[编程交流] 从其他绘图复制对象

Sub MergeDrawings()
   Dim CurrentFile As String
   Dim Path As String
   Dim ssMerge As AcadSelectionSet
   Dim maindrawing As AcadDocument
   Dim tempdrawing As AcadDocument
   Dim destEnts As Variant
   Dim sourceEnts() As AcadObject
   
   Set maindrawing = Application.ActiveDocument()
   
   Path = Application.ActiveDocument.Path()
          
   CurrentFile = Dir(Path + "\*.dwg", vbNormal)
   
   Do While CurrentFile <> ""
       
       If Path & "" & CurrentFile = maindrawing.FullName() Then
           
           GoTo 98176
           
       End If
       
   
       Application.Documents.Open CurrentFile, False
       
       Set tempdrawing = Application.ActiveDocument()
       
       Set ssMerge = tempdrawing.SelectionSets.Add("SSMERGE03")
       ssMerge.Select acSelectionSetAll
                              
       ReDim sourceEnts(ssMerge.Count - 1)
       For i = 0 To ssMerge.Count - 1
           Set sourceEnts(i) = ssMerge(i)
       Next
       
             
       destEnts = tempdrawing.CopyObjects(sourceEnts, maindrawing.ModelSpace)
       
       ThisDrawing.Close False
       
98176   CurrentFile = Dir
       MsgBox ("done")
       
   Loop
End Sub

destEnts = tempdrawing.CopyObjects(sourceEnts,maindrawing.ModelSpace)

destEnts = tempdrawing.CopyObjects(sourceEnts, maindrawing.ModelSpace)
dim myObj as AcadObject 
For i = 0 To ssMerge.Count - 1 
       Set myObj = sourceEnts(i) 
      ' add code to change myObj insertion point 
Next

Sub MergeDrawings()
   Dim CurrentFile As String
   Dim Path As String
   Dim ssMerge As AcadSelectionSet
   Dim maindrawing As AcadDocument
   Dim tempdrawing As AcadDocument
   Dim destEnts As Variant
   Dim sourceEnts() As AcadObject
   Dim tempEnt As AcadEntity
   
   Dim Extmin As Variant
   Dim Extmax As Variant
   
   Dim tempP1(2) As Double
   Dim tempP2(2) As Double
   
   'Define origin
   tempP1(0) = 0
   tempP1(1) = 0
   tempP1(2) = 0
   
   Set maindrawing = Application.ActiveDocument()
   
   'Set Drawing path
   Path = Application.ActiveDocument.Path()
   CurrentFile = Dir(Path + "\*.dwg", vbNormal)
   
   'Open Drawings
   Do While CurrentFile <> ""
         
       'Skip main drawing
       If Path & "" & CurrentFile = maindrawing.FullName() Then
           
           GoTo 98176
           
       End If
       
       'Open temporary drawing for merge
       Application.Documents.Open CurrentFile, False
       Set tempdrawing = Application.ActiveDocument()
       
       'Regen for extent values
       maindrawing.Activate
       ThisDrawing.Regen (acAllViewports)
               
       Extmin = maindrawing.GetVariable("EXTMIN")
       Extmax = maindrawing.GetVariable("EXTMAX")
            
       'Set move distance
       d = Extmax(0) - Extmin(0)
       
       'Set destination move point
       tempP2(0) = d
       tempP2(1) = 0
       tempP2(2) = 0
                           
       tempdrawing.Activate
              
       Set ssMerge = tempdrawing.SelectionSets.Add("SSMERGE03")
       ssMerge.Select acSelectionSetAll
       
       'Move entities
       For Each tempEnt In ssMerge
           tempEnt.Move tempP1, tempP2
       Next
                              
       'Set array for copy
       ReDim sourceEnts(ssMerge.Count - 1)
       For i = 0 To ssMerge.Count - 1
           Set sourceEnts(i) = ssMerge(i)
       Next
             
       destEnts = tempdrawing.CopyObjects(sourceEnts, maindrawing.ModelSpace)
       
       ThisDrawing.Close False
       
98176   CurrentFile = Dir
       
   Loop
       
   ssMerge.Delete
End Sub