从其他绘图复制对象
你好。我编写了一个代码，可以在活动文件目录中打开多个dwg文件并复制对象。但和往常一样，我有一个问题：Sub MergeDrawings()
Dim CurrentFile As String
Dim Path As String
Dim ssMerge As AcadSelectionSet
Dim maindrawing As AcadDocument
Dim tempdrawing As AcadDocument
Dim destEnts As Variant
Dim sourceEnts() As AcadObject
Set maindrawing = Application.ActiveDocument()
Path = Application.ActiveDocument.Path()
CurrentFile = Dir(Path + "\*.dwg", vbNormal)
Do While CurrentFile <> ""
If Path & "\" & CurrentFile = maindrawing.FullName() Then
GoTo 98176
End If
Application.Documents.Open CurrentFile, False
Set tempdrawing = Application.ActiveDocument()
Set ssMerge = tempdrawing.SelectionSets.Add("SSMERGE03")
ssMerge.Select acSelectionSetAll
ReDim sourceEnts(ssMerge.Count - 1)
For i = 0 To ssMerge.Count - 1
Set sourceEnts(i) = ssMerge(i)
Next
destEnts = tempdrawing.CopyObjects(sourceEnts, maindrawing.ModelSpace)
ThisDrawing.Close False
98176 CurrentFile = Dir
MsgBox ("done")
Loop
End Sub
实际上它是有效的，但是；
destEnts = tempdrawing.CopyObjects(sourceEnts,maindrawing.ModelSpace)
不允许我设置插入点。它只是将对象粘贴到其原始位置。我需要设置插入点的左下角，以便在其旁边添加其他图形。
对不起我的英语。提前谢谢。 一些猜测
1） 将每个对象设置为在将其添加到sourceEnts（）之前复制插入点
2） 将每个复制的对象插入点添加到目标文件后，使用以下方法设置它们：
destEnts = tempdrawing.CopyObjects(sourceEnts, maindrawing.ModelSpace)
dim myObj as AcadObject
For i = 0 To ssMerge.Count - 1
Set myObj = sourceEnts(i)
' add code to change myObj insertion point
Next
一些最后的笔记（和猜测）
a） 我从AutoCAD ActiveX和VBA参考中看到，您声明为“Variant”的内容应声明为“Object”。可能这不会影响CopyObjects的结果，因为你说你在新文件中得到了它们。但以防万一。。。
b） 您将“所有者”设置为主图形。模型空间。这听起来像是默认选项。也许你可以试着把它设置为Tempdrawing。模型空间 感谢您的努力和建议RICVBA。昨晚，我与代码作了斗争，不知何故我做到了。在从tempdrawing复制项目之前，我将它们移动到所需的位置。但有一个小问题，AutoCAD在Windows中打开每个图形，所以如果有太多的图形，这个过程会花费太多时间。我想知道是否有一种方法可以“在后台做事”。但这并不重要，代码对我来说已经足够好了。
Sub MergeDrawings()
Dim CurrentFile As String
Dim Path As String
Dim ssMerge As AcadSelectionSet
Dim maindrawing As AcadDocument
Dim tempdrawing As AcadDocument
Dim destEnts As Variant
Dim sourceEnts() As AcadObject
Dim tempEnt As AcadEntity
Dim Extmin As Variant
Dim Extmax As Variant
Dim tempP1(2) As Double
Dim tempP2(2) As Double
'Define origin
tempP1(0) = 0
tempP1(1) = 0
tempP1(2) = 0
Set maindrawing = Application.ActiveDocument()
'Set Drawing path
Path = Application.ActiveDocument.Path()
CurrentFile = Dir(Path + "\*.dwg", vbNormal)
'Open Drawings
Do While CurrentFile <> ""
'Skip main drawing
If Path & "\" & CurrentFile = maindrawing.FullName() Then
GoTo 98176
End If
'Open temporary drawing for merge
Application.Documents.Open CurrentFile, False
Set tempdrawing = Application.ActiveDocument()
'Regen for extent values
maindrawing.Activate
ThisDrawing.Regen (acAllViewports)
Extmin = maindrawing.GetVariable("EXTMIN")
Extmax = maindrawing.GetVariable("EXTMAX")
'Set move distance
d = Extmax(0) - Extmin(0)
'Set destination move point
tempP2(0) = d
tempP2(1) = 0
tempP2(2) = 0
tempdrawing.Activate
Set ssMerge = tempdrawing.SelectionSets.Add("SSMERGE03")
ssMerge.Select acSelectionSetAll
'Move entities
For Each tempEnt In ssMerge
tempEnt.Move tempP1, tempP2
Next
'Set array for copy
ReDim sourceEnts(ssMerge.Count - 1)
For i = 0 To ssMerge.Count - 1
Set sourceEnts(i) = ssMerge(i)
Next
destEnts = tempdrawing.CopyObjects(sourceEnts, maindrawing.ModelSpace)
ThisDrawing.Close False
98176 CurrentFile = Dir
Loop
ssMerge.Delete
End Sub
所以你已经做了类似于我的“猜测”数字1）
关于时间问题，我可以指出以下几点
一） 在宏的开头将AutoCAD Visible属性设置为“False”
所以你可以摆脱那些耗时的可视化工作
然后记得在宏结束之前将该属性设置回“True”
二） 使用ObjectDBX
正如肖特最近在这个论坛上所记得的那样(http://www.cadtutor.net/forum/showthread.php?30302-所选线路长度的VBA代码&p=608193#post608193）
它应该允许您“使用”图形，而不必在Autocad中打开它们，因为您使用的是它们的数据库（每个Autocad图形实际上都是这样的） 是的，很接近你的建议，效果很好。实际上是Autocad。可见属性差别不大。稍后我将尝试使用ObjectDBX。
再次感谢我的朋友。你和论坛里的其他人都很友善，很有帮助。我真的很感激。
如果您能发布ObjectDBX的成果，我很乐意与大家分享。
页:
[1]