Printable View
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!
This will work for most things but I can't say if it will work correct with block entities.
[VBA]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]
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
Hey Rob,
How are you calling the sub? Like ChnageAllToLyer "0" ?
Oh well this will end the confusion Sorry
[VBA]
Sub ChnageAllToLyer()[/VBA]
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
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......
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.Quote:
Originally Posted by Tommy
[vba]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]
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 :)
[VBA]
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]
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
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.:dunno The new file name is testab.dxf
EDIT: Added the name of the new dxf
Hi, guys
Just have thought, perhaps, there is need to add
the piece of code to work with locked layers...
Something like:
Bear in mind this will not change the layerCode:
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
of subentities, say in blocks and also the
same thing with other complex objects like
the dimensions, leaders etc.
Regards,
Oleg
~'J'~
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.Quote:
Originally Posted by Tommy
Thanks alot guys!
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.
[VBA]
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]
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
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
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
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 :hi: )
[vba]
On Error Resume Next
ThisDrawing.SelectionSets("AllEntities").Delete
If Err Then
Err.Clear
End If
Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities")
[/vba]
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?
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
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
~'J'~Code:
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
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.
Please excuse my intrusion. I thought I was on the stretching diminsions thread.......carry on as if I was never here.
Many thanks, Fixo!! I stepped into the code and found it that it only changes the color if the layer was locked. I tweaked it a little and it works great.
Sorry, Lucas. I debated on whether or not to start a new thread, but I thought the code was related enough to use this one.
Sorry my bad
Try this one instead
(not tesded though because of
I can't rich Acad at the moment)
~'J'~Code:
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
' 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
oLayer.color = acWhite
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
It definitely is closely related spike.........I should read before I post.Quote:
Originally Posted by Spike
Sounds like you found your solution.