查找文件夹

Option Explicit
   
  Private Type BrowseInfo
          lngHwnd                 As Long
          pIDLRoot               As Long
          pszDisplayName   As Long
          lpszTitle             As Long
          ulFlags                 As Long
          lpfnCallback       As Long
          lParam                   As Long
          iImage                   As Long
  End Type
   
  Private Const BIF_RETURNONLYFSDIRS = 1
‘Private Const BIF_RETURNONLYFSDIRS = 100-----〉多一个新建文件夹的按钮
  Private Const MAX_PATH = 260
   
  Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
          (ByVal hMem As Long)
   
  Private Declare Function lstrcat Lib "Kernel32" _
        Alias "lstrcatA" (ByVal lpString1 As String, _
        ByVal lpString2 As String) As Long
         
  Private Declare Function SHBrowseForFolder Lib "shell32" _
        (lpbi As BrowseInfo) As Long
         
  Private Declare Function SHGetPathFromIDList Lib "shell32" _
        (ByVal pidList As Long, ByVal lpBuffer As String) As Long
   
  Public Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String
   
          On Error GoTo ehBrowseForFolder         'Trap   for   errors
   
          Dim intNull     As Integer
          Dim lngIDList     As Long, lngResult       As Long
          Dim strPath     As String
          Dim udtBI     As BrowseInfo
   
          'Set   API   properties   (housed   in   a   UDT)
          With udtBI
                  .lngHwnd = lngHwnd
                  .lpszTitle = lstrcat(strPrompt, "")
                  .ulFlags = BIF_RETURNONLYFSDIRS
          End With
   
          'Display   the   browse   folder...
          lngIDList = SHBrowseForFolder(udtBI)
   
          If lngIDList <> 0 Then
                  'Create   string   of   nulls   so   it   will   fill   in   with   the   path
                  strPath = String(MAX_PATH, 0)
   
                  'Retrieves   the   path   selected,   places   in   the   null
                    'character   filled   string
                  lngResult = SHGetPathFromIDList(lngIDList, strPath)
   
                  'Frees   memory
                  Call CoTaskMemFree(lngIDList)
   
                  'Find   the   first   instance   of   a   null   character,
                    'so   we   can   get   just   the   path
                  intNull = InStr(strPath, vbNullChar)
                  'Greater   than   0   means   the   path   exists...
                  If intNull > 0 Then
                          'Set   the   value
                          strPath = Left(strPath, intNull - 1)
                  End If
          End If
   
          'Return   the   path   name
          BrowseForFolder = strPath
          Exit Function     'Abort
   
ehBrowseForFolder:
   
          'Return   no   value
          BrowseForFolder = Empty
   
  End Function
 
   
  Private Sub Command1_Click()
          Debug.Print BrowseForFolder(Me.hWnd, "a")
  End Sub