vb 带新建文件夹的文件夹浏览窗口 BrowseForFolder

来源：互联网发布：java访问权限编辑：程序博客网时间：2024/05/16 12:25

感谢 Zezese（蓝酷云）同学

http://topic.csdn.net/t/20050807/23/4194587.html

Option   Explicit

Private   Type   BROWSEINFOTYPE
          hOwner   As   Long
          pidlRoot   As   Long
          pszDisplayName   As   String
          lpszTitle   As   String
          ulFlags   As   Long
          lpfn   As   Long
          lParam   As   Long
          iImage   As   Long
End   Type

Private   Declare   Function   LocalAlloc   Lib   "kernel32"   (ByVal   uFlags   As   Long,   ByVal   uBytes   As   Long)   As   Long
Private   Declare   Function   LocalFree   Lib   "kernel32"   (ByVal   hMem   As   Long)   As   Long
Private   Declare   Sub   CoTaskMemFree   Lib   "ole32.dll"   (ByVal   pv   As   Long)
Private   Declare   Sub   CopyMemory   Lib   "kernel32"   Alias   "RtlMoveMemory"   (pDest   As   Any,   pSource   As   Any,   ByVal   dwLength   As   Long)
Private   Declare   Function   SHBrowseForFolder   Lib   "shell32.dll"   Alias   "SHBrowseForFolderA"   (lpBROWSEINFOTYPE   As   BROWSEINFOTYPE)   As   Long
Private   Declare   Function   SHGetPathFromIDList   Lib   "shell32.dll"   Alias   "SHGetPathFromIDListA"   (ByVal   pidl   As   Long,   ByVal   pszPath   As   String)   As   Long
Private   Declare   Function   SendMessage   Lib   "user32"   Alias   "SendMessageA"   (ByVal   hwnd   As   Long,   ByVal   wMsg   As   Long,   ByVal   wParam   As   Long,   lParam   As   Any)   As   Long

Private   Const   WM_USER   =   &H400
Private   Const   BFFM_SETSELECTIONA   As   Long   =   (WM_USER   +   102)
Private   Const   BFFM_SETSELECTIONW   As   Long   =   (WM_USER   +   103)
Private   Const   LPTR   =   (&H0   Or   &H40)

Public   Enum   BROWSETYPE
          NONE   =   0
          PATHTEXT   =   16
          NEWFOLDER   =   64
End   Enum

Private   Sub   BrowseCallbackProcStr(ByVal   hwnd   As   Long,   ByVal   uMsg   As   Long,   ByVal   lParam   As   Long,   ByVal   lpData   As   Long)
          If   uMsg   =   1   Then
                  Call   SendMessage(hwnd,   BFFM_SETSELECTIONA,   True,   ByVal   lpData)
          End   If
End   Sub

Private   Function   FunctionPointer(FunctionAddress   As   Long)   As   Long
          FunctionPointer   =   FunctionAddress
End   Function

Public   Function   BrowseForFolder(ByVal   hwnd   As   Long,   ByVal   strTitle   As   String,   Optional   selectedPath   As   String,   Optional   ByVal   Flag   As   BROWSETYPE   =   0)   As   String
          Dim   Browse_for_folder   As   BROWSEINFOTYPE
          Dim   itemID   As   Long
          Dim   selectedPathPointer   As   Long
          Dim   tmpPath   As   String   *   256

          If   selectedPath   =   ""   Then   selectedPath   =   ""   '避免selectedPath未初始化而出错

          If   Not   Right(selectedPath,   1)   <>   "/"   Then
                  selectedPath   =   Left(selectedPath,   Len(selectedPath)   -   1)   '如果用户加了   "/"   则删除
          End   If

          With   Browse_for_folder
                  .hOwner   =   hwnd   '所有都窗口之句柄
                  .lpszTitle   =   strTitle   '对话框的标题
                  .ulFlags   =   Flag
                  .lpfn   =   FunctionPointer(AddressOf   BrowseCallbackProcStr)   '用于设置预设文件夹的回调函数
                  selectedPathPointer   =   LocalAlloc(LPTR,   Len(selectedPath)   +   1)   '分配一个字符串内存
                  Call   CopyMemory(ByVal   selectedPathPointer,   ByVal   selectedPath,   Len(selectedPath)   +   1)     '   拷贝那个路径到内存
                  .lParam   =   selectedPathPointer   '   预设的文件夹
          End   With
          itemID   =   SHBrowseForFolder(Browse_for_folder)   '执行API函数：BrowseForFolder
          If   itemID   Then
                  If   SHGetPathFromIDList(itemID,   tmpPath)   Then   '取得选定的文件夹
                          BrowseForFolder   =   Left(tmpPath,   InStr(tmpPath,   vbNullChar)   -   1)   '去掉多余的   null   字符
                  End   If
                  Call   CoTaskMemFree(itemID)   '释放内存
          End   If
          Call   LocalFree(selectedPathPointer)   '释放内存
End   Function