AutoCAD VBA - Change all objects to Lay 0

[RMS]

Hey Guys,

Would anyone have VBA code example that would allow me to change all the drawing objects from their current layers to layer 0 ?

I have code now that automatically scans a dir. of cad files and makes other changes but I just need to add this.

Thanks for any help with this!

[Tommy]

This will work for most things but I can't say if it will work correct with block entities.

Sub ChnageAllToLyer(iLayer As String) 
    Dim ssAll As AcadSelectionSet, mEntity As AcadEntity 
    Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities") 
    ssAll.Select acSelectionSetAll 
    For Each mEntity In ssAll 
        mEntity.Layer = iLayer 
    Next 
    ssAll.Clear 
    ssAll.Delete 
    Set ssAll = Nothing 
    ThisDrawing.Regen acActiveViewport 
End Sub 

VBA tags courtesy of www.thecodenet.com

[RMS]

Hi Tommy,

The code is running but does not seem to be doing anything. Does this add a layer or does it put "ALLEntities" on layer 0 ? Am I supposed to make any changes to it first?

Thanks,
Rob

[Tommy]

Hey Rob,
How are you calling the sub? Like ChnageAllToLyer "0" ?

Oh well this will end the confusion Sorry

Sub ChnageAllToLyer() 
Dim ssAll As AcadSelectionSet, mEntity As AcadEntity 
Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities") 
ssAll.Select acSelectionSetAll 
For Each mEntity In ssAll 
mEntity.Layer = "0" 
Next 
ssAll.Clear 
ssAll.Delete 
Set ssAll = Nothing 
ThisDrawing.Regen acActiveViewport 
End Sub 
 

VBA tags courtesy of www.thecodenet.com

[RMS]

Well I am pasting it directly into my program just as you posted it. I just tried this new one as it is, and again it does run (thats a good thing) but nothing changes. I am trying to think what I may need to do......

[Tommy]

Please post the dwg in a zip file so I can figure out what is wrong.
Thanks

[RMS]

Quote:   Originally Posted by: Tommy Please post the dwg in a zip file so I can figure out what is wrong. Thanks

Tommy I can't send the actual drawing BUT here is the VBA Code, scroll all the way down to the bottom to see it. I am using 2005, and this is being implemented automatically without an actual drawing being open, just AutoCAD.

Sub FixMyDXF() 
    Dim mPath As String, mFileName As String, mNewLyr As AcadLayer 
    Dim mDoc As AcadDocument, sset As AcadSelectionSet, mFxdNm As String 
    mPath = "D:\VBATEST\" ' dxf files here
    mFileName = "*.dxf" 
    mFileName = Dir(mPath & mFileName) 
    While mFileName <> "" 
        Set mDoc = Application.Documents.Open(mPath & mFileName) 
        DeleteLayouts mDoc 
         ' bellow code works
         
         
         ' I added New Text Style and then sets a new style
         ' for dimention text
         
        Dim newTextStyle As AcadTextStyle 
         
        Set newTextStyle = ThisDrawing.TextStyles.Add("ARIAL") 
        ThisDrawing.ActiveTextStyle = newTextStyle 
         
         ' End add text
         
         ' I added Set Font Type
         
        Dim textStyle1 As AcadTextStyle 
         'Dim currFontFile As String
        Dim newFontFile As String 
         
        Set textStyle1 = ThisDrawing.ActiveTextStyle 
         
         ' Change the value for FontFile
        newFontFile = "C:\Program Files\AutoCAD 2005\Fonts\arial.ttf" 
        textStyle1.fontFile = newFontFile 
         
         ' End Set Font
         
         'Set mNewLyr = mDoc.Layers.Add("LayerName")
         'set layer attributes
         'mNewLyr.color = acRed
         'mNewLyr.Linetype = "CONTINUOUS"
         ' added dim style change
         ' ad_AddDimStyle
         ' This routine demonstrates how to add a new dimension style and define
         ' its various properties.
         ' It was developed for AutoCAD 2000 and above.
         ' Demand load: -vbarun;ad_AddDimStyle.dvb!ad_AddDimStyle;
         ' version 1.00
         '
         ' Copyright?2000-2006 ActiveDwg.com
         '
         ' This routine is provided for demonstration purposes only and must
         ' not be used for critical applications without your verification
         ' that this routine will perform as you intended.
         ' This routine may be freely utilized for your own personal use so long
         ' as the entire contents of this header remain intact.
         ' This routine is provided "as-is" and no declaration, written or implied,
         ' is made as to its reliability for any particular task. Any use of this
         ' routine is solely at your own risk.
         '
        Dim adDimStyle As AcadDimStyle 
         ' Start Med
         'Set adDimStyle = ThisDrawing.DimStyles.Add("adDimStyle")
        Set adDimStyle = ThisDrawing.DimStyles.Add("Med 20-48 Inch") 
        ThisDrawing.ActiveDimStyle = adDimStyle 
        With ThisDrawing 
             'The first group defines overall and linear scale factors
            .SetVariable "DimScale", 1 'Overall Scale Factor. Determined by 12/Scale Factor.
             ' 96 is for 1/8"=1'-0" so that 12/.125=96.
            .SetVariable "DimLFac", 1 'Linear Scale Factor. '1'=1:1, '2'=2:1,'.5'=1:2, etc
             'This group defines the typical dimension properties
            .SetVariable "DimADec", 2 'Precision places for angular dimensions. May be 0-8.
            .SetVariable "DimAso", 1 'Dimensional associativity. 0=off, 1=on. 0 'explodes' dimensions.
             ' DimAso is stored by drawing, not by style.
            .SetVariable "DimASz", 1.25 'Arrowhead size for dimensions and leaders.
            .SetVariable "DimAtFit", 3 'Defines placement of arrowheads and text if insufficient space for both.
             ' 0=both outside, 1=force arrows outside, 2=force text outside, 3=best fit.
            .SetVariable "DimAUnit", 0 'Units for angular dimensions.
             ' 0=decimal degrees, 1=degrees/minutes/seconds, 2=gradians, 3=radians
            .SetVariable "DimAZin", 3 'Zero suppression for angular dimensions.
             ' 0=display all leading and trailing zeros, 1=suppress leading zeros,
             ' 2=suppress trailing zeros, 3=suppress leading and trailing zeros
            .SetVariable "DimBlk", "" 'Defines typical arrow type. ' "" '=Closed-Filled, '.'=none.
             ' Others are: '_ArchTick', '_BoxBlank', '_BoxFilled', '_Closed', '_ClosedBlank',
             ' '_DatumBlank', '_DatumFilled', '_Dot', '_DotSmall', '_DotBlank', '_Integral',
             ' '_None', '_Oblique', '_Origin', '_Origin2', '_Open', '_Open90', '_Open30', '_Small'.
            .SetVariable "DimBlk1", "" 'Defines 1st arrow type if 'DimSAH is '1'. See 'DimBlk' for type list.
            .SetVariable "DimBlk2", "" 'Defines 1st arrow type if 'DimSAH is '2'. See 'DimBlk' for type list.
            .SetVariable "DimCen", 0.5 'Defines circle and arc center marks and lines. Show as mark size.
             ' 0=No marks, <0=centerlines are drawn, >0=centermarks are drawn.
            .SetVariable "DimClrD", 160 'Color for dimlines, arrows, and leaders. 0=ByBlock, 256 = ByLayer, 1-255=color.
            .SetVariable "DimClrE", 1 'Color for dimension extension lines. 0=ByBlock, 256 = ByLayer, 1-255=color.
            .SetVariable "DimClrT", 7 'Color for dimension text. 0=ByBlock, 256 = ByLayer, 1-255=color.
            .SetVariable "DimDec", 2 'Decimal precision for normal dimensions.
            .SetVariable "DimDLE", 0 'For oblique marks in place of arrows: Distance dimlines extend beyond extension lines.
            .SetVariable "DimDLI", 0.1 'Offset distance between dimension line rows.
            .SetVariable "DimDSep", "." 'Decimal separator for decimal format dimensions.
            .SetVariable "DimExe", 1.25 'Extension distance of extension lines beyond dimension lines.
            .SetVariable "DimExO", 1.25 'Offset distance from dimension origin to extension line.
            .SetVariable "DimFrac", 0 'Fraction format in fractional dimensions. 0=Horizontal, 1=diagonal, 2=not stacked.
            .SetVariable "DimGap", 1.25 'Gap between dimlines and dimension text.
            .SetVariable "DimJust", 0 'Dimension text horizontal position. 0=Centered between extension lines,
             ' 1=at 1st extension line, 2=at 2nd extension line, 3=above and at 1st extension line,
             ' 4=above and at 2nd extension line.
            .SetVariable "DimLdrBlk", "" 'Defines leader arrow type. See DimBlk for type list.
            .SetVariable "DimLim", 0 'Defines whether dimension limits are generated. 1=On, 0=Off.
            .SetVariable "DimLUnit", 3 'Defines dimension unit types(except angular). 1=Scientific, 2=Decimal, 3=Engineering,
             ' 4=Architectural, 5=Fractional, 6=Windows default
            .SetVariable "DimLwd", acLnWtByLayer 'Defines dimension line lineweight. 'ByBlock'=acLnWtByBlock, 'ByLayer'=acLnWtByLayer,
             ' also may be specified as millimeters WAS -2.
            .SetVariable "DimLwe", acLnWtByLayer 'Defines extension line lineweight. 'ByBlock'=acLnWtByBlock, 'ByLayer'=acLnWtByLayer,
             ' also may be specified as millimeters WAS -2.
            .SetVariable "DimPost", "" 'Defines dimension text prefix or suffix. Use brackets to specify prefix or suffix.
             ' '<>ft' will create a suffix of 'ft', while 'ft<>' will create a prefix of 'ft'.
            .SetVariable "DimRnd", 0 'Defines precision for rounding dimensions. '.5' will round to nearest half.
            .SetVariable "DimSAh", 0 'Defines arrowhead block display. 0=set per 'DIMBLK'(see 'DimLdrBlk' for list'),
             ' 1=sets arrowhead 1('DIMBLK1') independently of arrowhead 2('DIMBLK2')(see 'DimLdrBlk' for list').
            .SetVariable "DimSD1", 0 'Defines display of 1st dimline and arrowhead. 0=Display, 1=Do not display.
            .SetVariable "DimSD2", 0 'Defines display of 2nd dimline and arrowhead. 0=Display, 1=Do not display.
            .SetVariable "DimSE1", 0 'Defines display of 1st extension line. 0=Display, 1=Do not display.
            .SetVariable "DimSE2", 0 'Defines display of 2nd extension line. 0=Display, 1=Do not display.
            .SetVariable "DimSho", 1 'Defines dynamic update of dimtext as defining points are dragged. 0=Update, 1=Do not update.
             ' DimSho is stored by drawing, not by style.
            .SetVariable "DimSOXD", 0 'Defines whether dimlines are drawn outside of extension lines.
             ' 0=Drawn outside, 1=Not drawn outside.
            .SetVariable "DimTAD", 0 'Dimension text vertical position. 0=Centered between extension lines,
             ' 1=above the dimension line, 2=dimensions placed on side of dimline away from defining points,
             ' 3=placed according to Japanese Industrial Standards.
            .SetVariable "DimTIH", 1 'Defines position of dimtext between extension lines. 0=Align with dimline, 1=Always horizontal.
            .SetVariable "DimTIX", 0 'Defines how text is placed between extension lines. 0=Between if fits, 1=Always between.
            .SetVariable "DimTOFL", 0 'Defines how dimline is placed between extension lines. 0=In or out with arrowheads, 1=Always between.
            .SetVariable "DimTOH", 1 'Defines position of dimtext outside extension lines. 0=Align with dimline, 1=Always horizontal.
            .SetVariable "DimTSz", 0 'Defines size of Oblique strokes in place of arrowheads. 0=Draws arrowheads, >0=Oblique size.
            .SetVariable "DimTVP", 0 
            .SetVariable "DimTxSty", "ARIAL" 
            .SetVariable "DimTxt", 1.25 
            .SetVariable "DimUPT", 1 
            .SetVariable "DimZIn", 12 
             'This group defines the Alternate dimension properties
            .SetVariable "DimAlt", 1 
            .SetVariable "DimAltD", 2 
            .SetVariable "DimAltF", 1 
            .SetVariable "DimAltRnd", 0 
            .SetVariable "DimAltTD", 2 
            .SetVariable "DimAltTZ", 0 
            .SetVariable "DimAltU", 2 
            .SetVariable "DimAltZ", 0 
            .SetVariable "DimAPost", """" 
             'This group defines the Tolerance dimension properties
            .SetVariable "DimTol", 0 
            .SetVariable "DimTDec", 2 
            .SetVariable "DimTFac", 1 
            .SetVariable "DimTM", 0 
            .SetVariable "DimTolJ", 1 
            .SetVariable "DimTP", 0 
            .SetVariable "DimTZin", 0 
        End With 
        adDimStyle.CopyFrom ThisDrawing 
         'End Add Med Dim Styles
         
        Set sset = mDoc.SelectionSets.Add("TEST") 
         'ZoomExtents
         'ZoomAll
        mFxdNm = Replace(mPath & mFileName, ".DXF", "Rev") 
        mDoc.Export mFxdNm, "DXF", sset 
        mDoc.Close False 
        ZoomExtents 
         'copy new file over exist file
        FileCopy mFxdNm & ".DXF", mPath & mFileName 
         'delete the new file
        Kill mFxdNm & ".DXF" 
        Set mDoc = Nothing 
        Set mNewLyr = Nothing 
        mFileName = Dir 
    Wend 
End Sub 
 
 'Below contributed by lucas :D
Sub DeleteLayouts(iDoc As AcadDocument) 
    Dim adLayout As AcadLayout 
    On Error Resume Next 
    If iDoc.ActiveSpace = acPaperSpace Then _ 
    iDoc.ActiveSpace = acModelSpace 
    ZoomExtents 
    For Each adLayout In iDoc.Layouts 
        adLayout.Delete 
         'ZoomAll
    Next adLayout 
    Err.Clear 
    On Error Goto 0 
End Sub 
 '*************************************************************************
 ' should change all objects to a single layer by Tommy VBAX
 
Sub ChnageAllToLyer() 
    Dim ssAll As AcadSelectionSet, mEntity As AcadEntity 
    Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities") 
    ssAll.Select acSelectionSetAll 
    For Each mEntity In ssAll 
        mEntity.Layer = "0" 
    Next 
    ssAll.Clear 
    ssAll.Delete 
    Set ssAll = Nothing 
    ThisDrawing.Regen acActiveViewport 
End Sub 
 
 '*************************************************************************

VBA tags courtesy of www.thecodenet.com

[Tommy]

Hey Rob,

Who says you can't teach an old dog new tricks. I had the same problem and didn't know it!! This fixed it though

Sub ChnageAllToLyer() 
    Dim ssAll As AcadSelectionSet, mEntity As AcadEntity 
    Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities") 
    ssAll.Select acSelectionSetAll 
    For Each mEntity In ssAll 
         'move entity to layer "0"
        mEntity.Layer = "0" 
         'make sure entity is "ByLayer"
        mEntity.Color = 256 
    Next 
    ssAll.Clear 
    ssAll.Delete 
    Set ssAll = Nothing 
    ThisDrawing.Regen acActiveViewport 
End Sub 

VBA tags courtesy of www.thecodenet.com

[RMS]

Hey Tommy,

I included a zip file of a rectangle. Take a look at it please, because I was not able to change my objects (rectangle) to layer 0 so maybe its my Cad system not sure. One other thing I use 2005 BUT I have to save as a 2000 for our vendor.

Thanks for the help

[Tommy]

I changed the version to acad 2000 cause I don't have the particular version you have/was posted. I then ran the macro(revised already posted). It worked. The new file name is testab.dxf

EDIT: Added the name of the new dxf

[fixo]

Hi, guys
Just have thought, perhaps, there is need to add
the piece of code to work with locked layers...
Something like:

 
Sub ChangeAllToLayerZero()
     Dim ssAll As AcadSelectionSet, mEntity As AcadEntity
 
     On Error Resume Next
     ThisDrawing.SelectionSets("AllEntities").Delete
     If Err Then
     Err.Clear
     End If
     Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities")
     ssAll.Select acSelectionSetAll
     Dim lockedColl As New Collection
     Dim itmLay As Variant, i As Long
     With ThisDrawing
          ' set as active layer "0"
          .ActiveLayer = .Layers("0")
          If .Layers("0").Lock = True Then
          .Layers("0").Lock = False
          End If
          For Each mEntity In ssAll
               'unlock layer if this was locked
               If .Layers(mEntity.Layer).Lock = True Then
                    .Layers(mEntity.Layer).Lock = False
                    mEntity.Layer = "0"
                    mEntity.color = acByLayer     '// remove this line if no needed
                    mEntity.Lineweight = acLnWtByLayer     '// remove this line if no needed
               ' add layer name to collection with key that allow to add just iniques only
               i = i + 1
               lockedColl.Add mEntity.Layer, CStr(i)
               Else
                    mEntity.Layer = "0"
                    mEntity.color = acByLayer     '// remove this line if no needed
                    mEntity.Lineweight = acLnWtByLayer     '// remove this line if no needed
               End If
          Next
          .Regen acAllViewports
          For Each itmLay In lockedColl
          'then turn back to lock all the unlocked layers
          .Layers.Item(itmLay).Lock = True
          Next
     End With
 
     ssAll.Clear
     ssAll.Delete
     Set ssAll = Nothing
End Sub

Bear in mind this will not change the layer
of subentities, say in blocks and also the
same thing with other complex objects like
the dimensions, leaders etc.

Regards,

Oleg

~'J'~

[RMS]

Quote:   Originally Posted by: Tommy I changed the version to acad 2000 cause I don't have the particular version you have/was posted. I then ran the macro(revised already posted). It worked. The new file name is testab.dxf EDIT: Added the name of the new dxf

I look at the file and yeah it did work for you........so I have some strange setting problably screwing me up somewhere.......ok I will have to look into this more.

Thanks alot guys!

[DennisHowe]

Hey Folks
Hope you dom't mind me butting in on your discussion.
I have a similar problem. I have a messy drawing with entities scattered over lots of different layers (a survey drawing with GPS points etc). I am trying to move all the entities onto certain layers depending on what the object name is and possibly on its colour. I was having trouble with my code finding all of the different objectnames so I tried tried your code and it really blew up.

On the line "Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities")" it gives an error message "The named selection set exists". I am using version 2007.

Any clues?

The code I was trying to use is listed below.

 
Public Function Changelayers() As Long 
    On Error Goto Errhand 
    Dim allEnt As AcadObject 
    Dim entObjectID As Long, xI As Integer, xBool As Boolean, gg As Long 
    Dim entObjectName As String, Clr As Integer 
    Dim entry As AcadEntity, x As Integer 
    For Each entry In ThisDrawing.ModelSpace 
        x = x + 1 
        entObjectID = entry.ObjectID 
        entObjectName = entry.ObjectName 
        Clr = entry.color 
        For xI = 0 To UBound(oName) 
            If entObjectName = oName(xI) Then 
                xBool = True 
                Exit For 
            End If 
        Next xI 
        If xBool = False Then 
            gg = pushPoint(entObjectName) 
            Debug.Print entObjectName 
        End If 
        Select Case entObjectName 
        Case "AcDbPoint" 
             ' entry.Layer = "Controlpoints"
        Case "acdbpolyline" 
             
        Case "AcDbCircle" 
             ' entry.Layer = "Controlpoints"
        Case "acdbLine" 
             
        Case "acdbText" 
        End Select 
         
    Next 
    Exit Function 
Errhand: 
     
    If Err.Number = 9 Then 
        ReDim oName(0) 
        Resume 
    End If 
End Function 

VBA tags courtesy of www.thecodenet.com

The array bit is only there to get a distinct list of objectnames.
The problem I am having is that it only finds three objectnames.
AcDbCircle
AcDbPoint
AcDbText
I know that I have ordinary lines, splines and polylines but it just won't find then.

Any help would be very much appreciated.
Thanks


EDIT: Added VBA tags Tommy

[DennisHowe]

Hey don't mind me!!
I was just looking through my code and realise that I didn't reset 'xBool' to false so it couldn't print all the names. It now happily finds my lines and polylines etc etc.
I also realised that i needed to delete the SelectionSet in your code before rsetting it so it works happily as well.
Thank again

[RMS]

Educate me, what is SelectionSet all about, because I have no idea? I use AutoCAD all the time but I am new to VB and the programing world.

Rob

[Tommy]

A selectionset is just another way to select a group of entities. The entities could be in a layer, multiple layers, just one type of entity. You can filter the selection set with dxf codes. Once the selection set is filled or has entities you can iterate through it and modify (change layers, colors, linetype....)

The selection set problem should have been taken care of here (as originally posted by Fatty )

On Error Resume Next 
ThisDrawing.SelectionSets("AllEntities").Delete 
If Err Then 
    Err.Clear 
End If 
Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities") 
 

VBA tags courtesy of www.thecodenet.com

See this post for more information and how to filter .. well at least a small discussion on it.

http://www.vbaexpress.com/forum/showthread.php?t=7479

@ DennisHowe

Why don't you filter the selection set?

[Spike]

Is it possible to modify the code used in this thread to select all the layers in a drawing and set their color to white? I am a field engineer and I am creating my "as built" drawings electronically. In order to clearly identify what I need changed I want to convert all existing layers to white. Would someone be so kind as to help get me pointed in the right direction. I have some VBA experience with Excel, but I'm new to AutoCAD.

Thanks,
Spike

[fixo]

Here is a quick and dirty solution, based on I posted
above, unfortunately I haven't have a time to varnish
this code
Anyway, you can try it

 
Option Explicit
Sub ChangeLayersColor()
     On Error Resume Next
     Dim oLayer As AcadLayer, itmLay As Variant, i As Long
     Dim lockedColl As New Collection
     With ThisDrawing
          For Each oLayer In .Layers
               'unlock layer if this was locked
               If oLayer.Lock = True Then
                    oLayer.Lock = False
                    oLayer.color = acWhite
               ' add layer name to collection with key that allow to add just iniques only
               i = i + 1
               lockedColl.Add oLayer.Name, CStr(i)
               End If
          Next
          .Regen acAllViewports
          For Each itmLay In lockedColl
          'then turn back to lock all the unlocked layers
          .Layers.item(itmLay).Lock = True
          Next
     End With
End Sub

~'J'~

[lucas]

Spike, you really should start a new thread to ask this question as it's not closely related to what they are doing here.

Your problem is not that hard to resolve.

[lucas]

Please excuse my intrusion. I thought I was on the stretching diminsions thread.......carry on as if I was never here.