[VBA]利用ObjectDbx技术在当前图形中插入其它未打开的图形中的图块
本帖最后由 作者 于 2007-1-12 17:27:19 编辑以前，我们为了做图库，每一个图块均必须保存为一个图形文件，以便在编程时直接插入选定的图形，这样做出来的程序，图形文件的数量就会很多，因为有时你的图库内容很多。
现在利用ObjectDbx技术可以将这些图块放在一个图形中，做到真正的图库，以下为程序内容：
引用：ObjectDbx 1.0类型库(文件为：c:\program files\autocad 2002\AXDB15.TLB)
插入模块1，输入以下代码：
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)
然后在窗体的代码窗中输入以下代码：
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代码窗中输入以下代码：
Sub InsBlk()
Load UserForm1
UserForm1.Show
End Sub
这样就可以试试你的程序了。
如果觉得麻烦，这个我已经打包成一个文件，大家拿去试试吧：
下载的文件已经改为最新无错版本，可用于2000-2004版本 新人上路，求大神解答一下。这个帖子里的功能就是我想要的，我想学习下，但是不知道为什么我运行这个程序，点击“浏览文件”按钮的时候就会报错，hwndOwner = ThisDrawing.HWND的类型不匹配，这是什么原因？我用的是AutoCAD2016版本和内置的VB 请教大家 可以演示一下怎么操作使用吗？ 哇，看到了知识点，留个位子
非常好,這種東西很面熟,我好像有用VLISP寫過,但一直沒有用過
有个bug，如何解决
运行时出现对话框，提示内容为：run-time error '-2147221005(800401f3)'
problem in loading application
可能是你還沒有註冊objectdbx,先註冊吧!程序如內
(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."
)
)
)
)
)
谢谢！
本人是新手，是在明经长大的，以后会多学习的。非常有意义，不知道AutoCAD对ObjectDbx 1.0类型库的支持是不是稳定的？
例如，对Office 97类型库的引用在只安装Office 2000/XP的系统中能够自动识别并转换，而不至于出现找不到类型库的警告。也同样存在版本问题
这个程序是在2002中写的，应该在2000到2002都可以运行。而2004版中直接运行则会出错并退出AutoCAD，所以在2004中必须调用ObjectDbx16，也就是与2004版本相同的DBX类型库，但只是这样做还是会出错，要再把
Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument")
改为
Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16")
才能正常运行。
这样的话就要引用两个类型库，并在程序中判断当前ACAD版本以引用不同的类型库了。
类型库的引用最大的问题就是版本问题。
根据版本判断来引用不同的类型库相当于修改VBA源程序，退出AutoCAD时会提问是否保存DVB，早年曾与老弟探讨过这个问题，不知道现在可有什么妙法解决。两个类型库一起引用，但在Set objDbx=这一句前加判断版本
我没试过，不知是否可行看看这种方法是否可以彻底解决问题
可以使用CreateObject函数来创建对类型库的引用，这样就可以避开在工具中人工进行引用所带来的版本问题。也就是这样：
以下为2004版：
Dim objDbx
Set objDbx = CreateObject("ObjectDBX.AxDbDocument.16")
以下为2000-2002版：
Dim objDbx
Set objDbx = CreateObject("ObjectDBX.AxDbDocument.1")
注意以上使用的方法不需要在工具中引用类型库了，而是直接在程序中完成，这样就可以在程序中判断目前AutoCAD的版本来决定程序的引用了。
以下为改动过的UserForm_Initialize过程：
Private Sub UserForm_Initialize()
If Left(Version, 2) = "15" Then
Set objDbx = CreateObject("ObjectDBX.AxDbDocument.1")
ElseIf Left(Version, 2) = "16" Then
Set objDbx = CreateObject("ObjectDBX.AxDbDocument.16")
End If
Me.CommandButton1.Caption = "浏览"
Me.CommandButton2.Caption = "插入"
Me.CommandButton3.Caption = "取消"
Me.Label1.Caption = "选择图形："
Me.Label2.Caption = "选择图块："
Me.Caption = "插入外部图形中的图块示例"
End Sub