Autocad VBA Copying between drawings

[Anonymous]

Hello forum,

I've got a problem concerning copying elements between two drawings which I cannot solve myself at the moment.

I want to copy elements from the drawing "QuellDxf" based on Layer "ORIGINALKONTUR" to the "ZielDxf" and then add some elements to drawing "ZielDxf". Well all works fine until I add something by the call "Set Linie1 =..." in the sub routine to the drawing after copying.

If I comment out this lines I see the expected result: the elements from second opened drawing have been added to the other drawing. But if I add anything to the drawing after copying the elements are not visible anymore. They seem to be on a layer which is not displayed in the layer properties. You can get them back, if you select all elements and change the layer so they are only some kind of invinsible.

Maybe someone has an idea. Thanks in advance.

Lars

Here comes the Code.

'Declaration of variables

Public InsrtPnt(0 To 2) As Double
Public QuellDxf As AcadDocument
Public Quelllayer As String
Public ZielDxf As AcadDocument
Public SSetA As AcadSelectionSet

'Test Sub
Sub TESTMain()
    Dim Linie1 As AcadLine, Linie2 As AcadLine
    Dim MinXPkt(0 To 2) As Double, MaxXPkt(0 To 2) As Double
    'Definiere den Einfügepunkt (0,0,0)
    InsrtPnt(0) = 0: InsrtPnt(1) = 0: InsrtPnt(2) = 0
    MinXPkt(0) = 10.5: MinXPkt(1) = 10: MinXPkt(2) = 0
    MaxXPkt(0) = -10: MaxXPkt(1) = 10: MaxXPkt(2) = 0
    
    Quelllayer = "ORIGINALKONTUR"
    
    Set ZielDxf = Application.Documents.Open("E:\Dropbox\Zeichnung0.dxf") '("C:\Users\Lars.Elbracht\Desktop\Testprofile\Zeichnung0.dxf") '
    Set QuellDxf = Application.Documents.Open("E:\Dropbox\Zeichnung1.dxf") '("C:\Users\Lars.Elbracht\Desktop\Testprofile\Zeichnung1.dxf")
    
    CopyObjects False
    
    Set Linie1 = ZielDxf.ModelSpace.AddLine(InsrtPnt, MinXPkt)
    'Set Linie2 = QuellDxf.ModelSpace.AddLine(InsrtPnt, MinXPkt)
    
End Sub

Function CopyObjects(All As Boolean)
    Dim SSetA As AcadSelectionSet
    Dim tDxfCodes(0) As Integer ', mI%
    Dim tDxfValues(0) As Variant
    Dim mTmp As AcadBlockReference

    Set SSetA = CreateSelectionSet("KopiereObjekte")
    
    'wenn All=True sollen alle Objekte in der aktiven Zeichnung kopiert werden, sonst nur gemäß Filter-Einstellungen
    If All = False Then
        'Filter-Einstellungen
        tDxfCodes(0) = 8     

        tDxfValues(0) = Quelllayer
        Call SSetA.Select(acSelectionSetAll, , , tDxfCodes, tDxfValues) 'Filtertyp 8-->Layer Name, Layer-Name
    Else
        Call SSetA.Select(acSelectionSetAll)
    End If
    
    If SSetA.Count > 0 Then
        QuellDxf.Wblock "C:\Users\Public\Documents\" & "Block.dwg", SSetA
        Set mTmp = ZielDxf.ModelSpace.InsertBlock(InsrtPnt, "C:\Users\Public\Documents\" & "Block.dwg", 1, 1, 1, 0)
        mTmp.Explode
        mTmp.Delete
        ZielDxf.PurgeAll
        Kill "C:\Users\Public\Documents\" & "Block.dwg"
        SSetA.Clear
    End If

End Function

[Anonymous · Accepted solution]

if you re-open Zeichnung0 after closing-saving it you'll find it's all there

to see it immediately just put 

ZielDxf.Regen acAllViewports

anywhwhere in your code before 

Set Linie1 = ZielDxf.ModelSpace.AddLine(InsrtPnt, MinXPkt)

as a side note I'd suggest you:

1) not to use pubic variables 

   you'd rather use locally scoped variables and pass them over your subs/function

   this way you'll have better control over your code

2) not to relay on the "arguably" active document

    you'd better always pass and use wanted document object to work on

you may then want to consider the following possible refactoring of your code

Sub TESTMain()
    Dim QuellDxf As AcadDocument, ZielDxf As AcadDocument
    
    ' you can swap file opening order with no side effects
    Set QuellDxf = Application.Documents.Open("E:\Dropbox\Zeichnung1.dxf") '("C:\Users\Lars.Elbracht\Desktop\Testprofile\Zeichnung1.dxf")
    Set ZielDxf = Application.Documents.Open("E:\Dropbox\Zeichnung0.dxf") '("C:\Users\Lars.Elbracht\Desktop\Testprofile\Zeichnung0.dxf") '
 
    Dim Quelllayer As String
    Quelllayer = "ORIGINALKONTUR"
    
    'Definiere den Einfügepunkt (0,0,0)
    Dim InsrtPnt(0 To 2) As Double
    InsrtPnt(0) = 0: InsrtPnt(1) = 0: InsrtPnt(2) = 0
    
    CopyObjects QuellDxf, ZielDxf, InsrtPnt '<--| pass relevant parameters to your sub
    
    ZielDxf.Regen acAllViewports '<--| regen all viewports and make your exploded object "appear"
    
    Dim MinXPkt(0 To 2) As Double, MaxXPkt(0 To 2) As Double
    MinXPkt(0) = 10.5: MinXPkt(1) = 10: MinXPkt(2) = 0
    MaxXPkt(0) = -10: MaxXPkt(1) = 10: MaxXPkt(2) = 0
    
    Dim Linie1 As AcadLine, Linie2 As AcadLine
    Set Linie1 = ZielDxf.ModelSpace.AddLine(InsrtPnt, MinXPkt)
    'Set Linie2 = QuellDxf.ModelSpace.AddLine(InsrtPnt, MinXPkt)
    
    Set ZielDxf = Nothing
    Set QuellDxf = Nothing
End Sub
 
Sub CopyObjects(sourceDoc As AcadDocument, targetDoc As AcadDocument, InsrtPnt() As Double, Optional Quelllayer As String = "*") '<--| make layer name an optional parameter with a default value of "*" , i.e. "all layers"
    Dim SSetA As AcadSelectionSet

    Set SSetA = CreateSelectionSet(sourceDoc, "KopiereObjekte") '<--| pass relevant document to create selectionset of
    
    'wenn Quelllayer = "" sollen alle Objekte in der aktiven Zeichnung kopiert werden, sonst nur gemäß Filter-Einstellungen
    Dim tDxfCodes(0) As Integer ', mI%
    Dim tDxfValues(0) As Variant
    'Filter-Einstellungen
    tDxfCodes(0) = 8
    tDxfValues(0) = Quelllayer
    SSetA.Select acSelectionSetAll, , , tDxfCodes, tDxfValues 'Filtertyp 8-->Layer Name, Layer-Name
    
    If SSetA.Count > 0 Then
        Dim blockPath As String
        blockPath = "C:\Users\Public\Documents\" & "Block.dwg"
        sourceDoc.Wblock blockPath, SSetA
        With targetDoc.ModelSpace.InsertBlock(InsrtPnt, blockPath, 1, 1, 1, 0)
            .Explode
            .Delete
        End With
        targetDoc.PurgeAll
        Kill blockPath
        SSetA.Clear
    End If
End Sub

Function CreateSelectionSet(acDoc As AcadDocument, ssetName As String) As AcadSelectionSet
    On Error Resume Next
    Set CreateSelectionSet = acDoc.SelectionSets.Add(ssetName)
    On Error GoTo 0
    If CreateSelectionSet Is Nothing Then Set CreateSelectionSet = acDoc.SelectionSets.Item(ssetName)
    CreateSelectionSet.Clear
End Function

[Anonymous]

Thanks a lot for your help. I've already tried your changes and it worked perfectly.

[Anonymous · Accepted solution]

You are welcome
You may then want to mark my answer as the solution
Cheers