[VBA]利用ObjectDbx技术在当前图形中插入其它未打开的图形中的图块

mccad

以前，我们为了做图库，每一个图块均必须保存为一个图形文件，以便在编程时直接插入选定的图形，这样做出来的程序，图形文件的数量就会很多，因为有时你的图库内容很多。
现在利用ObjectDbx技术可以将这些图块放在一个图形中，做到真正的图库，以下为程序内容：

引用：ObjectDbx 1.0类型库(文件为：c:\program files\AutoCAD 2002\AXDB15.TLB)
插入模块1，输入以下代码：

3. Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
4.     (LPOPENFILENAME As OPENFILENAME) As Long
5. Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
6.     (pOpenfilename As OPENFILENAME) As Long
7. Public Const OFN_PATHMUSTEXIST = &H800
8. Public Const OFN_FILEMUSTEXIST = &H1000
9. Public Const OFN_HIDEREADONLY = &H4 '隐蔽只读复选框
11. Public Type OPENFILENAME
12.     lStructSize As Long
13.     hwndOwner As Long '拥有对话框的窗口
14.     hInstance As Long
15.     lpstrFilter As String '装载文件过滤器的缓冲区
16.     lpstrCustomFilter As String
17.     nMaxCustFilter As Long
18.     nFilterIndex As Long
19.     lpstrFile As String
20.     nMaxFile As Long
21.     lpstrFileTitle As String
22.     nMaxFileTitle As Long
23.     lpstrInitialDir As String
24.     lpstrTitle As String '对话框的标题
25.     flags As Long
26.     nFileOffset As Integer
27.     nFileExtension As Integer
28.     lpstrDefExt As String
29.     lCustData As Long
30.     lpfnHook As Long
31.     lpTemplateName As String
32. End Type
34. Function GetFile(strTitle As String, strFilter As String, Optional strIniDir As String) As String
36. On Error Resume Next
37. Dim FileName As String
38. Dim OFileBox As OPENFILENAME
39. With OFileBox
40.     .lpstrTitle = strTitle '对话框标题
41.     .lpstrInitialDir = strIniDir '初始目录
42.     .lStructSize = Len(OFileBox)
43.     .hwndOwner = ThisDrawing.HWND
44.     .flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
45.     .lpstrFile = String$(255, 0)
46.     .nMaxFile = 255
47.     .lpstrFileTitle = String$(255, 0)
48.     .nMaxFileTitle = 255
49.     .lpstrFilter = strFilter  '过滤器
50.     .nFilterIndex = 1
51. End With
53. lntFile = GetOpenFileName(OFileBox) '执行打开对话框
54. If lntFile <> 0 Then
55.     FileName = Left(OFileBox.lpstrFile, InStr(OFileBox.lpstrFile, vbNullChar) - 1)
56.     GetFile = FileName
57. Else
58.     GetFile = ""
59. End If
61. End Function

Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _     (LPOPENFILENAME As OPENFILENAME) As Long Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _     (pOpenfilename As OPENFILENAME) As Long Public Const OFN_PATHMUSTEXIST = &H800 Public Const OFN_FILEMUSTEXIST = &H1000 Public Const OFN_HIDEREADONLY = &H4 '隐蔽只读复选框 Public Type OPENFILENAME     lStructSize As Long     hwndOwner As Long '拥有对话框的窗口     hInstance As Long     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 Long     lpTemplateName As String End Type Function GetFile(strTitle As String, strFilter As String, Optional strIniDir As String) As String On Error Resume Next Dim FileName As String Dim OFileBox As OPENFILENAME With OFileBox     .lpstrTitle = strTitle '对话框标题     .lpstrInitialDir = strIniDir '初始目录     .lStructSize = Len(OFileBox)     .hwndOwner = ThisDrawing.HWND     .flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY     .lpstrFile = String$(255, 0)     .nMaxFile = 255     .lpstrFileTitle = String$(255, 0)     .nMaxFileTitle = 255     .lpstrFilter = strFilter  '过滤器     .nFilterIndex = 1 End With lntFile = GetOpenFileName(OFileBox) '执行打开对话框 If lntFile <> 0 Then     FileName = Left(OFileBox.lpstrFile, InStr(OFileBox.lpstrFile, vbNullChar) - 1)     GetFile = FileName Else     GetFile = "" End If End Function

插入窗体userform1,自上而下插入以下控件：
  标签(Label1)
     文本框(TextBox1)
              命令按钮(CommandButton1)
  标签(Label2)
     组合框(ComboBox1)
命令按钮(CommandButton2)  命令按钮(CommandButton3)

然后在窗体的代码窗中输入以下代码：

3. Option Explicit
4.     Dim objDbx As AxDbDocument
5.     Dim elem As Object
6.     Dim blkName As String
7.     Dim dwgName As String
8.     Dim blkObj(0) As Object
9.     Dim pnt As Variant
11. Private Sub CommandButton1_Click()
12.     Me.TextBox1 = GetFile("打开图形", "图形文件(*.dwg)" & vbNullChar & "*.dwg")
13. End Sub
15. Private Sub CommandButton2_Click()
16.     blkName = Me.ComboBox1.SelText
17.     dwgName = Me.TextBox1.Value
18.     Me.Hide
19.    
20.     pnt = ThisDrawing.Utility.GetPoint(, "选择插入点：")
21.     Set blkObj(0) = objDbx.Blocks(blkName)
22.     objDbx.CopyObjects blkObj, ThisDrawing.ModelSpace
23.     ThisDrawing.ModelSpace.InsertBlock pnt, blkName, 1, 1, 1, 0
24.     Unload UserForm1
25.     Set elem = Nothing
26.     Set objDbx = Nothing
27.    
28. End Sub
30. Private Sub CommandButton3_Click()
31.     Unload UserForm1
32.     Set elem = Nothing
33.     Set objDbx = Nothing
35. End Sub
37. Private Sub TextBox1_Change()
38.     If Dir(Me.TextBox1.Value) <> "" Then
39.         objDbx.Open Me.TextBox1.Value
40.         For Each elem In objDbx.Blocks
41.             If Left(elem.Name, 1) <> "*" Then
42.                 Me.ComboBox1.AddItem elem.Name
43.             End If
44.         Next
45.     End If
46.         
47. End Sub
49. Private Sub UserForm_Initialize()
50.     Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument")
51.     Me.CommandButton1.Caption = "浏览"
52.     Me.CommandButton2.Caption = "插入"
53.     Me.CommandButton3.Caption = "取消"
54.     Me.Label1.Caption = "选择图形："
55.     Me.Label2.Caption = "选择图块："
56.     Me.Caption = "插入外部图形中的图块示例"
57. End Sub

Option Explicit     Dim objDbx As AxDbDocument     Dim elem As Object     Dim blkName As String     Dim dwgName As String     Dim blkObj(0) As Object     Dim pnt As Variant Private Sub CommandButton1_Click()     Me.TextBox1 = GetFile("打开图形", "图形文件(*.dwg)" & vbNullChar & "*.dwg") End Sub Private Sub CommandButton2_Click()     blkName = Me.ComboBox1.SelText     dwgName = Me.TextBox1.Value     Me.Hide         pnt = ThisDrawing.Utility.GetPoint(, "选择插入点：")     Set blkObj(0) = objDbx.Blocks(blkName)     objDbx.CopyObjects blkObj, ThisDrawing.ModelSpace     ThisDrawing.ModelSpace.InsertBlock pnt, blkName, 1, 1, 1, 0     Unload UserForm1     Set elem = Nothing     Set objDbx = Nothing     End Sub Private Sub CommandButton3_Click()     Unload UserForm1     Set elem = Nothing     Set objDbx = Nothing End Sub Private Sub TextBox1_Change()     If Dir(Me.TextBox1.Value) <> "" Then         objDbx.Open Me.TextBox1.Value         For Each elem In objDbx.Blocks             If Left(elem.Name, 1) <> "*" Then                 Me.ComboBox1.AddItem elem.Name             End If         Next     End If          End Sub Private Sub UserForm_Initialize()     Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument")     Me.CommandButton1.Caption = "浏览"     Me.CommandButton2.Caption = "插入"     Me.CommandButton3.Caption = "取消"     Me.Label1.Caption = "选择图形："     Me.Label2.Caption = "选择图块："     Me.Caption = "插入外部图形中的图块示例" End Sub

然后在ThisDrawing代码窗中输入以下代码：

3. Sub InsBlk()
4.     Load UserForm1
5.     UserForm1.Show
6. End Sub

Sub InsBlk()     Load UserForm1     UserForm1.Show End Sub

这样就可以试试你的程序了。
如果觉得麻烦，这个我已经打包成一个文件，大家拿去试试吧：


下载的文件已经改为最新无错版本，可用于2000-2004版本

Syjhy

新人上路，求大神解答一下。这个帖子里的功能就是我想要的，我想学习下，但是不知道为什么我运行这个程序，点击“浏览文件”按钮的时候就会报错，hwndOwner = ThisDrawing.HWND的类型不匹配，这是什么原因？我用的是AutoCAD2016版本和内置的VB

MXS

哇，看到了知识点，留个位子

快乐贝贝

学习一下 谢谢分享

龙龙仔

china-hz

运行时出现对话框，提示内容为：
run-time error '-2147221005(800401f3)'
problem in loading application

龙龙仔

(defun REGISTEROBJECTDBX (/ DBXSERVER)        ;by Tony Tanzillo - Thanks Tony!
  (cond
    ((vl-registry-read
       "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
     )
    )
    ((not (setq DBXSERVER (findfile "AxDb15.dll")))
     (alert "Error: Can't locate ObjectDBX Library (AxDb15.dll)")
    )
    (t
     (startapp "regsvr32.exe" (strcat "/s \"" DBXSERVER "\""))
     (or
       (vl-registry-read
         "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
       )
       (alert
         "Error: Failed to register ObjectDBX ActiveX services."
       )
     )
    )
  )
)

china-hz

本人是新手，是在明经长大的，以后会多学习的。

河伯

例如，对Office 97类型库的引用在只安装Office 2000/XP的系统中能够自动识别并转换，而不至于出现找不到类型库的警告。

mccad

这个程序是在2002中写的，应该在2000到2002都可以运行。
而2004版中直接运行则会出错并退出AutoCAD，所以在2004中必须调用ObjectDbx16，也就是与2004版本相同的DBX类型库，但只是这样做还是会出错，要再把
Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument")
改为
Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16")
才能正常运行。
这样的话就要引用两个类型库，并在程序中判断当前ACAD版本以引用不同的类型库了。

河伯

根据版本判断来引用不同的类型库相当于修改VBA源程序，退出AutoCAD时会提问是否保存DVB，早年曾与老弟探讨过这个问题，不知道现在可有什么妙法解决。

mccad

我没试过，不知是否可行

mccad

可以使用CreateObject函数来创建对类型库的引用，这样就可以避开在工具中人工进行引用所带来的版本问题。
也就是这样：
以下为2004版：
    Dim objDbx
    Set objDbx = CreateObject("ObjectDBX.AxDbDocument.16")
以下为2000-2002版：
    Dim objDbx
    Set objDbx = CreateObject("ObjectDBX.AxDbDocument.1")
注意以上使用的方法不需要在工具中引用类型库了，而是直接在程序中完成，这样就可以在程序中判断目前AutoCAD的版本来决定程序的引用了。

以下为改动过的UserForm_Initialize过程：

2. 
   
3. Private Sub UserForm_Initialize()
   
4.     If Left(Version, 2) = "15" Then
   
5.         Set objDbx = CreateObject("ObjectDBX.AxDbDocument.1")
   
6.     ElseIf Left(Version, 2) = "16" Then
   
7.         Set objDbx = CreateObject("ObjectDBX.AxDbDocument.16")
   
8.     End If
   
9.    
   
10.     Me.CommandButton1.Caption = "浏览"
    
11.     Me.CommandButton2.Caption = "插入"
    
12.     Me.CommandButton3.Caption = "取消"
    
13.     Me.Label1.Caption = "选择图形："
    
14.     Me.Label2.Caption = "选择图块："
    
15.     Me.Caption = "插入外部图形中的图块示例"
    
16. End Sub
    

<br /> Private Sub UserForm_Initialize()<br />     If Left(Version, 2) = "15" Then<br />         Set objDbx = CreateObject("ObjectDBX.AxDbDocument.1")<br />     ElseIf Left(Version, 2) = "16" Then<br />         Set objDbx = CreateObject("ObjectDBX.AxDbDocument.16")<br />     End If<br />     <br />     Me.CommandButton1.Caption = "浏览"<br />     Me.CommandButton2.Caption = "插入"<br />     Me.CommandButton3.Caption = "取消"<br />     Me.Label1.Caption = "选择图形："<br />     Me.Label2.Caption = "选择图块："<br />     Me.Caption = "插入外部图形中的图块示例"<br /> End Sub<br />