再问一个问题:)

xiaopei520

我的程序主要过程是:打开若干个DXF文件,将其中的线一一按原坐标复制到新的dwg文件中,但是这其中总是不稳定,有时会在原点处加几个识别不了的文字,显示问几个问号.下面是复制时用的命令: ThisDrawing.Application.Documents(lst2.List(I)).SendCommand Chr(3) + Chr(3) + "._copyclip all " + Chr(32) + Chr(32) ' str + Chr(59)
ThisDrawing.Application.Documents(MStrPrjName + "坡面.DWG").SendCommand Chr(3) + Chr(3) + "._pasteorig " '粘贴到原坐标系
ThisDrawing.Application.Documents(lst2.List(I)).Close , False '关闭原文件
ThisDrawing.SendCommand Chr(3) + Chr(3) + "Z E "

雪山飞狐_lzh

用CopyObjects方法

bluelover

图元很多的情况下，copyObjects 方法效率其实比较低的，可以试试WBlock方法与 Explode方法相结合。

xiaopei520

还好,俺的程序就是将一些线粘贴到一张新图中去,用copyObjects简单容易 实现 Dim Doc1 As AcadDocument, Doc2 As Object
Dim ssetObj As AcadSelectionSet
Dim objCollection() As AcadEntity
Set Doc1 = Application.Documents(lst2.List(I))'有多个DXF文件 DeleAllSelect
Set ssetObj = ThisDrawing.SelectionSets.Add("ybssa")
Set ssetObj = Doc1.ActiveSelectionSet
ssetObj.Select acSelectionSetAll If ssetObj.count > 0 Then
ReDim objCollection(ssetObj.count - 1) As AcadEntity
For K = 0 To ssetObj.count - 1
Set objCollection(K) = ssetObj(K)
Next K Set Doc2 = Documents("D:\mydwg.DWG")
Doc1.CopyObjects objCollection, Doc2.ModelSpace
End If
ThisDrawing.Application.Documents(lst2.List(I)).Close , False
ThisDrawing.Application.ZoomExtents