我知道这是旧的，但我有一个为此开发的应用程序。下面，我取了一些代码并添加了它以供参考。我试图尽可能地清理它，但我确信这里缺少一些功能。如果您有任何其他问题，请随时提出。
这段代码来自的应用程序是我们在这里开发的一个访问数据库。它保存着我们每张常青的 AutoCAD 图纸的记录。它有子表来存储修订条目以及支持文档（PDF 红线）、块参考信息、块属性参考信息、自定义绘图属性和图层信息。它的作用远不止于此，但这是另一个话题。
我还使用后期绑定而不是直接引用 AutoCAD，因为我们有不同版本的用户。这更难编码，但实现了相同的目标。
最后，我是一名自学成才的程序员，我知道我的代码并不完美，但它可以作为我们需要的一个很好的解决方案。任何建议表示赞赏和欢迎。我希望这对找到这个主题的人有所帮助。
按钮点击打开绘图
Private Sub TxtSketchURL_Click()
On Error GoTo ErrorHandler
SketchPath = "C:\Test.dwg" '<---Provide your autocad path here
Call getCadDwg(SketchPath)
'-------------------------------------------------------
ExitHere:
On Error Resume Next
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure TxtSketchURL_Click of VBA Document Form_Sketch", vbOKOnly
GoTo ExitHere
End Sub
Sub 打开绘图
Public Sub getCadDwg(Dwgpath As String)
On Error GoTo ErrorHandler
Dim strMsg As String
Dim booYouHaveItOpen As Boolean
Set CADApp = GetCad
Dim booFileOpen As Boolean
booFileOpen = isFileOpen(Dwgpath)
Dim booFileExists As Boolean
Dim objfso As New Scripting.FileSystemObject
booFileExists = objfso.fileExists(Dwgpath)
'See if the file exists and then exit if it doesn't
If booFileExists = False Then
MsgBox "A file at the below path does not exist." & vbCr & vbCr & vbCr & Dwgpath, vbOKOnly, "File Missing"
End If
If booFileOpen = True Then
'Search to see if it is the current user that has it opened
If CADApp.Documents.Count > 0 Then
For Each myDwg In CADApp.Documents
'Test to see if one of the current drawing has the same path, then bring it to the front.
If Dwgpath = myDwg.FullName Or GetUNC(Dwgpath) = myDwg.FullName Then
booYouHaveItOpen = True
If myDwg.active = False Then
myDwg.Activate
Call bringCADToFront
Exit For
End If
End If
Next myDwg
End If
If booYouHaveItOpen = False Then
MsgBox "Drawing file is already opened by another user." _
, vbInformation + vbOKOnly _
, "Drawing Opened Already!"
End If
GoTo ExitHere
Else
'Open the AutoCAD drawing
Set myDwg = CADApp.Documents.Open(Dwgpath)
CADApp.ZoomExtents
CADApp.Visible = True
End If
'-------------------------------------------------------
ExitHere:
On Error Resume Next
Call bringCADToFront
Set CADApp = Nothing
Set myDwg = Nothing
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getCadDwg of Module mCadLateBind", vbOKOnly
GoTo ExitHere
End Sub
GetCAD 函数
Public Function GetCad() As Object
On Error Resume Next
'Check to see if AutoCAD is open
'Set GetCad = GetObject(, "AutoCAD.Application.19")
Set GetCad = GetObject(, "AutoCAD.Application")
'If AutoCAD is NOT open and error number will be produced
If Err.Number <> 0 Then
Err.Clear
'Open an instance of AutoCAD
'Set GetCad = CreateObject("AutoCAD.Application.19")
Set GetCad = CreateObject("AutoCAD.Application")
End If
'Make AutoCAD visible
GetCad.Visible = True
End Function
获取UNC路径函数
Public Function GetUNC(strMappedDrive As String) As String
Dim objfso As FileSystemObject
Dim objDrive As Drive
Dim strDrive As String
Dim strShare As String
On Error GoTo ErrorHandler
Set objfso = New FileSystemObject
'Get the Drive Name
strDrive = objfso.GetDriveName(strMappedDrive)
Set objDrive = objfso.GetDrive(strDrive)
'find the UNC share name from the mapped letter
strShare = objDrive.ShareName
'Replace the MappedDrive With the UNC share name
GetUNC = Replace(strMappedDrive, strDrive, strShare)
'-------------------------------------------------------
ExitHere:
On Error Resume Next
Set objfso = Nothing 'Destroy the object
Set objDrive = Nothing 'Destroy the object
Exit Function
ErrorHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetUNC of Module mFunctions", vbOKOnly
GoTo ExitHere
End Function
将 CAD 放在最前面
Public Sub bringCADToFront()
On Error GoTo ErrorHandler
Dim CADApp As Variant
Dim lngHwnd As Long
Dim lngMDIHwnd As Long
On Error GoTo ErrorHandler
Set CADApp = GetCad
lngHwnd = FindWindow(vbNullString, CADApp.Caption)
SetFocusAPI lngHwnd
'-------------------------------------------------------
ExitHere:
On Error Resume Next
Set CADApp = Nothing
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure bringCADToFront of Sub mAutoCADsubs", vbOKOnly
GoTo ExitHere
End Sub
保存 AutoCAD 绘图
myDwg.Close True 'True to save the drawing, False for no save