社区 › VB › [求助]使用CopyObjects不能复制尺寸标注

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

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

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