问题描述
最近修改一个非常古老的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