topic Re: copy layers to new drawing in VBA Forum

copy layers to new drawing

Anonymous — Wed, 09 Aug 2006 17:53:21 GMT

Ok so heres another thing i could use some input on 🙂
In the drawings im building this macro for all the layers are label "1-rest of the layer name", "2-", "3-", "4-" and so on. What i need to do is write a procedure which takes everything on the "1-" and "2-" layers and copies them to a new drawing, then procedes with 3- and 4-, 5,6 and so on. heres what i have so far

Private Sub subCopyToNewDoc()
Dim objLayer As AcadLayer
Dim strLayer() As String
Dim i As Integer
Dim keepgoing As Boolean
Dim str1 As String
Dim str2 As String

Dim origDWG As AcadDocument
Dim newDWG As AcadDocument
Set origDWG = ThisDrawing

str1 = "1-"
str2 = "2-"
keepgoing = True

While keepgoing
ReDim strLayer(100)
i = 0
For Each objLayer In ThisDrawing.Layers
If Left(objLayer.Name, 2) = str1 Or str2 Then
strLayer(i) = objLayer.Name
i = i + 1
objLayer.LayerOn = True
Else
objLayer.LayerOn = False
End If
Next
ReDim strLayer(i - 1)

ThisDrawing.SendCommand ("copybase 0,0 c -10000,-10000 10000,1000" & vbCr & vbCr)
Set newDWG = Application.Documents.Add
newDWG.SendCommand ("pasteclip 0,0" & vbCr)
Application.ActiveDocument = origDWG --------------error here----

str1 = str(CInt(Left(str1, 1)) + 2) & "-"
str2 = str(CInt(Left(str2, 1)) + 2) & "-"

keepgoing = False
For Each objLayer In ThisDrawing.Layers
If Left(objLayer.Name, 2) = str1 Or str2 Then keepgoing = True
Next
Wend
End Sub

As it stands now the error says "Failed to get the Document Object" on the marked line where i try to reset the active drawing to the drawing i originally started with.

Re: copy layers to new drawing

Anonymous — Wed, 09 Aug 2006 19:43:46 GMT

Here is another way with using of ObjecDBX
I incuded to copy Xref's layers also

Option Explicit
'' Requires reference to:
'' Visual Basic For Applications
'' AutoCAD 2005 Type Library
'' Ole Automation
'' AutoCAD/ObjectDBX Common 16. Type Library
'' AutoCAD/ObjectDBX Common 1.0 Type Library: -> not sure about
'' Visual Lisp ActiveX module: -> not sure about
Public Sub DBXCopyLayers(ByVal fname As String)
Dim oDbx As Object
Dim olayer As AcadLayer
Dim i As Integer
With ThisDrawing.Application
Set oDbx = .GetInterfaceObject("ObjectDBX.AxDbDocument.16") '' or 17 for A2007
End With

oDbx.Open FileName:=fname

Dim copyVar() As Object

For Each olayer In oDbx.Layers
If Not olayer.Name Like "0,Defpoints" Then
ReDim Preserve copyVar(i)
Set copyVar(i) = olayer
i = i + 1
End If
Next
Dim idPairs As Variant
Dim copyObj As Variant
copyObj = oDbx.CopyObjects(copyVar, ThisDrawing.Layers, idPairs)
Set oDbx = Nothing

End Sub

Sub TestCopyLayers()
Dim fname As String

On Error GoTo WeHaveAProblem
'' change full path name for the donor
fname = "D:\MyFavouriteDwg.dwg"

Call DBXCopyLayers(fname)

WeHaveAProblem:
If Err Then
MsgBox "ObjectDBX CopyObjects method objects failed." & vbCr & Err.Number & " " & _
Err.Description, vbCritical
End If

End Sub

Fatty

~'J'~

Re: copy layers to new drawing

Anonymous — Thu, 10 Aug 2006 15:50:00 GMT

Im hesitant to use any other object libraries than the included autocad ones as I am building a program to be used on many different machines with cad already installed, it would probably cause more problems to install new libraries than it would to just write the code without using them

Ive pretty much worked out the part where i copy the entities to the other drawing, my problem is that since i am doing this multiple times i need to reset my active drawing to the drawing i had when i first ran my program. currently it looks like this:

Set origDWG = Application.ActiveDocument 'i set the original drawing here
Application.ActiveDocument = origDWG 'then i recall the drawing later in the program

The problem is obviously that since origDWG is set to Application.ActiveDocument when i go to reset the drawing it sets it to the current open drawing, not the original. any ideas as to how this might be fixed? Message was edited by: sryabinin

Re: copy layers to new drawing

Anonymous — Thu, 10 Aug 2006 16:21:23 GMT

Use the Documents collection to set origDWG.

--
R. Robert Bell

Re: copy layers to new drawing

Anonymous — Thu, 10 Aug 2006 16:56:46 GMT

Assuming that only one drawing is open at the start would this work?

Set origDWG = Documents.Item(0)

Edit: Nevermind, i got it..thank you Message was edited by: sryabinin

Re: copy layers to new drawing

Anonymous — Fri, 11 Aug 2006 10:16:07 GMT

А не мог бы, ты мил человек, мне по-нашему растолмачить,
а то мы по-аглицки не шибко....
А и для практики мне бы польза 🙂
fixo@yandex.ru

Fatty

~'J'~