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

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

用下面的代码把当前图纸中所有的图形复制到一张新建dwg中，其他图形都是好的，就是标注没有复制过去
Sub main()
Dim doc1 As AcadDocument, doc2 As Object
Dim ssetObj As AcadSelectionSet
Dim objCollection() As Object
Set doc1 = Application.ActiveDocument

Set ssetObj = doc1.ActiveSelectionSet
ssetObj.Select acSelectionSetAll
If ssetObj.Count > 0 Then
      ReDim objCollection(ssetObj.Count - 1) As Object
      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

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

标注也复制过去了，只不过没显示出来
Dim doc1 As AcadDocument, doc2 As AcadDocument
Dim ssetObj As AcadSelectionSet
Dim objCollection() As Object
Dim k As Integer
Set doc1 = Application.ActiveDocument

Set ssetObj = doc1.ActiveSelectionSet
ssetObj.Select acSelectionSetAll
If ssetObj.Count > 0 Then
      ReDim objCollection(ssetObj.Count - 1) As Object
      For k = 0 To ssetObj.Count - 1
         Set objCollection(k) = ssetObj.Item(k)

      Next k

      Set doc2 = Documents.Add
      doc1.CopyObjects objCollection, doc2.ModelSpace
   End If
For k = 0 To ssetObj.Count - 1
      doc2.ModelSpace.Item(k).Visible = True
Next k

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

发表回复

精选推荐