VBA merge layers....copy content of a layer to other layer

[faith_cad]

Hello! Can someone help me solve this annoing problem?

A have to make a script ...that renames the name of some layers.. ex (layer name "102" and layer name "104" must merge into "test1") .. at first...i was just renameing ..each layer... but i receive the error that says that the layer is already existing "duplicate error" ... and now i must copy the content of layer "102" to layer "104" and then rename "104" to "test1" but i'm kind of new into VBA scripting in AutoCAD!

PS. I have to process a large number of files..and it can't be done manualy beacuse the lack of time.. i must make it by vba script beacuse vb is the only language a know!

[David Bethel]

I'd use something like this ( AutoLisp )

(defun c:mergel (/ vlist laylist ss tdef fe fd el)

  (setq vlist '(("ELEVATION" . 0) ("THICKNESS"  . 0)
                ("CELTSCALE" . 1) ("CECOLOR"   . "BYLAYER")
                ("CELTYPE"   . "BYLAYER")))
  (foreach v vlist
      (and (getvar (car v))
           (setvar (car v) (cdr v))))


  (setq laylist '(("OLD-LAYER" . "NEW-LAYER")
                  ("3D-SZG"    . "SNEEZE")))

  (command "_.LAYER")
  (foreach l laylist
       (if (not (tblsearch "LAYER" (cdr l)))
           (command "_New" (cdr l))))
  (command "")

  (foreach l laylist
       (and (setq ss (ssget "X" (list (cons 8 (car l)))))
            (command "_.CHPROP" ss "" "_LA" (cdr l) "")))

  (while (setq tdef (tblnext "BLOCK" (not tdef)))
         (setq fe (cdr (assoc -2 tdef)))
         (entmake tdef)
         (while fe
              (setq fd (entget fe)
                    el (cdr (assoc 8 fd)))
              (if (assoc el laylist)
                  (setq fd (subst (cons 8 (cdr (assoc el laylist)))
                                  (assoc 8 fd) fd)))
              (entmake fd)
              (setq fe (entnext fe)))
         (entmake (list (cons 0 "ENDBLK")(cons 8 "0"))))

  (prin1))

You could format the layer list externally and then read it globally into each dwg or just completely compile the list inside the routine as it is now.

I'd be careful cause it will destroy the handle data. -David

[faith_cad]

Thank u David! but as I mentioned I don't know lisp! But thank u for trying to help! I've resolved the problem with finding some pieces of code in VBA like selecting all content of a layer...and then the process was kind simple!

For everyone that have the same problem like i did...ask me for the code and i'l give it to u!


And sorry for my bad english!

[AQucsaiJr]

I am having a similar problem... You think you could post the code so I could try it?

[faith_cad]

this is the code ... i hope it will help u

Private Sub button1_Click()

Dim acadDoc As AutoCAD.AcadDocument
Set acadDoc = AutoCAD.Documents.Open("C:\test.dwg")
 

Dim lays As AcadLayers
Dim layerObj As AcadLayer
Dim lay As AcadLayer
Dim strLayerName As String
    
On Error Resume Next
    'Set lays = ThisDrawing.Layers
Set lays = acadDoc.Layers 


'set the layer to default
ThisDrawing.ActiveLayer = lays.Item(0)

'go trough all the layers
For Each lay In lays
            Set layerObj = acadDoc.Layers(lay.Name)
'listbox1 is the list with the layer names that are initialy
'listbox2 is the list with the layer names that are becoming 
'ex: listbox1 contains (103, 150, 160)
' and listbox2 contains (a, b, c) 103 is becoming a .. 150 is becoming b and 160 is becoming c
'if u have ..listbox1(103, 150, 160) and listbox2 (a, a, c)
'then a error..ocurs..and is captured.. then..takes all the elements on
'then layer 150 and copy them to the layer a ..and then deletes the 150 
'and so on...
'the listbox u can fill them from a txt file ... 

                For i = 0 To ListBox1.ListCount - 1
                
                    If layerObj.Name = ListBox1.List(i) Then
                        layerObj.Name = ListBox2.List(i)
                        
                            If Err.Number = "-2145386405" Then
'Testselectionsetfilter is the sub that copies the information from one layer to the other
                                Testselectionsetfilter ListBox1.List(i), ListBox2.List(i)
                                acadDoc.Layers.Item(ListBox1.List(i)).Delete
                            End If
                    End If
                Next i
        Next lay

Private Sub Testselectionsetfilter(layer_init As String, layer_dest As String)
    Dim objss As AcadSelectionSet
    Dim intcodes(0) As Integer
    Dim varcodevalues(0) As Variant
    Dim strname As String
    
On Error GoTo done
    
        strname = layer_init
        If "" = strname Then Exit Sub
        
        ''create new selectionset
        Set objss = ThisDrawing.SelectionSets.Add("Testselectionsetfilter")
        ''set the code for layer
        intcodes(0) = 8
        
        ''set the value specified by user
        varcodevalues(0) = strname
        
        ''filter the objects
        objss.Select acSelectionSetAll, , , intcodes, varcodevalues
        
        ''highlight the selected entities
        objss.Highlight True
              
         For i = 0 To objss.Count
       
         objss.Item(i).layer = layer_dest
      
         Next i
                      
done:
        '' if the selection was created , delete it
        If Not objss Is Nothing Then
        objss.Delete
        End If

End Sub

End sub

[faith_cad]

i've posted the code