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

fjfhgdwfn 发表于 2019-7-18 16:39:22

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

mikewolf2k 发表于 2019-7-19 10:59:12

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

fjfhgdwfn 发表于 2019-7-20 11:48:50

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

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

风言无际 发表于 2019-7-21 21:33:40

本帖最后由风言无际于 2019-7-21 21:54 编辑

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

风言无际 发表于 2019-7-21 21:50:08

本帖最后由风言无际于 2019-7-21 21:56 编辑

'以下插入模块中
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 发表于 2019-8-1 16:12:43

用vb.net吧，完美支持

maiqi 发表于 2019-8-19 21:26:56

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

t18-13nil 发表于 2019-8-22 08:00:22

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

sunny_8848 发表于 2019-9-2 14:52:48

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

页: [1]

明经CAD社区's Archiver

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