simatyga 发表于 2009-3-10 15:08:00

[求助]使用CopyObjects不能复制尺寸标注

<p>用下面的代码把当前图纸中所有的图形复制到一张新建dwg中，其他图形都是好的，就是标注没有复制过去</p><p>Sub main()<br/>&nbsp;&nbsp;&nbsp; Dim doc1 As AcadDocument, doc2 As Object<br/>&nbsp;&nbsp;&nbsp; Dim ssetObj As AcadSelectionSet<br/>&nbsp;&nbsp;&nbsp; Dim objCollection() As Object<br/>&nbsp;&nbsp;&nbsp; Set doc1 = Application.ActiveDocument<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; Set ssetObj = doc1.ActiveSelectionSet<br/>&nbsp;&nbsp;&nbsp; ssetObj.Select acSelectionSetAll</p><p>&nbsp;&nbsp;&nbsp; If ssetObj.Count &gt; 0 Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ReDim objCollection(ssetObj.Count - 1) As Object<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; For k = 0 To ssetObj.Count - 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Set objCollection(k) = ssetObj(k)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Next k<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Set doc2 = Documents.Add<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; doc1.CopyObjects objCollection, doc2.ModelSpace<br/>&nbsp;&nbsp;&nbsp;&nbsp; End If</p><p><br/>End Sub<br/></p>

zzyong00 发表于 2009-3-10 16:11:00

<p>标注也复制过去了，只不过没显示出来</p><p>&nbsp;&nbsp;&nbsp; Dim doc1 As AcadDocument, doc2 As AcadDocument<br/>&nbsp;&nbsp;&nbsp; Dim ssetObj As AcadSelectionSet<br/>&nbsp;&nbsp;&nbsp; Dim objCollection() As Object<br/>&nbsp;&nbsp;&nbsp; Dim k As Integer<br/>&nbsp;&nbsp;&nbsp; Set doc1 = Application.ActiveDocument<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; Set ssetObj = doc1.ActiveSelectionSet<br/>&nbsp;&nbsp;&nbsp; ssetObj.Select acSelectionSetAll</p><p>&nbsp;&nbsp;&nbsp; If ssetObj.Count &gt; 0 Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ReDim objCollection(ssetObj.Count - 1) As Object<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; For k = 0 To ssetObj.Count - 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Set objCollection(k) = ssetObj.Item(k)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Next k<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Set doc2 = Documents.Add<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; doc1.CopyObjects objCollection, doc2.ModelSpace<br/>&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; For k = 0 To ssetObj.Count - 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; doc2.ModelSpace.Item(k).Visible = True<br/>&nbsp;&nbsp;&nbsp; Next k</p>

jepvyg 发表于 2024-12-16 15:24:39

都是好人啊。
页: [1]
查看完整版本: [求助]使用CopyObjects不能复制尺寸标注