【求助】现在VB如何调用CAD？WIN10下

fjfhgdwfn

原来用GetObject和CreateObject现在都用不了，哪位分享下方法。

mikewolf2k

VB是32位的，如果ACAD是64位的，可能不能调用。另外win10的安全性又大大提高，相当的麻烦。

fjfhgdwfn

mikewolf2k 发表于 2019-7-19 10:59
VB是32位的，如果ACAD是64位的，可能不能调用。另外win10的安全性又大大提高，相当的麻烦。

有什么好的方法来处理了？

风言无际

CreateObject其实在WIN7 32位系统下有的时候也不能很好的生成CAD实例，尤其是在电脑安装了多个CAD版本的情况下，这情况更为严重，一般我用SHELL的方法解决这一问题，并且在WIN10上也好用。以下是代码：

风言无际

'以下插入模块中
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any,
lpcbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Const HKEY_CLASSES_ROOT& = &H80000000
Public Const HKEY_CURRENT_USER& = &H80000001
Public Const HKEY_LOCAL_MACHINE& = &H80000002
Public Const HKEY_USERS& = &H80000003
Public Const HKEY_PERFORMANCE_DATA& = &H80000004
Public Const HKEY_CURRENT_CONFIG& = &H80000005
Public Const HKEY_DYN_DATA& = &H80000006
Public Const REG_NONE = 0 'No value type
Public Const REG_SZ = 1 'Unicode nul terminated string
Public Const REG_EXPAND_SZ = 2 'Unicode nul terminated string
Public Const REG_BINARY = 3 'Free form binary
Public Const REG_DWORD = 4 '32-bit number
'检查指定的进程是否正在运行
Public Function IsRunning(exeName As String) As Boolean
    On Error GoTo Err
    Dim WMI
    Dim Obj
    Dim Objs
    IsRunning = False
    Set WMI = GetObject("WinMgmts:")
    Set Objs = WMI.InstancesOf("Win32_Process")
    For Each Obj In Objs
        If (InStr(UCase(exeName), UCase(Obj.Description)) <> 0) Then
            IsRunning = True
            If Not Objs Is Nothing Then Set Objs = Nothing
            If Not WMI Is Nothing Then Set WMI = Nothing
            Exit Function
        End If
    Next
    If Not Objs Is Nothing Then Set Objs = Nothing
    If Not WMI Is Nothing Then Set WMI = Nothing
    Exit Function
Err:
    If Not Objs Is Nothing Then Set Objs = Nothing
    If Not WMI Is Nothing Then Set WMI = Nothing
End Function
'获取当前使用的AUTOCAD程序的安装位置
Public Function GetACADPath()
    Dim sPath$, sKey$
    Dim sValue As String, sUseValue$, lLength&, lType&
    Dim KeyCADFile&, KeyACad&, KeyCLSID&, KeyItem1&, KeyItem2&
   
    GetACADPath = ""
   
    '打开Classes Root (AutoCAD.Application)
    sKey = ".dwg"
    If RegOpenKey(HKEY_CLASSES_ROOT, sKey, KeyCADFile) = 0 Then
        'Length
        lLength = 100
        lType = REG_SZ
        sValue = String(lLength, Chr$(0))
        If RegQueryValueEx(KeyCADFile, vbNullString, 0, lType, ByVal sValue, lLength) = 0 Then
           sUseValue = Left$(sValue, InStr(sValue, Chr$(0)) - 1)
        End If
        '关闭Key ACad File
        Call RegCloseKey(KeyCADFile)
    End If
   
    '打开Classes Root (AutoCAD.Application)
    sKey = sUseValue
    If RegOpenKey(HKEY_CLASSES_ROOT, sKey, KeyACad) = 0 Then
        '打开Key CLSID Of AutoCAD.Application
        sKey = "CLSID"
        If RegOpenKey(KeyACad, sKey, KeyCLSID) = 0 Then
            'Length
            lLength = 100
            lType = REG_SZ
            sValue = String(lLength, Chr$(0))
            If RegQueryValueEx(KeyCLSID, vbNullString, 0, lType, ByVal sValue, lLength) = 0 Then
                sUseValue = Left$(sValue, InStr(sValue, Chr$(0)) - 1)
            End If
            '关闭Key CLSID
            Call RegCloseKey(KeyCLSID)
        End If
        '关闭Key ACad
        Call RegCloseKey(KeyACad)
    End If
   
    '打开Classes Root (CLSID)
    sKey = "CLSID"
    If RegOpenKey(HKEY_CLASSES_ROOT, sKey, KeyCLSID) = 0 Then
        '打开Key ACAD CLSID Of CLSID
        sKey = Trim$(UCase(sUseValue))
        If RegOpenKey(KeyCLSID, sKey, KeyItem1) = 0 Then
            '打开Key ACAD CLSID Of CLSID
            sKey = "LocalServer32"
            If RegOpenKey(KeyItem1, sKey, KeyItem2) = 0 Then
                'Length
                lLength = 255
                sValue = String(lLength, Chr$(0))
                If RegQueryValueEx(KeyItem2, vbNullString, 0, lType, ByVal sValue, lLength) = 0 Then
                    GetACADPath = Left$(sValue, InStr(sValue, Chr$(0)) - 1)
                End If
                '关闭Key Item 2
                Call RegCloseKey(KeyItem2)
            End If
            '关闭Key Item 1
            Call RegCloseKey(KeyItem1)
        End If
        '关闭Key CLSID
        Call RegCloseKey(KeyCLSID)
    End If
End Function
'以下放入窗体FORM1的COMMAND1的CLICK事件中
Private Sub Command1_Click()
    On Error GoTo ErrorHandler
    Dim Acad As Object 'AcadApplication
    Dim Adoc As Object 'AcadDocument
    '(注册表中查到当前使用的AUTOCAD的安装位置，用SHELL打开)
    '----但是根据微软网站(https://support.microsoft.com/zh-cn/help/238610/getobject-or-getactiveobject-cannot-find-a-running-office-application)介绍
    '----采用SHELL方法调用了应用程序后，它不会立即注册其正在运行的对象，所以立即捕捉程序对象会出现429错误，
    '----以下方法采用的是微软官方提供的变通方法，基本可以保证每次都能成功的启动AUTOCAD。(会尝试30000次，每次等待0.005秒，如果电脑配置太差，150秒内还启动不了，那就不再继续尝试了)
    Dim sPath As String
    If IsRunning("acad.exe") = False Then
        sPath = GetACADPath()
        If Trim(sPath) = "" Then
           Exit Sub
        End If
        Shell Trim(sPath), vbMinimizedFocus '用SHELL启动AUTOCAD
    End If
    Form1.SetFocus '本窗体重新获得焦点，保证AUTOCAD能注册到运行对象表（ROT）中
    intSection = 1 '作一个标记，用于跳转
    Set Acad = GetObject(, "AutoCAD.Application")
    intSection = 0 '能运行到此，说明上面的语句已经正确获取到AUTOCAD对象了
    Acad.Visible = True
    Set Adoc = Acad.ActiveDocument
ErrorHandler:
    If intSection = 1 Then
        intTries = intTries + 1
        If intTries < 30000 Then
            Sleep 5
            Resume '继续运行intSection = 1后的代码
        End If
    End If
End Sub

sunkira007

用vb.net吧，完美支持

maiqi

风言无际：你好，我qq是2401979811，我想用vb读取access数据库，然后成图，现状就是两个问题1、如何不受cad版本限制，2、能否发一些相关例子的源码，谢谢！

t18-13nil

用vb.net可以不受CAD版本限制，受限是他们写死了，不写版本号就是默认安装的版本

sunny_8848

我把代码放在Excel 里面，手工运行代码可以启动，直接点击按钮不行，不知道什么原因