问题描述

最近修改一个非常古老的CAD插件程序，由VBA编写，在32位软件下没问题，但在64位上出现PtrSafe、Addressof、 CommonDialog无法调用等问题。通过研究测试，重写了文件打开、文件保存和文件夹打开的操作方法，实用对64位系统和高版本CAD的支持。

操作系统：Win10 64位

CAD版本： AutoCAD 2016 x64

文件浏览

文件打开、文件保存：

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, "|", Chr(0))

    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = nFilterIndex
    OpenFile.lpstrTitle = sTitle
    
    
    
    OpenFile.hWndOwner = 0
    OpenFile.lpstrFile = 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 = Trim(Replace(Trim(OpenFile.lpstrFile), vbNullChar, ","))
            Dim ed As String
            ed = Mid(str, Len(str))
            While (ed = ",")
                str = Trim(Left(str, Len(str) - 1))
                ed = Mid(str, Len(str))
            Wend
            FileBrowseOpen = str
        Else
            FileBrowseOpen = Trim(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 Right$(sPath, 1) = "\" Then
        If Len(sPath) > 3 Then sPath = 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

文件夹浏览

Option Explicit
#If VBA7 Then
  Private Type BrowseInfo
    Owner As LongPtr
    RootIdl As LongPtr
    DisplayName As String
    Title As String
    flags As Long
    CallbackAddress As LongPtr
    CallbackParam As LongPtr
    Image As Long
  End Type
 
  Private Type SHITEMID
    cb As Long
    abID As Byte
  End Type
 
  Private Type ITEMIDLIST
    mkid As SHITEMID
  End Type
#Else
  Private Type BrowseInfo
    Owner As Long
    RootIdl As Long
    DisplayName As String
    Title As String
    flags As Long
    CallbackAddress As Long
    CallbackParam As Long
    Image As Long
  End Type
#End If
Private Const MAX_PATH_Unicode As Long = 519 ' 260 * 2 - 1
Private Const MAX_PATH = MAX_PATH_Unicode 'As Long = 260

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSELECTIONA = WM_USER + 102
Private Const BFFM_SETSELECTION = BFFM_SETSELECTIONA
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
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 BIF_RETURNONLYFSDIRS   As Long = &H1 'only file system directories
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2  'no network folders below domain level
Private Const BIF_STATUSTEXT As Long = &H4         'include status area for callback
Private Const BIF_RETURNFSANCESTORS As Long = &H8  'only return file system ancestors
Private Const BIF_EDITBOX As Long = &H10           'add edit box
Private Const BIF_NEWDIALOGSTYLE As Long = &H40    'use the new dialog layout
Private Const BIF_UAHINT As Long = &H100
Private Const BIF_NONEWFOLDERBUTTON As Long = &H200 'hide new folder button
Private Const BIF_NOTRANSLATETARGETS As Long = &H400 'return lnk file
Private Const BIF_USENEWUI As Long = BIF_NEWDIALOGSTYLE Or BIF_EDITBOX
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 'only return computers
Private Const BIF_BROWSEFORPRINTER As Long = &H2000 'only return printers
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 'browse for everything
Private Const BIF_SHAREABLE As Long = &H8000 'sharable resources, requires BIF_USENEWUI
'class ID values
Private Const CSIDL_DESKTOP As Long = &H0
Private Const CSIDL_INTERNET As Long = &H1
Private Const CSIDL_PROGRAMS As Long = &H2
Private Const CSIDL_CONTROLS As Long = &H3
Private Const CSIDL_PRINTERS As Long = &H4
Private Const CSIDL_PERSONAL As Long = &H5
Private Const CSIDL_FAVORITES As Long = &H6
Private Const CSIDL_STARTUP As Long = &H7
Private Const CSIDL_RECENT As Long = &H8
Private Const CSIDL_SENDTO As Long = &H9
Private Const CSIDL_BITBUCKET As Long = &HA 'reycle bin
Private Const CSIDL_STARTMENU As Long = &HB
Private Const CSIDL_MYDOCUMENTS As Long = &HC
Private Const CSIDL_MYMUSIC As Long = &HD
Private Const CSIDL_MYVIDEO As Long = &HE
Private Const CSIDL_UNUSED1 As Long = &HF '&HF not currently implemented
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Private Const CSIDL_DRIVES As Long = &H11
Private Const CSIDL_NETWORK As Long = &H12
Private Const CSIDL_NETHOOD As Long = &H13
Private Const CSIDL_FONTS As Long = &H14
Private Const CSIDL_TEMPLATES As Long = &H15
Private Const CSIDL_COMMON_STARTMENU As Long = &H16
Private Const CSIDL_COMMON_PROGRAMS As Long = &H17
Private Const CSIDL_COMMON_STARTUP As Long = &H18
Private Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Private Const CSIDL_APPDATA As Long = &H1A
Private Const CSIDL_PRINTHOOD As Long = &H1B
Private Const CSIDL_LOCAL_APPDATA As Long = &H1C
Private Const CSIDL_ALTSTARTUP As Long = &H1D
Private Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E
Private Const CSIDL_COMMON_FAVORITES As Long = &H1F
Private Const CSIDL_INTERNET_CACHE As Long = &H20
Private Const CSIDL_COOKIES As Long = &H21
Private Const CSIDL_HISTORY As Long = &H22
Private Const CSIDL_COMMON_APPDATA As Long = &H23
Private Const CSIDL_WINDOWS As Long = &H24
Private Const CSIDL_SYSTEM As Long = &H25
Private Const CSIDL_PROGRAM_FILES As Long = &H26
Private Const CSIDL_MYPICTURES As Long = &H27
Private Const CSIDL_PROFILE As Long = &H28
Private Const CSIDL_SYSTEMX86 As Long = &H29 'RISC only
Private Const CSIDL_PROGRAM_FILESX86 As Long = &H2A 'RISC only
Private Const CSIDL_PROGRAM_FILES_COMMON As Long = &H2B
Private Const CSIDL_PROGRAM_FILES_COMMONX86 As Long = &H2C 'RISC only
Private Const CSIDL_COMMON_TEMPLATES As Long = &H2D
Private Const CSIDL_COMMON_DOCUMENTS As Long = &H2E
Private Const CSIDL_COMMON_ADMINTOOLS As Long = &H2F
Private Const CSIDL_ADMINTOOLS As Long = &H30
Private Const CSIDL_CONNECTIONS As Long = &H31
Private Const CSIDL_COMMON_MUSIC As Long = &H35
Private Const CSIDL_COMMON_PICTURES As Long = &H36
Private Const CSIDL_COMMON_VIDEO As Long = &H37
Private Const CSIDL_RESOURCES As Long = &H38
Private Const CSIDL_RESOURCES_LOCALIZED As Long = &H39
Private Const CSIDL_COMMON_OEM_LINKS As Long = &H3A
Private Const CSIDL_CDBURN_AREA As Long = &H3B
Private Const CSIDL_UNUSED2 As Long = &H3C '&H3C not currently implemented
Private Const CSIDL_COMPUTERSNEARME As Long = &H3D


Private Const CSIDCC_DESKTOP = &H0
Private Const MAX_LEN = MAX_PATH_Unicode '= 260

Private mstrSTARTFOLDER As String
'-----------------------------------------------
' API calls.
'-----------------------------------------------
#If VBA7 Then
  Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As LongPtr, ByVal nFolder As Long, pidl As ITEMIDLIST) As LongPtr
  Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
  Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" (lpBrowseInfo As BrowseInfo) As LongPtr
  Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As LongPtr, ByVal Msg As Long, wParam As Any, lParam As Any) As LongPtr
#Else
  Private Declare Function SHGetSpecialFolderLocation Lib "Shell32.DLL" (ByVal hwndOwner As Long, ByVal Folder As Long, ByRef IDL As Long) As Long
  Private Declare Function SHGetPathFromIDList Lib "Shell32.DLL" (ByVal IDL As Long, ByVal Path As String) As Long
  Private Declare Function SHBrowseForFolder Lib "Shell32.DLL" (ByRef bi As BrowseInfo) As Long
  Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long

#End If

'---------------------------------------------------------------------------------------
Public Function BrowseFolders(ByVal strStartFolder As String, ByVal strTitle As String) As String
    BrowseFolders = DoBrowse(BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE, strTitle, strStartFolder)
End Function


'---------------------------------------------------------------------------------------
Private Function DoBrowse(ByVal lngFlags As Long, ByVal strTitle As String, ByVal strStartFolder As String) As String
    Dim stBif As BrowseInfo
    Dim strFolderPath As String
    #If VBA7 Then
    Dim lRet As Long
    Dim IDL As ITEMIDLIST
    Dim lngHandle As LongPtr
    #Else
    Dim lngHandle As Long
    #End If

       
     
    strFolderPath = Space(MAX_LEN)
    With stBif
      .Owner = 0
      .RootIdl = 0
      .DisplayName = Space(MAX_LEN)
      .Title = strTitle
      .flags = lngFlags
    End With
    If strStartFolder <> "" Then
      mstrSTARTFOLDER = strStartFolder & vbNullChar
      stBif.CallbackAddress = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
    End If
     
    lngHandle = SHBrowseForFolder(stBif)
    If (lngHandle <> 0) Then
      strFolderPath = Space(MAX_LEN)
      If (CBool(SHGetPathFromIDList(lngHandle, strFolderPath))) Then
        DoBrowse = TrimStringAtNull(strFolderPath)
      Else
        DoBrowse = TrimStringAtNull(strFolderPath = stBif.Title)
      End If
    End If
    Call GlobalFree(lngHandle)
     
End Function


Private Function TrimStringAtNull(ByVal strValue As String) As String
  
   Dim intPos As Integer
   
    intPos = InStr(strValue, vbNullChar)
    Select Case intPos
        Case Is > 1
            TrimStringAtNull = Left$(strValue, intPos - 1)
        Case 0
            TrimStringAtNull = intPos
        Case 1
            TrimStringAtNull = ""
    End Select
   
End Function

#If VBA7 Then
Private Function BrowseCallbackProc(ByVal Hwnd As LongPtr, ByVal uMsg As LongPtr, ByVal lP As LongPtr, ByVal pData As String) As LongPtr
#Else
Private Function BrowseCallbackProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal lP As Long, ByVal pData As Long) As Long
#End If
   On Error Resume Next
   Dim lpIDList As LongPtr
   Dim ret As Long
   Dim sBuffer As String
   Select Case uMsg
       Case BFFM_INITIALIZED
           Call SendMessage(Hwnd, BFFM_SETSELECTION, 1, ByVal mstrSTARTFOLDER)
       Case BFFM_SELCHANGED
           sBuffer = Space(MAX_PATH)
           ret = SHGetPathFromIDList(lP, sBuffer)
           If ret = 1 Then
              Call SendMessage(Hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
         End If
   End Select
   BrowseCallbackProc = 0
End Function
#If VBA7 Then
Private Function GetAddressofFunction(add As LongPtr) As LongPtr
#Else
Private Function GetAddressofFunction(add As Long) As Long
#End If
 GetAddressofFunction = add
End Function

Function IsFolderExists(strFullPath As String) As Boolean
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.IsFolderExists(strFullPath) Then IsFolderExists = True
    Set fso = Nothing
End Function

Function IsFileExists(ByVal strFileName As String) As Boolean
    Dim objFileSystem As Object
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    If objFileSystem.fileExists(strFileName) = True Then
        IsFileExists = True
    Else
        IsFileExists = False
    End If
End Function