Multi Layer to single DWG

Anonymous · ‎06-17-2012

Hi to everybody, pls some body has some suggestion concerning the way to convert a multi-layer drawing in single sheet drawings ? I'll try to explain more: I have a drawing made with several layers (more than 80) the scope is to produce a single dwg file for each layer, the name of the single file should be composed by the main file name plus .the name of the layer that usually is 001, 002 etc. Somebody has some suggestion ?? My idea was to copy all objects on the single layers and paste on a new dwgfile previously settled as the main file (I mean form, size, and so on !). Many thanks

Hallex · ‎06-17-2012

Try to use ObjectDBX methods, here is a sample

Option Explicit
' require reference to AutoCAD/ObjectDBX XX.X Library
Sub ImpotrtLayersAsDwg()
Dim oEnt As AcadEntity
Dim dbxDoc As AxDbDocument
Dim path As String
Dim dwgname As String
path = ThisDrawing.GetVariable("dwgprefix")
dwgname = ThisDrawing.GetVariable("dwgname")
On Error GoTo Err_Control
Dim oLayer As AcadLayer
Dim layColl As Collection
Set layColl = New Collection

Dim n
   For Each oLayer In ThisDrawing.Layers
     layColl.Add oLayer.Name
   Next

Dim itm

For Each itm In layColl
Dim setName As String
     setName = CStr(itm)
    Dim gpCode(1) As Integer
     Dim dataValue(1) As Variant

     
     Dim oSset As AcadSelectionSet
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add(setName)
          End With
          
     gpCode(0) = 67: gpCode(1) = 8:
      dataValue(0) = 0: dataValue(1) = setName

     oSset.Select acSelectionSetAll, , , gpCode, dataValue
     MsgBox oSset.Count
     If oSset.Count > 0 Then
     Dim i As Long
     Dim objs() As Object
      For i = 0 To oSset.Count - 1
      ReDim Preserve objs(i)
      Set objs(i) = oSset.Item(i)
   Next
   
Set dbxDoc = New AxDbDocument
Dim idPairs As Variant
Dim copyObj As Variant

copyObj = ThisDrawing.CopyObjects(objs, dbxDoc.ModelSpace, idPairs)

dbxDoc.SaveAs path & Left(dwgname, Len(dwgname) - 4) & "_" & setName & ".dwg"
End If
Next

Set dbxDoc = Nothing
Set layColl = Nothing

Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If


End Sub

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

Anonymous · ‎06-19-2012

Thank you for your support,

The routine seems to work partially I got an Automation error at point

Set dbxDoc = New AxDbDocument

I insert the library as you suggested, but the routine hangs on such point.

I saw some recently post about some similar error on this forum

http://forums.autodesk.com/t5/Visual-Basic-Customization/AcadApplication-documents-open-execution-er...

Pls could you help me little bit more ?

Thank you

Hallex · ‎06-19-2012

I will try to solve it later, seemed to me you've used

another Acad release, mine is A2009,

see you tomorrow,

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

Anonymous · ‎06-19-2012

thank you very much, I'm using Autocad Electric 2013, but I can try with Autocad 2005 if this can help to solve the issue,

Pls feel free to work on that when you have time for this !.

Bye

Hallex · ‎06-19-2012

Try this code, I've changed ObjectDBX declaration within the code,

its working good on my end

Option Explicit
' require reference to AutoCAD/ObjectDBX XX.X Library
Sub ImpotrtLayersAsDwg()
Dim oEnt As AcadEntity
Dim dbxDoc As AxDbDocument
Dim path As String
Dim dwgname As String
path = ThisDrawing.GetVariable("dwgprefix")
dwgname = ThisDrawing.GetVariable("dwgname")
On Error GoTo Err_Control
Dim oLayer As AcadLayer
Dim layColl As Collection
Set layColl = New Collection

Dim n
   For Each oLayer In ThisDrawing.Layers
     layColl.Add oLayer.Name
   Next

Dim itm

For Each itm In layColl
Dim setName As String
     setName = CStr(itm)
    Dim gpCode(1) As Integer
     Dim dataValue(1) As Variant

     
     Dim oSset As AcadSelectionSet
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add(setName)
          End With
          
     gpCode(0) = 67: gpCode(1) = 8:
      dataValue(0) = 0: dataValue(1) = setName

     oSset.Select acSelectionSetAll, , , gpCode, dataValue
     MsgBox oSset.Count
     If oSset.Count > 0 Then
     Dim i As Long
     Dim objs() As Object
      For i = 0 To oSset.Count - 1
      ReDim Preserve objs(i)
      Set objs(i) = oSset.Item(i)
   Next
   
Dim dbxVer As String
Dim acadVer As String

dbxVer = "ObjectDBX.AxDbDocument"
acadVer = Mid(ThisDrawing.GetVariable("AcadVer"), 1, 2)
If Not Int(acadVer) < 16 Then
dbxVer = dbxVer & "." & acadVer
End If

Set dbxDoc = ThisDrawing.Application.GetInterfaceObject(dbxVer)
''Set dbxDoc = New AxDbDocument
Dim idPairs As Variant
Dim copyObj As Variant

copyObj = ThisDrawing.CopyObjects(objs, dbxDoc.ModelSpace, idPairs)

dbxDoc.SaveAs path & Left(dwgname, Len(dwgname) - 4) & "_" & setName & ".dwg"
End If
Next

Set dbxDoc = Nothing
Set layColl = Nothing

Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If


End Sub

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

Anonymous · ‎06-20-2012

Thank you very much for yoour support !! now it's working perfectly.

I should adjust something for the drawing frame perhaps I'll use as xref the main paper frame with drawing information.

Could you explain me better the use of dbx library ? In any case I'll search more on internet docs.

Thank you

Hallex · ‎06-20-2012

Glad I could help, but sorry I'm bad teacher for you

better yet to search for ObjectDbx methods in docs,

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

Anonymous · ‎06-22-2012

Pls may I ask you another little question ?.

Is there a way, during the layer scanning to save on the same drawing more layers ?.

I'll try to explain more :

I have the frame of the drawing on layer "0" and the others objects to transform in a single dwg on the layer 001, 002 and so on.

I would like to add to each dwg source from a single layer, also the fram on layer 0 !.

Could you suggest me something ?.

Thank you

Hallex · ‎06-22-2012

Let me a try, I'm not sure about how to rewtrite existing layer "0",

that will be added by default in every drawing first

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

Hallex · ‎06-22-2012

Try this code on your machine

Option Explicit
' require reference to AutoCAD/ObjectDBX XX.X Library
Sub ImpotrtLayersAsDwg()
Dim oEnt As AcadEntity
Dim zeroLayer As AcadLayer
Dim dbxDoc As AxDbDocument
Dim path As String
Dim dwgname As String
path = ThisDrawing.GetVariable("dwgprefix")
dwgname = ThisDrawing.GetVariable("dwgname")
On Error GoTo Err_Control
Dim oLayer As AcadLayer
Dim dbxLayer As AcadLayer
Dim layColl As Collection
Set layColl = New Collection

Dim n
   For Each oLayer In ThisDrawing.Layers
     layColl.Add oLayer.Name
   Next

Dim itm

For Each itm In layColl
Dim setName As String
     setName = CStr(itm)
    Dim gpCode(1) As Integer
     Dim dataValue(1) As Variant

     
     Dim oSset As AcadSelectionSet
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add(setName)
          End With
          
     gpCode(0) = 67: gpCode(1) = 8:
      dataValue(0) = 0: dataValue(1) = setName & ",0"

     oSset.Select acSelectionSetAll, , , gpCode, dataValue

     If oSset.Count > 0 Then
     Dim i As Long
     Dim objs() As Object
      For i = 0 To oSset.Count - 1
      ReDim Preserve objs(i)
      Set objs(i) = oSset.Item(i)
   Next
   
Dim dbxVer As String
Dim acadVer As String

dbxVer = "ObjectDBX.AxDbDocument"
acadVer = Mid(ThisDrawing.GetVariable("AcadVer"), 1, 2)
If Not Int(acadVer) < 16 Then
dbxVer = dbxVer & "." & acadVer
End If

Set dbxDoc = ThisDrawing.Application.GetInterfaceObject(dbxVer)

' copy layer
Dim lPairs As Variant
Dim layObj As Variant
Set zeroLayer = ThisDrawing.Layers.Item("0")
Dim lobj() As Object
ReDim Preserve lobj(0)
Set lobj(0) = zeroLayer
layObj = ThisDrawing.CopyObjects(lobj, dbxDoc.Layers, lPairs)
Set dbxLayer = dbxDoc.Layers.Item("0")
dbxLayer.Linetype = zeroLayer.Linetype
dbxLayer.Lineweight = zeroLayer.Lineweight
dbxLayer.TrueColor = zeroLayer.TrueColor
' copy objects
Dim idPairs As Variant
Dim copyObj As Variant
copyObj = ThisDrawing.CopyObjects(objs, dbxDoc.ModelSpace, idPairs)


dbxDoc.SaveAs path & Left(dwgname, Len(dwgname) - 4) & "_" & setName & ".dwg"
End If
Next

Set dbxDoc = Nothing
Set layColl = Nothing

Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If


End Sub

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

Community

Multi Layer to single DWG

Multi Layer to single DWG

Multi Layer to single DWG