终于解决了悬疑好多年的低版本CAD VBA不能在高版本CAD使用的问题
本篇文章是博主怀着激动的心情写下的，因为积累十余年的CAD2007 32位 VBA程序无法在CAD2010 64位以上的高版本上使用的阴云在盘旋于众人头几年以后终于在今天消散了。
CAD 2010以后的版本分为32位和64位，32位和64位分别只能装在32位和64位操作系统，虽然通过一些变通方法，将32位CAD装在64位操作系统也是可行的，但是使用不是很方便。现在新电脑一般安装win10操作系统，而win10操作系统就是64位，在其上只能安装CAD64位版本。此时，问题出现了，在CAD2007 编写的VBA程序不能在64位高版本CAD上运行，高版本CAD加载vba程序会报如下错误：
就是这个两个报错对话框一直让博主觉得高版本不能运行32位低版本vba程序。因此，电脑的win10操作系统会安装两个版本的CAD，分别是CAD2007和高版本CAD，CAD2007用来运行CAD VBA程序，高版本CAD用来编图，因为CAD2007有一些诸如调整图元上下层失效的bug，其功能和流畅度也不如高版本CAD。这种恼人的情形持续了好几年，直到最近，一位同事说，将这些对话框点击完以后，并将程序代码中的Declare用Declare PtrSafe替换以后，VBA程序在高版本CAD中也能运行，但是程序不稳定，容易造成CAD死机。
博主尝试了一下，除了少部分程序确实能运行，大部分程序不能正常运行，有些会造成CAD死机。
1、不能正常运行的程序问题出在：CAD2007中文件打开对话框控件（CommonDialog）在高版本中的CAD找不到了。即使引用加载了COMDLG32.OC控件，工具箱和窗口都不显示CommonDialog。
用bing搜索在中文的世界中找出的答案都不可行，转到国际版，换了几次关键词，一种可行的解决方案就浮现了，见如下代码，相关连接见参考文献。
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'====== File Browsers for 64 bit VBA 7 ========
Private 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)
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
strReturn = FileBrowseOpen(sInitFolder, sTitle, sFilter, nFilterIndex, True)
GetFiles = Split(strReturn, ",")
End Function
Private Sub CommandButton1_Click()
Dim initFolder As String
Dim filter As String
Dim fileNames() As String
Dim i As Integer
Dim lstDwgList
initFolder = ThisDrawing.Path
filter = "AutoCAD Drawing Files (*.dwg)|*.dwg|All Files (*.*)|*.*"
fileNames = GetFiles(initFolder, "Select Drawing Files", filter, 0)
If UBound(fileNames) > 0 Then
For i = 1 To UBound(fileNames)
lstDwgList.AddItem fileNames(0) & "\" & fileNames(i)
Next
End If
End Sub
#End If
2、死机的原因是VBA 打开目录的功能过时了。
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
上面2句要改成：
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)
Private Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As LongPtr
参考文献
https://forums.autodesk.com/t5/vba/old-vba-32-bit-does-not-run-on-new-64-bit/td-p/8391555