vb打开文件夹对话框，并可事先指定默认路径，打开指定目录的对话框

点击收藏

 

可以用SHBrowseForFolder来实现

'Objects:   Form1、Command1、Module1  
  'Form1:  
  Option   Explicit  
  Private   Const   BIF_RETURNONLYFSDIRS   =   1  
  Private   Const   BIF_DONTGOBELOWDOMAIN   =   2  
  Private   Const   MAX_PATH   =   260  
  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  
  Private   Declare   Function   lstrcat   Lib   "kernel32"   Alias   "lstrcatA"   (ByVal   lpString1   As   String,   ByVal   lpString2   As   String)   As   Long  
  Private   Declare   Function   LocalAlloc   Lib   "kernel32"   (ByVal   uFlags   As   Long,   ByVal   uBytes   As   Long)   As   Long  
  Private   Declare   Sub   CopyMemory   Lib   "kernel32"   Alias   "RtlMoveMemory"   (pDest   As   Any,   pSource   As   Any,   ByVal   dwLength   As   Long)  
  Private   Const   LPTR   =   (&H0   Or   &H40)  
  Private   Type   BrowseInfo  
                  hWndOwner             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   Function   MyAddressOf(AddressOfX   As   Long)   As   Long  
  MyAddressOf   =   AddressOfX  
  End   Function  
   
  Private   Sub   Command1_Click()  
  Dim   lpIDList   As   Long  
  Dim   sBuffer   As   String  
  Dim   szTitle   As   String  
  Dim   tBrowseInfo   As   BrowseInfo  
  Dim   Ret   As   Long  
  szTitle   =   "This   is   the   title"  
  Dim   sPath   As   String  
  sPath   =   VBA.InputBox("初始路径:",   ,   "C:/program   files")  
  With   tBrowseInfo  
          .hWndOwner   =   Me.hWnd  
          .lpszTitle   =   lstrcat(szTitle,   "")  
          .ulFlags   =   BIF_RETURNONLYFSDIRS   +   BIF_DONTGOBELOWDOMAIN  
          .lpfnCallback   =   MyAddressOf(AddressOf   BrowseForFolders_CallbackProc)  
          Ret   =   LocalAlloc(LPTR,   VBA.Len(sPath)   +   1)  
          CopyMemory   ByVal   Ret,   ByVal   sPath,   VBA.Len(sPath)   +   1  
          .lParam   =   Ret  
  End   With  
  lpIDList   =   SHBrowseForFolder(tBrowseInfo)  
  If   (lpIDList)   Then  
      sBuffer   =   VBA.Space(MAX_PATH)  
      SHGetPathFromIDList   lpIDList,   sBuffer  
      sBuffer   =   VBA.Left(sBuffer,   VBA.InStr(sBuffer,   vbNullChar)   -   1)  
      MsgBox   sBuffer  
      End   If  
  End   Sub  
   
  'Module1:  
  Option   Explicit  
  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   BFFM_INITIALIZED   As   Long   =   1  
  Public   Function   BrowseForFolders_CallbackProc(ByVal   hWnd   As   Long,   ByVal   uMsg   As   Long,   ByVal   lParam   As   Long,   ByVal   lpData   As   Long)   As   Long  
  If   uMsg   =   BFFM_INITIALIZED   Then  
      SendMessage   hWnd,   BFFM_SETSELECTIONA,   True,   ByVal   lpData  
  End   If  
  End   Function