• 解决64位VBA的打开文件及文件兼容问题


    问题描述

    最近修改一个非常古老的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
  • 相关阅读:
    宝宝多大可以用枕头?别被忽悠,不到年龄用枕头伤颈椎又容易窒息
    如何提高英文阅读水平?
    古典音乐进阶之路
    循环、行列转换、跨表更新的综合案列
    GROUPING 运算符
    事务
    聚合函数
    Airtest自动化测试
    mac更新nodejs
    更新package.json里所有模块
  • 原文地址:https://www.cnblogs.com/liweis/p/15912538.html
Copyright © 2020-2023  润新知