Using ObjectDBX and copyObjects to copy 3 layers from one drawing to another

[aachiney]

Hi,

I am trying to copy 3 layers from one drawing file to another drawing file. I DON'T want to open the drawing files, as this process will be applicable to at least 50 drawing files. I am using VBA. So far, I have opened the UPDATED file and copied 3 layers. When trying to use "copyObjects" to copy these 3 layers into a non-updated file, code is executing without any error, but the drawing file it NOT getting updated. 

Below is my piece of code-

--Moderator edit. Changed code format to VB.

Dim newPath As String   'without layer and updated
Dim oldPath As String   'to update
    
Private Sub CommandButton1_Click()
    UserForm1.Hide
    CopyLayers newPath, oldPath
End Sub

Public Sub CopyLayers(newFile As String, oldFile As String)
    Dim oDoc As New AxDbDocument
    Dim nDoc As New AxDbDocument
    Dim oDbx As Object          'To update
    Dim nDbx As Object          'Updated
    Dim olayer As AcadLayer
    Dim i As Integer
    Set nDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument.18")
    nDbx.Open newFile

    'Copying the Layers from Updated File
    Dim copyLay() As Object
    For Each olayer In nDbx.Layers
        If UCase(olayer.Name) = "DATE1" Or UCase(olayer.Name) = "DATE2" Or UCase(olayer.Name) = "DATE3" Then
            ReDim Preserve copyLay(i)
            Set copyLay(i) = olayer
            i = i + 1
        End If
    Next
    MsgBox i
    Dim idPairs As Variant
    Dim copyObj As Variant

    'Opening the File to copy the Layer i.e Opening the File To UPDATE
    Set oDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument.18")
    oDbx.Open FileName:=oldFile
    'Copying the Layers to oDbx File
    nDbx.CopyObjects copyLay, ThisDrawing.Database.ModelSpace
    'oDbx.SaveAs savPath
    Set oDbx = Nothing
    Set nDbx = Nothing
End Sub

Private Sub UserForm_Activate()
    Dim dwgName As String
    dwgName = "mech_1"
    oldPath = "E:\ACE\Testing\09Dec\" & dwgName & ".dwg"
    newPath = "E:\ACE\Testing\30Jan\" & dwgName & ".dwg"
End Sub

What's wrong with this piece of code?

Regards

[Ed__Jobe]

Can you post samples for oDbx and nDbx?

[aachiney]

Hi,

I am attaching the 2 drawing files. They are not the original drawing files, but a replica.

Drawing1.dwg will be the Old one i.e file to be updated and Drawing2.dwg will be the updated one, where

from, I (here YOU) will try to copy the layers, DATE1, DATE2, and DATE3 to Drawing1.dwg file 

Regards

[norman.yuan]

Well, your code calls the CopyObjects() method backward: you should call it from ThisDrawing object and use the DBX document's ModelSpace as the new owner of the objects that are copied (while it is odd to use ModelSpace as new owner for whatever objects being copied, but it is how the CopyObjects() method is designed when copying objects crossing drawings).

So, the line of code should be:

ThisDrawing.CopyObjects copylay, nDbx.ModelSpace

Also, I assume you did save the DBX document after copying (this the commented-out line nDbx.SaveAs .... should be there, right?)

Following code works well on my side (I use Acad2022):

Option Explicit

Public Sub CopyLayers()

    Dim layers As Variant
    layers = CollectLayersToCopy()
    MsgBox "Layers to copy: " & UBound(layers) + 1

    Dim doc As AXDBLib.AxDbDocument
    Dim dbxFile As String
    dbxFile = "E:\CAD Work\Acad VBA\CopyLayer\DBX_Target.dwg"
    Set doc = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument.24")
    doc.Open dbxFile
    MsgBox doc.name
    
    ThisDrawing.CopyObjects layers, doc.ModelSpace
    doc.SaveAs dbxFile
    
End Sub

Private Function CollectLayersToCopy() As Variant

    Dim lay As AcadLayer
    Dim layers() As AcadObject
    Dim name As String
    Dim i As Integer
    
    For Each lay In ThisDrawing.layers
        name = UCase(lay.name)
        If Left(name, 5) = "LAYER" Then
            ReDim Preserve layers(i)
            Set layers(i) = lay
            i = i + 1
        End If
    Next

    CollectLayersToCopy = layers
    
End Function

[aachiney]

Hi Norman,

Thanks... I will also try this code at my (client) end too.

But, simply reading your code, I don't see the old file, the file TO BE UPDATED, being called or opened......

And above all, my client is using 2012 version

Obviously, I will save the newly formed document. I, always, said it's a piece of my code. To be honest,

I, here too, my client, is going to implement this on 50+ dwg files in one go (Shot).  I had NOT shared that code,,,,

Well, let me try what you said.

Regards

[norman.yuan]

Well, there isn't really too many lines of code to read: this snippet of code OPENs a file into DBX document, and SAVEs the DBX document back to the file AFTER copying:

    Dim doc As AXDBLib.AxDbDocument
    Dim dbxFile As String
    dbxFile = "E:\CAD Work\Acad VBA\CopyLayer\DBX_Target.dwg"
    Set doc = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument.24")
    doc.Open dbxFile
    MsgBox doc.name
    
    ThisDrawing.CopyObjects layers, doc.ModelSpace
    doc.SaveAs dbxFile

PLEASE looking at "doc.Open ..." and "doc.SaveAs ...". Isn't it obvious? Of course if you want to save the DBX document to different file name, you can by supply a different file name!

[aachiney]

Hi Norman,

Thanks for the code. Now, I am error "Null object ID" at line number 16.

Regards

[Ed__Jobe]

---

@aachiney wrote:

Hi Norman,

Thanks for the code. Now, I am error "Null object ID" at line number 16.

Regards

---

Which line 16 are you referring to? Post 4? When you get errors like that, hover over the object variables and see which one is Nothing.

[aachiney]

Hi, @Ed__Jobe and @norman.yuan 

I tried the @norman.yuan 's code, but still getting the "Null Object ID" error on the same line. There's no Nothing

on any object variable.....

Regards

[norman.yuan · Accepted solution]

When you say " There's no Nothing on any object variable.....", PLEASE INDICATE EXACTLY WHICH VARIABLE/WHICH LINE OF CODE.

And, MORE IMPORTANTLY: did you do necessary debug to step through the code BEFORE ASKING?

For example, if you are saying in this line

ThisDrawing.CopyObjects layers, doc.ModelSpace

the variable "layers" is empty (an array having no element), then you needs to go through the function CleectLayersToCopy() to find out why there is no wanted layer found. I do hope you did not blindly just used my sample code "as is". In my code sample, I assume I want to get layers with name line "LAYERxxxxxx". You OBVIOUSLY NEED TO USE your own criteria to choose layers by name to to copy.

So, your issue has nothing to do with copying objects via ObjectDBX. Please do your diligent debugging, and as soon as you do, you would fix errors most programmers usually make (me included) much sooner than asking around.

[aachiney]

Hi Norman,

Yes, I did NOT use your code blindly. 

I am opening a document, using ObjectDBX, copying 3 layers from this document... here I am counting them, also.

The object containing copied layers does have layers. 

Instead of this -

ThisDrawing.CopyObjects layers, doc.ModelSpace

I am opening one more document, using ObjectDBX, where these copied layers will get placed.

Now, I am not getting any errors, but the old document is not being updated with the copied layers.

Earlier, I had a separate function that would copy and pass the required layers, as your code. But then

the whole process was shifted to a single method. Doing this eliminated the error. 

Regards

[aachiney]

Hi Norman,

An update. Now copying the Layers successfully, but not the Objects on these 3 Layers!!!

Does "copyObjects()" only copies the Layers or also, both Layers and Objects on it...?

Regards

[norman.yuan · Accepted solution]

Ah, it seems you did not make your real goal clear from the beginning: you want to copy entities on certain layers (3, or not, it does not matter) from one drawing to another, not the layers only!

In this case, you do not need to find the target layers and copy them. You need to find the target entities (by their layers, obviously) and copy them. In this case, even the target drawing does not have those layers originally, these layer will be created because of the copying entities.

So the code would be something like (not tested):

Option Explicit

Public Sub CopyLayers()

    Dim ents As Variant
    ents = CollectEntitiesToCopy()
    MsgBox "Entities to copy: " & UBound(ents) + 1

    Dim doc As AXDBLib.AxDbDocument
    Dim dbxFile As String
    dbxFile = "E:\CAD Work\Acad VBA\CopyLayer\DBX_Target.dwg"
    Set doc = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument.24")
    doc.Open dbxFile
    MsgBox doc.name
    
    ThisDrawing.CopyObjects ents, doc.ModelSpace
    doc.SaveAs dbxFile
    
End Sub

Private Function CollectEntitiesToCopy() As Variant

    Dim ent As AcadEntity
    Dim ents() As AcadObject
    Dim i As Integer
    
    For Each ent In ThisDrawing.ModelSapce
        If UCase(ent.Layer) = "AAAAA" Or UCase(ent.Layer) = "XXXXX" Then
            ReDim Preserve ents(i)
            Set ents(i) = ent
            i = i + 1
        End If
    Next

    CollectEntitiesToCopy = ents
    
End Function

[aachiney]

@norman.yuan ,

Thanks a lot.

Did some modifications at my end, working very well, as expected.

Thanks a lot, again.

Regards 🙂