ACAD: How to Copy All Object in a Layer to Another File?

[miumiu]

Dear All ,

I have a project to extract all the Works Area (which is some lines, polylines, blocks, text, etc. in a layer) from all the drawings in a directory and copy to a single file. And then I need to label the works area with the Filename of the Drawings from which I exact the works area. Is it possible to do so? Can you please help?

Thank you very much!!!

MiuMiu

[Tommy]

Hi miumiu,

Welcome to VBAX!

You will need to open each file select the objects in a selection set with the layer filter set to the correct layer, copy and paste into a new drawing and save. This is what I think I would do, not sure about blocks - there could possibly be some redefine block problems, overwriting, lines doubling up. This all sounds doable but more information is required.

[miumiu]

Hi Tommy,

Thank you very much for your quick response!

You are correct! This is what I want to do. The blocks problems can be ignore since they all share the same block definition.

As I am a newbie in Autocad programing, can you please kindly show me some example for doing the task you described.

Thank you very much for your help!!!

Cheers,
Miu Miu

[Tommy]

Place this code in a module. It make a new blank drawing, open all draawing in a directory, copy all items on a layer, wblock them and insert the block into the other drawing.

[VBA]
Public mTempDoc As AcadDocument
Public mWrkDoc As AcadDocument
Public Cntr As Integer
Sub GetLayerObject()
Dim ssetA As AcadSelectionSet
Dim groupCode As Variant, dataCode As Variant
Dim gpCode(0) As Integer, mI%
Dim dataValue(0) As Variant
Dim mTmp As AcadBlockReference
Dim InsrtPnt(2) As Double
Set ssetA = mWrkDoc.SelectionSets.Add("Layers")
gpCode(0) = 8
dataValue(0) = "CABLE" '<-- this is the layer name I used
groupCode = gpCode
dataCode = dataValue
ssetA.Select acSelectionSetAll, , , groupCode, dataCode
If ssetA.Count > 0 Then
Cntr = Cntr + 1
mWrkDoc.Wblock "C:\ACAD\Temp" & CStr(Cntr) & ".dwg", ssetA
Set mTmp = mTempDoc.ModelSpace.InsertBlock(InsrtPnt, "C:\ACAD\Temp" & CStr(Cntr) & ".dwg", 1, 1, 1, 0)
mTmp.Explode
mTempDoc.PurgeAll
Kill "C:\ACAD\Temp" & CStr(Cntr) & ".dwg"
ssetA.Clear
End If
Set ssetA = Nothing
Set mTmp = Nothing
End Sub

Sub OpenNewDoc()
Set mTempDoc = Application.Documents.Add '<-this is the drawing that ALL information will be inserted into
End Sub

Sub LookInDir(WhichDir As String)
Dim Filed As String
OpenNewDoc
Filed = Dir(WhichDir & "*.dwg") '<-change the drawing names if required
While Filed <> vbNullString
Set mWrkDoc = ThisDrawing.Application.Documents.Open(WhichDir & Filed)
GetLayerObject
mWrkDoc.Close False
Filed = Dir
Wend
Set mWrkDoc = Nothing
End Sub

Sub Main()
LookInDir "C:\ACAD\" 'change the directory to what you require
Set mTempDoc = Nothing
Application.ZoomExtents
End Sub
[/VBA]

HTH

[miumiu]

Hi Tommy,

Thank you so much for your help! It Works!!!



I amended the code a little bit to fit my need, and the code now look like this:

[VBA]
Public mTempDoc As AcadDocument
Public mWrkDoc As AcadDocument
Public Cntr As Integer
Sub GetLayerObject()
Dim ssetA As AcadSelectionSet
Dim groupCode As Variant, dataCode As Variant
Dim gpCode(8) As Integer, mI%
Dim dataValue(8) As Variant
Dim mTmp As AcadBlockReference
Dim InsrtPnt(2) As Double
ThisDrawing.ActiveSpace = acModelSpace
Set ssetA = mWrkDoc.SelectionSets.Add("Layers")
gpCode(0) = -4
dataValue(0) = "<or"
gpCode(1) = 8
dataValue(1) = "WORKAREA"
gpCode(2) = 8
dataValue(2) = "WORKSAREA"
gpCode(3) = 8
dataValue(3) = "CONE"
gpCode(4) = -4
dataValue(4) = "or>"
gpCode(5) = 67
dataValue(5) = 0 '
gpCode(6) = -4
dataValue(6) = "<not"
gpCode(7) = 0
dataValue(7) = "hatch"
gpCode(8) = -4
dataValue(8) = "not>"


groupCode = gpCode
dataCode = dataValue
ssetA.Select acSelectionSetAll, , , groupCode, dataCode
If ssetA.Count > 0 Then
Cntr = Cntr + 1
mWrkDoc.Wblock "C:\Temp" & CStr(Cntr) & ".dwg", ssetA
Set mTmp = mTempDoc.ModelSpace.InsertBlock(InsrtPnt, "C:\Temp" & CStr(Cntr) & ".dwg", 1, 1, 1, 0)
mTmp.Explode
mTempDoc.PurgeAll
Kill "C:\Temp" & CStr(Cntr) & ".dwg"
ssetA.Clear
End If
ThisDrawing.SelectionSets("Layers").Delete
Set ssetA = Nothing
Set mTmp = Nothing
End Sub

Sub OpenNewDoc()
Set mTempDoc = Application.Documents.Add '<-this is the drawing that ALL information will be inserted into
End Sub

Sub LookInDir(WhichDir As String)
Dim Filed As String
OpenNewDoc
Filed = Dir(WhichDir & "*.dwg") '<-change the drawing names if required
While Filed <> vbNullString
Set mWrkDoc = ThisDrawing.Application.Documents.Open(WhichDir & Filed)
GetLayerObject
mWrkDoc.Close False
Filed = Dir
Wend
Set mWrkDoc = Nothing
End Sub

Sub Main()
LookInDir "C:\TEMP\" 'change the directory to what you require
Set mTempDoc = Nothing
Application.ZoomExtents
End Sub

[/VBA]


Now the next problem is:

How can I label the worksarea? For each drawing I copied, I need to label the pasted block by the filename.

For example, if I found 10 drawings in a directory and then copied to a new drawing called "abc", then I have 10 blocks on the "abc". For each of the block, I need to label the block with the filename that I copied from.

How can I do it?

Thanks for your help again!!!


Cheers,

MiuMiu

[Tommy]

When you wblock the file you can either wblock it as the filename in a different location or rename the block on the hard drive. Then insert the block as normal.

Without me haveing to check it out, does the advanced filter select all of the layers entered or just 1 excluding the hatch?

[miumiu]

Hi Tommy,
I have modified the code to have the wblock with correct filename.
When I click the property of each block, the Name of the block shows the original filename which it was copied from correctly. And it is what I want.
To become more perfect, I think the name of the block can be shown on the block as a text. I know it is easy to create a text but how can the programme determine which point should it inserts the text?
That's the problem I am facing now...

Thanks for your help again!

Cheers,
Alex

[Tommy]

Hi Alex,

Well the only thing I can think of at the moment is to close the original drawing, open the "block" do a zoom extents, find where you are at (this is assumung that the drawing objects all are not at 0,0,0), based on the extents determine where you want the text. The problems are going to be, is there text already there? will it overwrite existing text when inserted? hopefully there will not be any problems but I don't know what you are dealing with so this is nothing but a guess.

[zenwest]

whay not attach xdata to the block? or stick it on a layer with the information you need as the layer name, or create a layer name with a "!" in the name start., you could also create an invisible block with the information as the name.

[miumiu]

Dear zenwest,

Thank you for your reply.
Sorry that I am only a beginner to the VBA in autocad. I don't reallly understand what you mean. Does it means that it is possible to show the block name/or the information of the block together with the block itself.

Can you show me some example?

Thank you very much for your help

Cheers,
Miumiu

[zenwest]

this is from the acad2002 help file under methods-setxdata. As I have rarely used xdata, I have no examples, but in theory, you attach extra data to objects in any quantity, but the data can be unique to each object. Sorry for the slow response, I was out of here for a bit

[VBA]
Sub Example_SetXdata()
' This example creates a line and attaches extended data to that line.

' Create the line
Dim lineObj As AcadLine
Dim startPt(0 To 2) As Double, endPt(0 To 2) As Double
startPt(0) = 1#: startPt(1) = 1#: startPt(2) = 0#
endPt(0) = 5#: endPt(1) = 5#: endPt(2) = 0#
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
ZoomAll
' Initialize all the xdata values. Note that first data in the list should be
' application name and first datatype code should be 1001
Dim DataType(0 To 9) As Integer
Dim Data(0 To 9) As Variant
Dim reals3(0 To 2) As Double
Dim worldPos(0 To 2) As Double

DataType(0) = 1001: Data(0) = "Test_Application"
DataType(1) = 1000: Data(1) = "This is a test for xdata" '< good place for a path, or name!
DataType(2) = 1003: Data(2) = "0" ' layer
DataType(3) = 1040: Data(3) = 1.23479137438413E+40 ' real
DataType(4) = 1041: Data(4) = 1237324938 ' distance
DataType(5) = 1070: Data(5) = 32767 ' 16 bit Integer
DataType(6) = 1071: Data(6) = 32767 ' 32 bit Integer
DataType(7) = 1042: Data(7) = 10 ' scaleFactor
reals3(0) = -2.95: reals3(1) = 100: reals3(2) = -20
DataType(8) = 1010: Data(8) = reals3 ' real

worldPos(0) = 4: worldPos(1) = 400.99999999: worldPos(2) = 2.798989
DataType(9) = 1011: Data(9) = worldPos ' world space position

' Attach the xdata to the line
lineObj.SetXData DataType, Data

' Return the xdata for the line
Dim xdataOut As Variant
Dim xtypeOut As Variant
lineObj.GetXData "", xtypeOut, xdataOut

End Sub[/VBA]
you use getXdata method to retrieve the info

acad help file
[VBA]
Sub Example_GetXData()
' This example creates a line and attaches extended data to that line.

' Create the line
Dim lineObj As AcadLine
Dim startPt(0 To 2) As Double, endPt(0 To 2) As Double
startPt(0) = 1#: startPt(1) = 1#: startPt(2) = 0#
endPt(0) = 5#: endPt(1) = 5#: endPt(2) = 0#
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
ZoomAll
' Initialize all the xdata values. Note that first data in the list should be
' application name and first datatype code should be 1001
Dim DataType(0 To 9) As Integer
Dim Data(0 To 9) As Variant
Dim reals3(0 To 2) As Double
Dim worldPos(0 To 2) As Double

DataType(0) = 1001: Data(0) = "Test_Application"
DataType(1) = 1000: Data(1) = "This is a test for xdata"
DataType(2) = 1003: Data(2) = "0" ' layer
DataType(3) = 1040: Data(3) = 1.23479137438413E+40 ' real
DataType(4) = 1041: Data(4) = 1237324938 ' distance
DataType(5) = 1070: Data(5) = 32767 ' 16 bit Integer
DataType(6) = 1071: Data(6) = 32767 ' 32 bit Integer
DataType(7) = 1042: Data(7) = 10 ' scaleFactor
reals3(0) = -2.95: reals3(1) = 100: reals3(2) = -20
DataType(8) = 1010: Data(8) = reals3 ' real

worldPos(0) = 4: worldPos(1) = 400.99999999: worldPos(2) = 2.798989
DataType(9) = 1011: Data(9) = worldPos ' world space position

' Attach the xdata to the line
lineObj.SetXData DataType, Data

' Return the xdata for the line
Dim xdataOut As Variant
Dim xtypeOut As Variant
lineObj.GetXData "", xtypeOut, xdataOut

End Sub
[/VBA]

[miumiu]

Thanks a lot! Zenwest
I will try it out!!!