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

simatyga

用下面的代码把当前图纸中所有的图形复制到一张新建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

标注也复制过去了，只不过没显示出来

    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

jepvyg

都是好人啊。