64位VBA打开文件对话框

nitou

感谢作者
出处：http://www.cnblogs.com/liweis/

Option Explicit

Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long

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

Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal Hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)

Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const CSIDL_DRIVES As Long = &H11
Private Const WM_USER As Long = &H400
Private Const MAX_PATH As Long = 260            '// message from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3  '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4  '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN As Long = 5         '// provides IUnknown to client. lParam: IUnknown*
'// messages to browser
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only

Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10
Private Const OFN_ENABLESIZING As Long = &H800000
Private Const OFS_MAXPATHNAME As Long = 260

'OFS_FILE_OPEN_FLAGS:
Private Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or _
             OFN_LONGNAMES Or _
             OFN_CREATEPROMPT Or _
             OFN_NODEREFERENCELINKS

Private Type OPENFILENAME
    lStructSize As Long
    hWndOwner As LongPtr
    hInstance As LongPtr
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As LongPtr
    lpTemplateName As String
End Type

Private Type BrowseInfo
    hWndOwner As LongPtr
    pIDLRoot As LongPtr
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As LongPtr
    lParam As LongPtr
    iImage As Long
End Type

'====== File Browsers for 64 bit VBA 7 ========

'选择文件
Public Function FileBrowseOpen(ByVal sInitFolder As String, ByVal sTitle As String, ByVal sFilter As String, ByVal nFilterIndex As Integer, Optional ByVal multiSelect = False) As String

    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long

    sInitFolder = CorrectPath(sInitFolder)
    OpenFile.lpstrInitialDir = sInitFolder

    ' Swap filter separator for api separator
    sFilter = Replace(sFilter, "|", VBA.Chr(0))

    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = nFilterIndex
    OpenFile.lpstrTitle = sTitle



    OpenFile.hWndOwner = 0
    OpenFile.lpstrFile = VBA.String(257, 0)
    OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
    OpenFile.lStructSize = LenB(OpenFile)

    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

    If Not multiSelect Then
        OpenFile.flags = 0
    Else
        OpenFile.flags = OFS_FILE_OPEN_FLAGS + OFN_ALLOWMULTISELECT
    End If

    lReturn = GetOpenFileName(OpenFile)

    Dim result As String
    If lReturn = 0 Then
        FileBrowseOpen = ""
    Else
        If multiSelect Then
            Dim str As String
            str = VBA.Trim(Replace(VBA.Trim(OpenFile.lpstrFile), vbNullChar, ","))
            Dim ed As String
            ed = VBA.Mid(str, Len(str))
            While (ed = ",")
                str = VBA.Trim(VBA.Left(str, Len(str) - 1))
                ed = VBA.Mid(str, VBA.Len(str))
            Wend
            FileBrowseOpen = str
        Else
            FileBrowseOpen = VBA.Trim(VBA.Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
        End If
    End If
End Function

'获取文件列表
Public Function GetFiles( _
    ByVal sInitFolder As String, _
    ByVal sTitle As String, _
    ByVal sFilter As String, _
    ByVal nFilterIndex As Integer) As String()

    Dim strReturn As String

    strReturn = FileBrowseOpen(sInitFolder, sTitle, sFilter, nFilterIndex, True)
    GetFiles = Split(strReturn, ",")

End Function
'保存文件
Public Function FileBrowseSave(ByVal sDefaultFilename As String, ByVal sInitFolder As String, ByVal sTitle As String, ByVal sFilter As String, ByVal nFilterIndex As Integer, Optional ByVal overwritePrompt = False) As String

    Dim PadCount As Integer
    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long

    sInitFolder = CorrectPath(sInitFolder)

    ' Swap filter separator for api separator
    sFilter = Replace(sFilter, "|", Chr(0))

    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = 1
    OpenFile.hWndOwner = 0

    PadCount = 260 - Len(sDefaultFilename)
    OpenFile.lpstrFile = sDefaultFilename & String(PadCount, Chr(0))
    'OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
    OpenFile.lStructSize = LenB(OpenFile)

    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = sInitFolder
    OpenFile.lpstrTitle = sTitle
    If Not IsMissing(overwritePrompt) And overwritePrompt Then
        OpenFile.flags = OFN_OVERWRITEPROMPT
    Else
        OpenFile.flags = 0
    End If
    lReturn = GetSaveFileName(OpenFile)

    If lReturn = 0 Then
        FileBrowseSave = ""
    Else
        FileBrowseSave = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
    End If

End Function

Private Function CorrectPath(ByVal sPath As String) As String
    If VBA.Right$(sPath, 1) = "\" Then
        If Len(sPath) > 3 Then sPath = VBA.Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
    Else
        If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
    End If
    CorrectPath = sPath
End Function

'文件夹是否存在
Public Function FolderExists(ByVal sFolderName As String) As Boolean
    Dim att As Long
    On Error Resume Next
    att = GetAttr(sFolderName)
    If Err.Number = 0 Then
    FolderExists = True
    Else
    Err.Clear
    FolderExists = False
    End If
    On Error GoTo 0
End Function

萧萧生

看不懂
学习学习

chixun99

用的API的，代码确实有点繁琐。桌子就没给vba留个接口。

hzyhzjjzh

谢谢分享

nslove44202489

我的博客有解决办法的，https://www.cnblogs.com/NanShengBlogs/p/16095282.html

pmq

http://bbs.mjtd.com/thread-175969-1-1.html
64位VBA调用打开和对话框

wuyunpeng888

'以下是cCommonDialog类的代码，建个类改名，把下面的代码放进去

#If VBA7 Then
    Private Declare PtrSafe Function FILEOPEN Lib "CommonDialog.dll" (ByVal hOwner As Long, ByVal Title As String, ByVal FileSpec As String, ByVal Path As String, _
                                                                      ByVal Fileter As String, ByVal DefExtension As String, ByVal FLAGS As Long, ByVal CenterFlag As Integer) As String
    Private Declare PtrSafe Function FILESAVE Lib "CommonDialog.dll" (ByVal hOwner As Long, ByVal Title As String, ByVal FileSpec As String, ByVal Path As String, _
                                                                      ByVal Fileter As String, ByVal DefExtension As String, ByVal FLAGS As Long, ByVal CenterFlag As Integer) As String
    Private Declare PtrSafe Function BROWSEFOLDER Lib "CommonDialog.dll" (ByVal hOwner As Long, ByVal Title As String, ByVal Path As String) As String
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
    Private Declare Function FILEOPEN Lib "CommonDialog32.dll" Alias "FILEOPEN@32" (ByVal hOwner As Long, ByVal Title As String, ByVal FileSpec As String, ByVal Path As String, _
                                                                      ByVal Fileter As String, ByVal DefExtension As String, ByVal FLAGS As Long, ByVal CenterFlag As Integer) As String
    Private Declare Function FILESAVE Lib "CommonDialog32.dll" Alias "FILESAVE@32" (ByVal hOwner As Long, ByVal Title As String, ByVal FileSpec As String, ByVal Path As String, _
                                                                      ByVal Fileter As String, ByVal DefExtension As String, ByVal FLAGS As Long, ByVal CenterFlag As Integer) As String
    Private Declare Function BROWSEFOLDER Lib "CommonDialog32.dll" Alias "BROWSEFOLDER@12" (ByVal hOwner As Long, ByVal Title As String, ByVal Path As String) As String
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

'创建并显示打开的通用对话框。返回所选的文件名，如果选择了多个文件将会用“|”分隔列表。若无选择返回空字符。
'nFilename = FILEOPEN(hWndForm, 标题, 默认文件名, 初始目录, 筛选器, 默认扩展名, Flags, 中心)
'hOwner:       （如果有） 的父窗口的句柄
'Title:      标题将显示为对话框的标题?
'FileSpec:     要显示的默认文件名。默认文件夹最后不能带 \ 字符
'Path:  对话框中将显示初始目录。如果此值为 null，则使用当前目录。
'Filter:      要在对话框中显示的文件的筛选器： 说明。这是一个分隔的字符串，将在"文件类型"组合框中产生可用的选项。
'例： "图像文件(*.bmp;*.jpg;*.jpeg;*.gif;*.png)|*.bmp;*.jpg;*.jpeg;*.gif;*.png"
'DefExtension: 默认文件扩展名适用于文件名，如果用户不提供一个。
'Flags:          Win32 帮助下"OpenFileName"文件中所述的一个或多个值的组合。
'E.g.: OFN_ALLOWMULTISELECT Or OFN_FILEMUSTEXIST Or OFN_NOCHANGEDIR
'CenterFlag:   TRUE  对中心对话框上的桌面屏幕。

Private Const OFN_ALLOWMULTISELECT = &H200          '指定文件名列表框允许多选?
Private Const OFN_CREATEPROMPT = &H2000             '如果用户指定了一个不存在的文件，这个标记使用对话框能提示用户是否新建这个文件。
Private Const OFN_ENABLEHOOK = &H20                 '激活在lpfnHook成员中指定的钩子函数?
Private Const OFN_ENABLETEMPLATE = &H40             '当用户打开一个文件夹时，引起对话框发送CDN_INCLUDEITEM通知消息到你的OFNHookProc程序。
Private Const OFN_ENABLETEMPLATEHANDLE = &H80       'OFN_ENABLETEMPLATEHANDLE  指出hInstance成员能识别的包含预载对话框模板的数据块。如果这个标记被指定的，系统忽略lpTemplateName。
Private Const OFN_EXPLORER = &H80000                'OFN_EXPLORER 指出任何打开或另存为对话框使用新的Explorer风格的用户化模块?
Private Const OFN_EXTENSIONDIFFERENT = &H400        'OFN_EXTENSIONDIFFERENT 指定用户输入的一个文件的扩展名与lpstrDefExt指定的扩展名不同?
Private Const OFN_FILEMUSTEXIST = &H1000            'OFN_FILEMUSTEXIST 指定用户仅可以在文件名登录字段中输入已存在的文件的名字?
Private Const OFN_HIDEREADONLY = &H4                'OFN_HIDEREADONLY 隐藏只读复选框
Private Const OFN_LONGNAMES = &H200000              'OFN_LONGNAMES           对于旧风格对话框，这个标记引起对话框使用长文件名。
Private Const OFN_NOCHANGEDIR = &H8                 'OFN_NOCHANGEDIR         如果当搜索文件时用户改变了目录的时候，恢复当前目录到它的初始值。
Private Const OFN_NODEREFERENCELINKS = &H100000     'OFN_NODEREFERENCELINKS  引导对话框为选择的快捷方式（.LNK）文件返回路径和文件名。
Private Const OFN_NOLONGNAMES = &H40000             'OFN_NOLONGNAMES   对于旧风格对话框，这个标识引起对话框去使用短文件名（8.3格式）。
Private Const OFN_NONETWORKBUTTON = &H20000         'OFN_NONETWORKBUTTON 隐藏和显示风格按钮?
Private Const OFN_NOREADONLYRETURN = &H8000         'OFN_NOREADONLYRETURN  指定返回的文件不带有只读复选框，不是在写保护的目录中。
Private Const OFN_NOTESTFILECREATE = &H10000        'OFN_NOTESTFILECREATE 指定文件不是在对话框关闭前建立的?
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2             'OFN_OVERWRITEPROMPT  如果选择的文件已经存在，使用另存为对话框产生一个消息框。用户必须确认是否覆盖这个文件。
Private Const OFN_PATHMUSTEXIST = &H800             'OFN_PATHMUSTEXIST 指定用户仅能输入的路径和文件名?
Private Const OFN_READONLY = &H1                    'OFN_READONLY           当对话框建立时，显示被选择的只读复选框。
Private Const OFN_SHAREAWARE = &H4000               'OFN_SHAREAWARE          指出如果调用OpenFile函数因为网络共享冲突而失败，这个错误被忽略并且对话框返回选择的文件名。
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Private Const OFN_SHOWHELP = &H10                   'OFN_SHOWHELP 使对话框显示帮助按钮?

'打开文件对话框
'FILEOPEN hWnd, "打开文件:", "", "c:\", "Text Files(*.txt)|*.txt|AutoCAD Files(*.dwg)|*.dwg", "dwg", OFN_ALLOWMULTISELECT + OFN_EXPLORER, 1
Public Function openDiaLog(ByVal OwnerTitle As String, ByVal InitPath As String, ByVal Filter As String, ByVal extName As String, ByVal MulSelect As Boolean) As String
Dim hWnd As Long

hWnd = FindWindow(vbNullString, Application.Caption)
openDiaLog = FILEOPEN(hWnd, "打开文件:", "", InitPath, Filter, extName, IIf(MulSelect = True, OFN_ALLOWMULTISELECT, 0) + OFN_EXPLORER, 1)
End Function

'保存文件对话框
'FILESAVE hWnd, "保存文件:", "", "c:\", "Text Files(*.txt)|*.txt|AutoCAD Files(*.dwg)|*.dwg", "dwg", OFN_EXPLORER, 1
Public Function SaveDiaLog(ByVal OwnerTitle As String, ByVal InitPath As String, ByVal Filter As String, ByVal extName As String) As String
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Application.Caption)
SaveDiaLog = FILESAVE(hWnd, "保存文件:", "", InitPath, Filter, extName, OFN_EXPLORER, 1)
End Function

'文件夹选择对话框
'MsgBox BROWSEFOLDER(hWnd, "文件夹:", "c:\")
Public Function DirDiaLog(ByVal OwnerTitle As String, ByVal InitPath As String) As String
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Application.Caption)
DirDiaLog = BROWSEFOLDER(hWnd, "文件夹:", InitPath)
End Function


Private Sub Class_Initialize()
Dim strPath As String, fileName As String
'拷文件到CAD程序文件夹
On Error Resume Next
strPath = Application.VBE.ActiveVBProject.fileName
strPath = Left(strPath, InStrRev(strPath, "\"))
fileName = strPath & "CommonDialog.dll"
FileCopy fileName, Application.Path & "\CommonDialog.dll"
fileName = strPath & "CommonDialog32.dll"
FileCopy fileName, Application.Path & "\CommonDialog32.dll"

End Sub

wuyunpeng888

‘下面是调用的例子，可以把代码复制到ThisDrawing模块里测试

Dim diaLog As New cCommonDialog

'找开文件对话框
Public Sub openDiaLog()
MsgBox diaLog.openDiaLog(Application.Caption, "c:\", "Text Files(*.txt)|*.txt|AutoCAD Files(*.dwg)|*.dwg", "dwg", True)
End Sub

'保存文件对话框
Public Sub SaveDiaLog()
MsgBox diaLog.SaveDiaLog(Application.Caption, "c:\", "Text Files(*.txt)|*.txt|AutoCAD Files(*.dwg)|*.dwg", "dwg")
End Sub

'文件夹选择对话框
Public Sub DirDiaLog()
MsgBox diaLog.DirDiaLog(Application.Caption, "c:\")
End Sub

wuyunpeng888

类里用了CommonDialog.dll和CommonDialog32.dll，这两个文件系统里应该是有，例子里为了以防万一系统丢失所以把这两个文件也放在一起了，这两个文件在系统里应该能找到，网上应该也能下到