请选择 进入手机版 | 继续访问电脑版

玩酷之家

 找回密码
 立即注册
搜索
热搜: 活动 交友 discuz
查看: 317|回复: 0

选择文件夹操作

[复制链接]

92

主题

97

帖子

361

积分

中级会员

Rank: 3Rank: 3

积分
361
发表于 2018-9-9 22:34:34 | 显示全部楼层 |阅读模式

  1. '---------------------------------------------------------------------------------------

  2. ' Module    : ModuleFile

  3. ' Author    : ROVAST

  4. ' Date      : 2014-4-22

  5. ' Purpose   : ????????????

  6. ' Function  : 1?????????

  7. '---------------------------------------------------------------------------------------



  8. Option Explicit



  9. Private Type BrowseInfo

  10.     hWndOwner As Long

  11.     pIDLRoot As Long

  12.     pszDisplayName As Long

  13.     lpszTitle As Long

  14.     ulFlags As Long

  15.     lpfnCallback As Long

  16.     lParam As Long

  17.     iImage As Long

  18. End Type

  19. Const BIF_RETURNONLYFSDIRS = 1

  20. Const BIF_NEWDIALOGSTYLE = &H40

  21. Const BIF_EDITBOX = &H10

  22. Const BIF_USENEWUI = BIF_NEWDIALOGSTYLE Or BIF_EDITBOX

  23. Const MAX_PATH = 260

  24. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

  25. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

  26. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long

  27. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long





  28. '---------------------------------------------------------------------------------------

  29. ' Procedure : BrowseForFolder

  30. ' Author    : ROVAST

  31. ' Date      : 2014-4-22

  32. ' Purpose   : ??????У???????????????? ????BrowseForFolder

  33. '---------------------------------------------------------------------------------------

  34. '

  35. Public Function BrowseForFolder(Optional sTitle As String = "??????????") As String

  36.     Dim iNull As Integer, lpIDList As Long, lResult As Long

  37.     Dim sPath As String, udtBI As BrowseInfo



  38.     With udtBI

  39.         .hWndOwner = 0 ' Me.hWnd

  40.         .lpszTitle = lstrcat(sTitle, "")

  41.         .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI

  42.     End With

  43.     lpIDList = SHBrowseForFolder(udtBI)

  44.     If lpIDList Then

  45.        sPath = String$(MAX_PATH, 0)

  46.         SHGetPathFromIDList lpIDList, sPath

  47.         CoTaskMemFree lpIDList

  48.        iNull = InStr(sPath, vbNullChar)

  49.         If iNull Then

  50.           sPath = Left$(sPath, iNull - 1)

  51.         End If

  52.     End If



  53.     BrowseForFolder = sPath

  54. End Function





  55. '---------------------------------------------------------------------------------------

  56. ' Procedure : BrowseForFolder1

  57. ' Author    : ROVAST

  58. ' Date      : 2014-4-22

  59. ' Purpose   : ???????·?????????????У? ????BrowseForFolder1 ?????

  60. '---------------------------------------------------------------------------------------

  61. '

  62. Public Function BrowseForFolder1(Optional sTitle As String = "??????????") As String

  63.     Dim iNull As Integer, lpIDList As Long, lResult As Long

  64.     Dim sPath As String, udtBI As BrowseInfo



  65.     With udtBI

  66.         .hWndOwner = 0 ' Me.hWnd

  67.         .lpszTitle = lstrcat(sTitle, "")

  68.         .ulFlags = BIF_RETURNONLYFSDIRS

  69.     End With

  70.     lpIDList = SHBrowseForFolder(udtBI)

  71.     If lpIDList Then

  72.        sPath = String$(MAX_PATH, 0)

  73.         SHGetPathFromIDList lpIDList, sPath

  74.         CoTaskMemFree lpIDList

  75.        iNull = InStr(sPath, vbNullChar)

  76.         If iNull Then

  77.           sPath = Left$(sPath, iNull - 1)

  78.         End If

  79.     End If



  80.     BrowseForFolder1 = sPath

  81. End Function
复制代码

  1. ‘窗体代码
  2. Private Sub Command1_Click()

  3.     Dim path1 As String

  4.     path1 = BrowseForFolder

  5.     MsgBox path1

  6. End Sub



  7. Private Sub Command2_Click()

  8.     Dim path As String

  9.     path = BrowseForFolder1

  10.     MsgBox path

  11. End Sub

复制代码



回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

Archiver|手机版|小黑屋|玩酷之家 ( 鄂ICP备14012049号-1 )

GMT+8, 2018-12-12 16:13 , Processed in 0.161336 second(s), 18 queries .

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表