◆请问怎么将图元复制到新的文档

bluelover

我用select方法在drawing1.dwg上选择了一些图元，然后用add方法创建了一个新的文档drawing2.dwg，请问怎样才能将前面选中的那些图元复制到drawing.dwg中同样的位置？


还有，一个选择集好像只能保存256个对象，如果给定的范围内被选的对象数目多余256个，该怎么做？


望赐教，谢谢。

efan2000

使用CopyObjects，先定义一个对象数组，将选择集中的所有对象赋给它，然后调用这个函数拷贝到另一个文档。

bluelover

我用的就是这个方法，可是没有成功，不知道问题出在哪里。 下面是出错地方的代码： Set DOC1 = Documents.Add
retObjects = DOC1.CopyObjects(objCollection) 其中DOC1是新建的dwg文档，objCollection是一个保存了一些图元的数组 在新建了一个文档后，下面这句： retObjects = DOC1.CopyObjects(objCollection) 提示出错： 运行错误 '-2145386377 （80200077）' ： 对象不在数据库中 不知道这是什么问题，监视窗口中可以看到objCollection是存在对象的。 望大侠不吝赐教。谢谢

雪山飞狐_lzh

DOC1.CopyObjects(objCollection) 方法中 DOC1换成objCollection对象数组所在的Document

bluelover

我将代码改成了如下：



set doc1=application.activedocument ' 源图元所在的文档


set doc2=docements.add


retObjects=doc1.CopyObjects(objCollection)


没有原来的错误了，可是图元并没有拷贝到新的文件中，why？

雪山飞狐_lzh

你的对象数组的代码看看？

bluelover

我是在Add 之前将文档赋给DOC1的，应该没问题吧，


现在我改成了下面的语句，错误倒没有了，新的文档中什么也没有


set doc1=application.activedocument ' 源图元所在的文档

雪山飞狐_lzh

贴你的完整一点的代码？

bluelover

set DOC1=Application.ActiveDocument If ssetObj.Count > 0 Then
ReDim objCollection(ssetObj.Count - 1)
For k = 0 To ssetObj.Count - 1
Set objCollection(k) = ssetObj(k)
Next k

Set DOC2 = Documents.Add
retObjects = DOC1.CopyObjects(objCollection)
End If 其中ssetObj是一个选择集，objCollection是一个动态数组

雪山飞狐_lzh

Sub t7()
Dim Doc1 As AcadDocument, Doc2 As Object
Dim ssetObj As AcadSelectionSet
Dim objCollection() As AcadEntity
Set Doc1 = Application.ActiveDocument 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.Add
Doc1.CopyObjects objCollection, Doc2.ModelSpace
End If
End Sub