[VBA程序]：[VBA程序]：[VBA程序]：[VBA程序]：一个关于对话框的问题！

左权

请问怎么调出浏览文件夹对话框？如附件中的图片。

tiancao1001

你好这个问题我帮你回答了，这个要用到api

Option Explicit
Public Type SHFILEOPSTRUCT

     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Integer
     fAborted As Boolean
     hNameMaps As Long
     sProgress As String

End Type
Public Type BrowseInfo

     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As String
     lpszTitle As String
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long

End Type
Global FileDestination As String
Public Const BIF_BROWSEINCLUDEURLS = 128
Public Const BIF_NEWDIALOGSTYLE = 64
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_STATUSTEXT = 4
Public Const BIF_USENEWUI = 64
Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function SHBrowseForFolder Lib "shell32" _
     (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
     (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
     (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Public Const FO_COPY = &H2
Public Const FO_DELETE = &H3
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
Public Const FOF_ALLOWUNDO = &H40
Public Const FOF_CONFIRMMOUSE = &H2
Public Const FOF_FILESONLY = &H80                  '  on *.*, do only files
Public Const FOF_MULTIDESTFILES = &H1
Public Const FOF_NOCONFIRMATION = &H10             '  Don't prompt the user.
Public Const FOF_NOCONFIRMMKDIR = &H200            '  don't confirm making any needed dirs
Public Const FOF_RENAMEONCOLLISION = &H8
Public Const FOF_SILENT = &H4                      '  don't create progress/report
Public Const FOF_SIMPLEPROGRESS = &H100            '  means don't show names of files
Public Const FOF_WANTMAPPINGHANDLE = &H20          '  Fill in SHFILEOPSTRUCT.hNameMappings

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Public Declare Function SHFileOperation Lib "shell32.dll" Alias _
     "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Dim StartFolder As String


Public Function ShellRename(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As String
     Dim Dick As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar
     Dick = FileDestination
     With SHFileOp

          .wFunc = &H4
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO
          .pTo = Dick
     End With

     ShellRename = SHFileOperation(SHFileOp)


End Function


Public Function ShellCopy(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As Variant
     Dim Dick As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar
     Dick = FileDestination
     With SHFileOp

          .wFunc = &H2
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO
          .pTo = Dick
     End With

     ShellCopy = SHFileOperation(SHFileOp)


End Function


Public Function ShellMove(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As Variant
     Dim Dick As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar
     Dick = FileDestination
     With SHFileOp

          .wFunc = &H1
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO
          .pTo = Dick
     End With

     ShellMove = SHFileOperation(SHFileOp)


End Function


Public Function ShellDelete(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar

     With SHFileOp

          .wFunc = FO_DELETE
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO

     End With

     ShellDelete = SHFileOperation(SHFileOp)


End Function


Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String, Optional sStartFolder) As String


     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

     With udtBI

          .hwndOwner = hwndOwner
          .lpszTitle = sPrompt
          .ulFlags = BIF_BROWSEINCLUDEURLS Or BIF_NEWDIALOGSTYLE Or BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT Or BIF_USENEWUI
          If Not IsMissing(sStartFolder) Then
               StartFolder = sStartFolder & vbNullChar
               .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
          End If

     End With

     lpIDList = SHBrowseForFolder(udtBI)
     If lpIDList Then

          sPath = String$(MAX_PATH, 0)
          lResult = SHGetPathFromIDList(lpIDList, sPath)
          CoTaskMemFree lpIDList
          iNull = InStr(sPath, vbNullChar)
          If iNull Then

               sPath = Left$(sPath, iNull - 1)

          End If

     End If

     BrowseForFolder = sPath


End Function

Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
   On Error Resume Next
   Dim lpIDList As Long
   Dim ret As Long
   Dim sBuffer As String
   Select Case uMsg
       Case BFFM_INITIALIZED
           SendMessage hwnd, BFFM_SETSELECTION, 1, StartFolder
       Case BFFM_SELCHANGED
           sBuffer = Space(MAX_PATH)
           ret = SHGetPathFromIDList(lp, sBuffer)
           If ret = 1 Then
               SendMessage hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer
           End If
   End Select
   BrowseCallbackProc = 0
End Function

Private Function GetAddressofFunction(add As Long) As Long
    GetAddressofFunction = add
End Function

你还可以的到我的博客下载原文件
http://www.tiancao.net/blogview.asp?logID=74

左权

谢谢这位大哥啊！你真是好人啊！！！！

我们——

干什么的？说说

shaner143

强啊

icemy82

楼主厉害！

hzh2000

这么长，太复杂了