TheSwamp
Code Red => VB(A) => Topic started by: nivuahc on February 01, 2006, 10:22:04 AM
-
Okay, here's what I've got in VBA. I didn't write this by myself, I had lots of help ( a few years ago). I can't even explain everything that's going on with this code (I mean, sure, I have the general idea... I can read the code and see what's happening.) so I can't tell you why something is the way that it is. What I'm wanting to do is make this better.
What I use it for: When we get a composite plan from an architect we usually have to run this on it in order to 'fix' the drawing so that all of the items in the drawing are set to BYLAYER. Then it changes all of the layers in the drawing to color 252 so we can use it as a base plan.
Right now, it works, but it's very slow (especially on large drawings) and it changes the color of layer '0' and layer 'Defpoints' (if it exists) to color 252. It also, for some reason I am unaware of, fails to get some attributes and it also fails to change nested blocks. And, it occasionally skips dimensions altogether. Once the basics of the routine are done it performs a purge that almost purges everything out of the drawing.
I know this can be better. I just don't know how to make it so. I'd also like to do something a bit different but I don't have a clue when it comes to VBA.
What I'd like to see it do: I'd like to take each and every entity in the drawing and find out what linetype it is. If it's 'BYLAYER' then find out what linetype is assigned to that layer. Change the entity to that linetype (yes, I know) and, when done, change the layer of each entity to a single layer (i.e. E-BASE-PLAN), retaining the original linetype. In the case of frozen layers or layers that are turned off, those items 'not shown' are useless to me, so they should be discarded completely. When complete, there should be 2 layers in the drawing; '0' and 'E-BASE-PLAN' and each entity should have it's color set to 'BYLAYER' and it's linetype set to whatever.
I was going to try to tackle this in LISP but I am so 'under the gun' at work I haven't had any time to devote to it.
Option Explicit
Sub dwgfix()
Call Set2Bylayer
Call FixBlocks
Call SetLayers
Call DoAtts
ThisDrawing.PurgeAll
End Sub
Sub Set2Bylayer()
On Error Resume Next
Dim ObjEnt As AcadEntity
' use current drawing
With ThisDrawing
' set active layer
.ActiveLayer.Name = "0"
.Application.Update
' change all entities in model space to color bylayer and lineweight bylayer (includes frozen)
For Each ObjEnt In .ModelSpace
'check if the layer is locked, if it is unlock it
If .Layers.Item(ObjEnt.Layer).Lock = True Then
.Layers.Item(ObjEnt.Layer).Lock = False
ObjEnt.Color = acByLayer
ObjEnt.Lineweight = acLnWtByLayer
ObjEnt.Update
'then lock it back so as to not change the layer state
.Layers.Item(ObjEnt.Layer).Lock = True
Else
ObjEnt.Color = acByLayer
ObjEnt.Lineweight = acLnWtByLayer
ObjEnt.Update
End If
Next
End With
End Sub
Sub FixBlocks()
' Redefines all blocks in a drawing to have property values of
' color & linweight bylayer
Dim blockObj As AcadBlock
Dim i As Long
For Each blockObj In ThisDrawing.Blocks
On Error Resume Next
For i = 0 To blockObj.Count - 1
'check if the layer is locked, if it is unlock it
If ThisDrawing.Layers.Item(blockObj.Item(i).Layer).Lock = True Then
ThisDrawing.Layers.Item(blockObj.Item(i).Layer).Lock = False
blockObj.Item(i).Color = acByLayer
blockObj.Item(i).Lineweight = acLnWtByLayer
'then lock it back so as to not change the layer state
ThisDrawing.Layers.Item(blockObj.Item(i).Layer).Lock = True
Else
blockObj.Item(i).Color = acByLayer
blockObj.Item(i).Lineweight = acLnWtByLayer
End If
Next i
Next blockObj
End Sub
Sub SetLayers()
Dim objLayer As AcadLayer
For Each objLayer In ThisDrawing.Layers
objLayer.Color = 252
objLayer.Lineweight = acLnWtByLwDefault
Next
End Sub
Sub DoAtts()
Dim AllAtts As Variant
Dim Att As AcadAttributeReference
Dim SelSet As AcadSelectionSet
Dim BlockEnt As AcadBlockReference
Dim X As Long
Dim GCode As Variant
Dim GData As Variant
Dim Code(0) As Integer
Dim Data(0) As Variant
Code(0) = 0
Data(0) = "INSERT"
GCode = Code
GData = Data
On Error GoTo BlockError
Set SelSet = ThisDrawing.SelectionSets.Add("Blocks")
SelSet.Select acSelectionSetAll, , , GCode, GData
SelSet.Select acSelectionSetAll, , , 0, "INSERT"
On Error Resume Next
For Each BlockEnt In SelSet
If BlockEnt.HasAttributes Then
AllAtts = BlockEnt.GetAttributes
For X = 0 To UBound(AllAtts)
Set Att = AllAtts(X)
Att.Layer = "0"
Att.Color = acByLayer
Next X
End If
Next BlockEnt
BlockError:
ThisDrawing.SelectionSets.Item("Blocks").Delete
End Sub
-
This should be pretty easy to do. What kind of time frame do you have?
-
This is what I have we can work with
Public Sub Vendor()
Dim objLay As AcadLayer
Dim ENT As AcadEntity, objText As AcadText, objMText As AcadMText, objRotDim As AcadDimRotated
On Error Resume Next
Set objLay = ThisDrawing.Layers.Add("VNDR-THIN")
objLay.color = 8
Set objLay = ThisDrawing.Layers.Add("VNDR-TEXT")
objLay.color = 80
For Each ENT In ThisDrawing.ModelSpace
Select Case ENT.ObjectName
Case "AcDbText"
ENT.Layer = "VNDR-TEXT"
Case "AcDbMText"
ENT.Layer = "VNDR-TEXT"
Case "AcDbRotatedDimension"
ENT.Layer = "VNDR-TEXT"
Case Else
ENT.Layer = "VNDR-THIN"
End Select
Next ENT
ThisDrawing.Regen acAllViewports
End Sub
Public Sub Everythingbylayer()
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim N As Integer
On Error Resume Next
If ThisDrawing.SelectionSets.Count > 0 Then
For N = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(N).Name = "EBL" Then
ThisDrawing.SelectionSets("EBL").Delete
End If
Next N
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("EBL")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
objSelected.color = acByLayer
objSelected.Linetype = "ByLayer"
objSelected.Lineweight = acLnWtByLayer
objSelected.Update
Next
ThisDrawing.SelectionSets.Item("EBL").Delete
ZoomExtents
ThisDrawing.Application.Update
Exit_Here:
Exit Sub
End Sub
-
so im thinking you want to
- Unlock all layers
- Delete all layers FROZEN and/or OFF
- create the layers you need (E-BASE-PLAN)
- Set colors to layers you are keeping
- For each object in mspace, get layer, get linetype of layer, set linetype to object
- Put each object on E-BASE-PLAN
-
This should be pretty easy to do. What kind of time frame do you have?
If, by time frame you mean "how much time do you have available to devote to this?"...
Not much. :( I'm buried under a pile of drawings right now and there is no real end in sight.
If, by time frame you man "how quickly are you looking for a solution?"...
There is no time frame. I'm not being pressured to make this, this would just make a lot of what I'm doing right now easier, thereby freeing up some of my time.
I'm willing to learn, though I can't promise stellar results when it comes to VBA (I've tried before but always get pulled in another direction so quickly forget what it was that I learned).
I'm looking at the code you posted above right now and attempting to make sense of it. As soon as I get finished, I'll post back here and tell you what I think it does. That should give you and idea about where I stand with VBA :D
so im thinking you want to
- Delete all layers frozen and or off
- create the layers you need (E-BASE-PLAN)
- Set colors to layers you are keeping
- For each object in mspace, get layer, get linetype of layer, set linetype to object
- Put each object on E-BASE-PLAN
Precisely :)
-
If, by time frame you man "how quickly are you looking for a solution?"...
There is no time frame.
Excellent, then we have us a project with an open end date, so we can dial it in just the way you want it.
-
Okie doke, here is my attempt to "break it down, now"
Public Sub Vendor()
Dim objLay As AcadLayer
Dim ENT As AcadEntity, objText As AcadText, objMText As AcadMText, objRotDim As AcadDimRotated
On Error Resume Next
Set objLay = ThisDrawing.Layers.Add("VNDR-THIN")
objLay.color = 8
Set objLay = ThisDrawing.Layers.Add("VNDR-TEXT")
objLay.color = 80
Create two layers. One called VNDR-THIN, color 8, and one called VNDR-TEXT, color 80.
For Each ENT In ThisDrawing.ModelSpace
Select Case ENT.ObjectName
Case "AcDbText"
ENT.Layer = "VNDR-TEXT"
Case "AcDbMText"
ENT.Layer = "VNDR-TEXT"
Case "AcDbRotatedDimension"
ENT.Layer = "VNDR-TEXT"
Case Else
ENT.Layer = "VNDR-THIN"
End Select
Next ENT
For each entity on the drawing change it to layer VNDR-TEXT if it is text, mtext or rotated dimensions?
ThisDrawing.Regen acAllViewports
End Sub
Regen! :)
Public Sub Everythingbylayer()
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim N As Integer
On Error Resume Next
If ThisDrawing.SelectionSets.Count > 0 Then
For N = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(N).Name = "EBL" Then
ThisDrawing.SelectionSets("EBL").Delete
End If
Next N
End If
EBL? I presume that's short for Everything By Layer but, I admit, I have no idea what you're doing with it there. Are you looking for a named selection set and deleting it if it exists? Named selection set? Huh? Is that akin to creating a variable with LISP? (i.e. (setq EBL (ssget "x")) )
Set OBJSELSET = ThisDrawing.SelectionSets.Add("EBL")
OBJSELSET.Select acSelectionSetAll
hmmmm... probably. And I'm guessing that this creates said selection set and selects "all"
For Each objSelected In OBJSELSET
objSelected.color = acByLayer
objSelected.Linetype = "ByLayer"
objSelected.Lineweight = acLnWtByLayer
objSelected.Update
Next
ThisDrawing.SelectionSets.Item("EBL").Delete
Change all colors, linetypes and lineweights to "BYLAYER" then delete the created (named) selection set (EBL)
ZoomExtents
Now that's a real head scratcher ;)
ThisDrawing.Application.Update
Exit_Here:
Exit Sub
End Sub
Wrap it all up and we're done.
How was that?
-
awsome!!! you can do this! I have got the next part for you as well
Option Explicit
Public Sub FIXLAYERS()
Call DELETELAYERS
Call SETUPLAYERS
Call SETCOLORLINETYPE
Call CHANGELAYER
End Sub
Private Sub DELETELAYERS()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
For Each objLayer In ThisDrawing.Layers
If objLayer.Name = "0" Then
objLayer.Lock = False
objLayer.LayerOn = True
'objLayer.Freeze = False
Else
objLayer.Lock = False
End If
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
ThisDrawing.Application.Update
ThisDrawing.Regen acAllViewports
For Each objLayer In ThisDrawing.Layers
If objLayer.LayerOn = False Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
For Each objLayer In ThisDrawing.Layers
If objLayer.Freeze = True Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
End Sub
Private Sub SETUPLAYERS()
Dim objLay As AcadLayer
Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")
objLay.color = 252
End Sub
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "changecolorline" Then
ThisDrawing.SelectionSets("changecolorline").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("changecolorline")
OBJSELSET.Select acSelectionSetAll
'this is where we are at so far
End Sub
Private Sub CHANGELAYER()
MsgBox "CHANGE LAYER"
End Sub
-
At this point you will see some 'repeating' type code, Im trying to get you some concept code that works, we can make it pretty later.
-
Here is a lisp variant of setting all objects in a drawing to bylayer...brought to you by resident code master MP. :)
http://www.theswamp.org/forum/index.php?topic=3020.msg37746#msg37746
-
This is mostly where you want to be
Option Explicit
Public Sub FIXLAYERS()
Call DELETELAYERS
Call SETUPLAYERS
Call SETCOLORLINETYPE
Call CHANGELAYER
End Sub
Private Sub DELETELAYERS()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
For Each objLayer In ThisDrawing.Layers
If objLayer.Name = "0" Then
objLayer.Lock = False
objLayer.LayerOn = True
'objLayer.Freeze = False
Else
objLayer.Lock = False
End If
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
ThisDrawing.Application.Update
ThisDrawing.Regen acAllViewports
For Each objLayer In ThisDrawing.Layers
If objLayer.LayerOn = False Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
ThisDrawing.SelectionSets("layerdelete").Delete
For Each objLayer In ThisDrawing.Layers
If objLayer.Freeze = True Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
End Sub
Private Sub SETUPLAYERS()
Dim objLay As AcadLayer
Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")
objLay.color = 252
End Sub
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
Dim strLinetype As String
Dim strLayer As String
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "ChangeLine" Then
ThisDrawing.SelectionSets("ChangeLine").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("ChangeLine")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
strLinetype = ThisDrawing.Layers(objSelected.Layer).Linetype
objSelected.Linetype = strLinetype
Next
ThisDrawing.SelectionSets("ChangeLine").Delete
End Sub
Private Sub CHANGELAYER()
Dim ENT As AcadEntity
On Error Resume Next
For Each ENT In ThisDrawing.ModelSpace
ENT.Layer = "E-BASE-PLAN"
Next ENT
ThisDrawing.Regen acAllViewports
End Sub
All that is left is processing blocks and attributes
-
Round 2...
Option Explicit
Public Sub FIXLAYERS()
Call DELETELAYERS
Call SETUPLAYERS
Call SETCOLORLINETYPE
Call CHANGELAYER
End Sub
This is the actual 'function' that we'll use (FIXLAYERS) that will call the other functions in the order shown
What follows is our first called sub-function (DELETELAYERS)
Private Sub DELETELAYERS()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
Make layer '0' current
For Each objLayer In ThisDrawing.Layers
If objLayer.Name = "0" Then
objLayer.Lock = False
objLayer.LayerOn = True
'objLayer.Freeze = False
Else
objLayer.Lock = False
End If
Make sure that layer '0' is neither locked nor frozen and turn it on if need be. Make sure the rest of the layers in the drawing are unlocked, should they be locked.
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
ThisDrawing.Application.Update
ThisDrawing.Regen acAllViewports
Okay... other than the Application.Update (what does that do anyway?) and the regen, didn't we already set layer '0' as current? Why are we doing it again?
For Each objLayer In ThisDrawing.Layers
If objLayer.LayerOn = False Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Alright, I'll admit that I don't quite follow exactly what's going on here... It seems like what you are doing is checking to see if a particular layer is off and, if it is, uhhh... hmmmm... then what?
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
Whoa! I guess this is where we're taking all layers that are off and deleting them... but I can't say how we're doing that.
For Each objLayer In ThisDrawing.Layers
If objLayer.Freeze = True Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
Same thing as the layers that are off, only this is dealing with the layers that are frozen. Still not sure about the process taking place though.
End Sub
This is the end of our first called sub-function (DELETELAYERS)
What follows is our second called sub-function (SETUPLAYERS)
Private Sub SETUPLAYERS()
Dim objLay As AcadLayer
Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")
objLay.color = 252
End Sub
This is the end of our second called sub-function (SETUPLAYERS)
It creates a layer called E-BASE-PLAN and assigns it a color of 252
What follows is our third called sub-function (SETCOLORLINETYPE)
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "changecolorline" Then
ThisDrawing.SelectionSets("changecolorline").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("changecolorline")
OBJSELSET.Select acSelectionSetAll
Ummm... same stuff, only different.
'this is where we are at so far
A comment! :D
End Sub
This is the end of our third called sub-function (SETCOLORLINETYPE)
What follows is our fourth called sub-function (CHANGELAYER)
Private Sub CHANGELAYER()
MsgBox "CHANGE LAYER"
End Sub
This is the end of fourth called sub-function (CHANGELAYER)
It pops up a MSGBOX that says "CHANGE LAYER"
How'd I do?
Hey! More code to go through! :)
-
For Each objLayer In ThisDrawing.Layers
If objLayer.LayerOn = False Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Alright, I'll admit that I don't quite follow exactly what's going on here... It seems like what you are doing is checking to see if a particular layer is off and, if it is, uhhh... hmmmm... then what?
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
Whoa! I guess this is where we're taking all layers that are off and deleting them... but I can't say how we're doing that.
You are doing fine translating this
for each layer in this drawing layers collection, if its turned OFF (layeron=false) , make a selection set of ALL, then for each obj in SS, if the obj.Layer = ObjLayer.name (The name of the turned off layer), delete the object, repeat for next obj. Then delete layer from DB
-
Private Sub CHANGELAYER()
Dim ENT As AcadEntity
On Error Resume Next
For Each ENT In ThisDrawing.ModelSpace
ENT.Layer = "E-BASE-PLAN"
Next ENT
ThisDrawing.Regen acAllViewports
End Sub
Other than a change in nomenclature ("ChangeLine") I think this is all that changed. And it seems that this changes the layer of each entity in the drawing to layer E-BASE-PLAN.
Shouldn't we have put something like this, though, in the SETCOLORLINETYPE sub?
objLayer.Color = acByLayer
-
Okie doke, here is my attempt to "break it down, now"
For each entity on the drawing change it to layer VNDR-TEXT if it is text, mtext or rotated dimensions?
that?
Yes, and what is weird is EVERY dimension is a rotated dimension once it has been inserted into the drawing. grab a few dims and look at your properties box
-
I updated this code to reflect your last post
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
Dim strLinetype As String
Dim strLayer As String
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "ChangeLine" Then
ThisDrawing.SelectionSets("ChangeLine").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("ChangeLine")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
strLinetype = ThisDrawing.Layers(objSelected.Layer).Linetype
objSelected.Linetype = strLinetype
objSelected.color = acByLayer ' I ADDED IT HERE
Next
ThisDrawing.SelectionSets("ChangeLine").Delete
End Sub
-
This is everything I have so far
Option Explicit
Public Sub FIXLAYERS()
Call DELETELAYERS
Call SETUPLAYERS
Call SETCOLORLINETYPE
Call CHANGELAYER
End Sub
Private Sub DELETELAYERS()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
For Each objLayer In ThisDrawing.Layers
If objLayer.Name = "0" Then
objLayer.Lock = False
objLayer.LayerOn = True
'objLayer.Freeze = False
Else
objLayer.Lock = False
End If
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
ThisDrawing.Application.Update
ThisDrawing.Regen acAllViewports
For Each objLayer In ThisDrawing.Layers
If objLayer.LayerOn = False Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
ThisDrawing.SelectionSets("layerdelete").Delete
For Each objLayer In ThisDrawing.Layers
If objLayer.Freeze = True Then
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
ThisDrawing.SelectionSets("layerdelete").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
If objSelected.Layer = objLayer.Name Then
objSelected.Delete
End If
Next
objLayer.Delete
End If
Next
End Sub
Private Sub SETUPLAYERS()
Dim objLay As AcadLayer
Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")
objLay.color = 252
End Sub
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
Dim strLinetype As String
Dim strLayer As String
If ThisDrawing.SelectionSets.Count > 0 Then
For n = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(n).Name = "ChangeLine" Then
ThisDrawing.SelectionSets("ChangeLine").Delete
End If
Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("ChangeLine")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
strLinetype = ThisDrawing.Layers(objSelected.Layer).Linetype
objSelected.Linetype = strLinetype
objSelected.color = acByLayer ' I ADDED IT HERE
Next
ThisDrawing.SelectionSets("ChangeLine").Delete
End Sub
Private Sub CHANGELAYER()
Dim ENT As AcadEntity
On Error Resume Next
For Each ENT In ThisDrawing.ModelSpace
ENT.Layer = "E-BASE-PLAN"
Next ENT
ThisDrawing.Regen acAllViewports
End Sub
-
for each layer in this drawing layers collection, if its turned OFF (layeron=false) , make a selection set of ALL, then for each obj in SS, if the obj.Layer = ObjLayer.name (The name of the turned off layer), delete the object, repeat for next obj. Then delete layer from DB
PMFJI, but.....It seems to me this is the absolute slowest way of accomplishing this task and the next (frozen layers).Creating and stepping through a selection set of everything in the drawing for every layer that is off and again for every layer that is frozen.....
Something like this makes far more sense to me......use it once and move on. You could also make the strFltr a gloabl variable for use in cycling blocks to remove any objects from them that may be on those layers (use of InStr or Like would work for this).
Sub Freeze_Off_Delete()
Dim strFltr As String
Dim oLayer As AcadLayer
Dim oSS As AcadSelectionSet
Dim oEnt As AcadEntity
Dim iCode(0) As Integer
Dim vData(0) As Variant
For Each oLayer In ThisDrawing.Layers
If (oLayer.Freeze = True) Or (oLayer.LayerOn = False) Then
If strFltr = "" Then
strFltr = oLayer.Name
Else
strFltr = strFltr & "," & oLayer.Name
End If
End If
Next
On Local Error Resume Next
Set oSS = ThisDrawing.SelectionSets.Item("DeleteEm")
If Err.Number <> 0 Then
Set oSS = ThisDrawing.SelectionSets.Add("DeleteEm")
Err.Clear
End If
On Local Error GoTo 0
oSS.Clear
iCode(0) = 8: vData(0) = strFltr
oSS.Select acSelectionSetAll, , , iCode, vData
For Each oEnt In oSS
oEnt.Delete
Next
oSS.Delete
End Sub
Just my $0.02....
Jeff
-
PMFJI - ??
I threw it together, and hadn't gone back to optimize it yet
-
PMFJI - ??
I threw it together, and hadn't gone back to optimize it yet
Pardon Me For Jumping In.......
Sorry, carry on..... :-) I just saw that explanation and felt obliged to comment, especially since it seems like Chuck is trying to learn from this.
/me *back to lurk mode*
-
By all means jump in, I could use the help
-
Okay, a hypothetical situation:
Let's say I have a line that's set to layer "EXAMPLE" set to color "BYLAYER" and linetype "DASHED". However, I also have an arc set to layer "EXAMPLE" which is color "RED" and linetype "BYLAYER". And, on top of that, I have an ellipse set to layer "EXAMPLE" with color and linetype set to "BYBLOCK". And, to top all of that off, the layer "EXAMPLE" has a linetype of "HIDDEN".
In the code posted so far, what will happen to those entities? Specifically, what will happen to those set to "BYLAYER" or "BYBLOCK"?
for each layer in this drawing layers collection, if its turned OFF (layeron=false) , make a selection set of ALL, then for each obj in SS, if the obj.Layer = ObjLayer.name (The name of the turned off layer), delete the object, repeat for next obj. Then delete layer from DB
PMFJI, but.....It seems to me this is the absolute slowest way of accomplishing this task and the next (frozen layers).Creating and stepping through a selection set of everything in the drawing for every layer that is off and again for every layer that is frozen.....
I thought the same thing when I looked at the code... partly why I was confused... but I was (and still am) willing to see where this is headed :)
...I just saw that explanation and felt obliged to comment, especially since it seems like Chuck is trying to learn from this.
/me *back to lurk mode*
NO LURKING ALLOWED! ;-)
The more the merrier, I always say :-)
-
based on previous posts, I set each entity to the linetype of the layer they were on, even if it was continuous. Based on another comment, I added the color bylayer piece. Did I miss understand?
-
Let's say I have a line that's set to layer "EXAMPLE" set to color "BYLAYER" and linetype "DASHED". However, I also have an arc set to layer "EXAMPLE" which is color "RED" and linetype "BYLAYER". And, on top of that, I have an ellipse set to layer "EXAMPLE" with color and linetype set to "BYBLOCK". And, to top all of that off, the layer "EXAMPLE" has a linetype of "HIDDEN".
As far as I know, everything will be assigned Hidden (From the layer Example) AND it just hit me B/T the eyes, you wanted everything that was bylayer to be assigned, and everything that was hardcoded (for lack of better term) to stay that way.
closer?
-
<*HeadsUp*>
Before you all run into something unexpected, as did I when I was writing a similar routine a few months ago, your VBA application will up & die (or at least puke heavily) if it encounters any RTEXT objects. I worked around this by using a selectionset function in my calling lisp wrapper that either deletes or explodes ,with the command line version, the RTEXT.</*HeadsUp*>
-
Using my hypothetical:
Each entity would be set as such
(Entity - Color - Linetype)
line - ByLayer - DASHED
arc - ByLayer - HIDDEN
ellipse - ByLayer - HIDDEN***
*** - Now this is where it gets tricky (at least I think so)... BYBLOCK
If it's a nested entity (let's say that ellipse is actually part of a block) then the the linetype would depend entirely on the linetype assigned to the block that it's a part of. So maybe it would be best to leave those entities as "BYBLOCK" as far as the linetype is concerned. But what if it's not a nested entity?
Maybe I'm just thinking too hard and I'm making this seem (to me) to be more difficult than it really is.
-
It seems to me that if an object has a linetype, or color, of BYBLOCK then it should be an object IN a block and should be left alone. If it is an object that is actually in Modelspace, then it should take on the properties of the layer it is on......
-
It seems to me that if an object has a linetype, or color, of BYBLOCK then it should be an object IN a block and should be left alone. If it is an object that is actually in Modelspace, then it should take on the properties of the layer it is on......
yeah, that makes the most sense.
-
Jeff, feel free to jump in on the block conversion and attribute conversion, as I have never modified sub-entities. I was kinda hoping someone would pick up from here and go with it.
Now, we agree that all entities are to be color bylayer right?
And, if an entity has a linetype assigned, it keeps that linetype, and moves to the new layer,
But if an entity is linetype bylayer, it gets assigned the linetype of the layer its on, and then moves to new layer?
does this make sense
-
Jeff, feel free to jump in on the block conversion and attribute conversion, as I have never modified sub-entities. I was kinda hoping someone would pick up from here and go with it.
Now, we agree that all entities are to be color bylayer right?
And, if an entity has a linetype assigned, it keeps that linetype, and moves to the new layer,
But if an entity is linetype bylayer, it gets assigned the linetype of the layer its on, and then moves to new layer?
does this make sense
Zackly :)
-
I hope you guys have Flash installed so you can see (and hear) this (http://www.careerbuilder.com/monk-e-mail/?mid=2878065). :)
-
OK, here's what I threw together.....I have not tested on a large drawing, just a small test dwg. I think it satisfies everything Chuck wanted. I kept it all in one Sub to eliminate any multiple accesses to the blocks/model space.
Trouble is, I gotta leave for the remainder of the day so I won't be available for questions or floggings.
Make sure to add a reference, as noted in the code, to the MS Scripting Runtime....this is so we can use the Dictionary object which has an EXISTS method, slick way to see if something is in a list of items.
Good Luck!
Sub Delete_Freeze_N_Off_Fix_Color_N_Linetype()
'requires reference to MS Scripting Runtime
Dim oLayer As AcadLayer
Dim oEnt As AcadEntity
Dim I As Integer
Dim colLays As New Dictionary
Dim oBlkRef As AcadBlockReference
Dim oatts As Variant
Dim oatt As AcadAttributeReference
'First let's create the Base layer with the color 252
Set oLayer = ThisDrawing.Layers.Add("E-BASE-PLAN")
oLayer.Color = 252
'Now set the current layer to it
ThisDrawing.ActiveLayer = oLayer
'create a dictionary of frozen/off layers
For Each oLayer In ThisDrawing.Layers
If (oLayer.Freeze = True) Or (oLayer.LayerOn = False) Then
colLays.Add oLayer.Name, I
I = I + 1
End If
oLayer.Lock = False 'make sure they are all unlocked
Next
''Now check the block defs for objects on these layers
Dim oBlk As AcadBlock
For Each oBlk In ThisDrawing.Blocks
If oBlk.Name = "*Model_Space" Then 'First up, Modelspace
For Each oEnt In oBlk
If colLays.Exists(oEnt.Layer) Then 'Delete frozen/Off objects
oEnt.Delete
Else ' it's visible, change the color/linetype to suit
oEnt.Color = acByLayer
If UCase(oEnt.Linetype) = "BYLAYER" Then
oEnt.Linetype = ThisDrawing.Layers.Item(oEnt.Layer).Linetype
End If
oEnt.Layer = "E-BASE-PLAN"
If TypeOf oEnt Is AcadBlockReference Then
Set oBlkRef = oEnt
If oBlkRef.HasAttributes Then
oatts = oBlkRef.GetAttributes
For I = 0 To UBound(oatts)
Set oatt = oatts(I)
oatt.Color = acByLayer
oatt.Layer = "E-BASE-PLAN"
Next
End If
End If
End If
Next
ElseIf (oBlk.IsLayout = False) And (oBlk.IsXRef = False) Then
'repeat for all other blocks, but leaving BYBLOCK objects alone
For Each oEnt In oBlk
If colLays.Exists(oEnt.Layer) Then
oEnt.Delete
Else
If oEnt.Color <> acByBlock Then oEnt.Color = acByLayer
If UCase(oEnt.Linetype) <> "BYBLOCK" Or UCase(oEnt.Linetype) = "BYLAYER" Then
oEnt.Linetype = ThisDrawing.Layers.Item(oEnt.Layer).Linetype
End If
oEnt.Layer = "E-BASE-PLAN"
If TypeOf oEnt Is AcadBlockReference Then
Set oBlkRef = oEnt
If oBlkRef.HasAttributes Then
oatts = oBlkRef.GetAttributes
For I = 0 To UBound(oatts)
Set oatt = oatts(I)
oatt.Color = acByLayer
oatt.Layer = "E-BASE-PLAN"
Next
End If
End If
End If
Next
End If
Next
End Sub
-
good job, I see that I have a lot to learn still
-
'requires reference to MS Scripting Runtime
:?
is that why I get an error on this line when I try to run it?
Dim colLays As New Dictionary
Compile error:
User-defined type not defined
A little enlightenment might be in order :angel:
-
i'll go out on a limb here, but i think in the IDE, go to Tools->references and find the MS Scripting Runtime
-
Yep, that's it! Just make sure to add a check mark next to it once found :-)
-
yep, that was it. :)
And the routine almost works :D
It leaves a few layers behind for some reason... I'll attach the drawing I tried it on if you wanna check it out (this drawing is pretty typical of what I get on a regular basis)
-
oops!
Forgot to mention that I added this towards the end:
End If
Next
ThisDrawing.PurgeAll
End Sub
-
I would also add ThisDrawing.Save
-
The layers that won't purge are kind of tough to get out......I'm working on a solution, but every time i think it's done, one more little problem crops up. And now, when I'm so close to getting it, I was just informed of some REAL work that, for some reason, they want done today. So I'm off of this until later on or maybe tomorrow.
Oh, the reason for them not being easily removed, is due to that layer being assigned to the EndBlk entity which cannot be obtained through normal means. I have a function that was posted on the old cadvault site that works sometimes, but other times it fails/errors out. I think that a part of this is due to a number of block definitions are empty but they won't purge since they are also inserted......'tis a vicious circle.
Once I get back to it I'll post my solution, or if someone else would like to pick it up from here......
-
That's great Jeff, thanks :)
One other thing I ran into today (I was playing around with it, trying it out on different drawings) was when I open a drawing that has proxy objects in it (in this case it was a civil plan) the routine runs... but nothing happens (other than the layer being created). No error or anything. And, when I closed AutoCAD (2002) it crashed. :)
I appreciate both of you helping me with this, now I need to understand it better.
-
Hi Chuck, you're welcome. The proxy_object issue I think will be pretty easy to fix (although the layers won't be modified for them), which should stop the crash. I'll try to setup a vanilla install to test with.
I'll try to place some comments in the final code for you to follow.....
-
ooooo... and MText. How would I go about changing the color of Mtext? That doesn't seem to work either :|
-
ooooo... and MText. How would I go about changing the color of Mtext? That doesn't seem to work either :|
This is a bit tougher since Mtext can have multiple colors embedded within the text.......each Mtext object would need to have the Textstring searched for all occurances of {\C#; and remove them, along with the closing } of each one found.
-
This is a bit tougher since Mtext can have multiple colors embedded within the text.......each Mtext object would need to have the Textstring searched for all occurances of {\C#; and remove them, along with the closing } of each one found.
Here is a lisp code to strip some of the formatting for mtext.
(defun StripString (String / cstr1 cstr2 nString cnt1 tstr1)
; Strips out formation for color, font, height and width.
(setq cnt1 1)
(while (and (setq cstr1 (substr String 1 1)) (> (strlen String) 0))
(if (= cstr1 "\\")
(progn
(setq cstr2 (substr String 2 1))
(if (member (strcase cstr2) '("C" "F" "H" "W"))
(progn
(while (/= (substr String cnt1 1) ";")
(setq cnt1 (1+ cnt1))
); while
(setq String (substr String (1+ cnt1) (strlen String)))
(setq cnt1 1)
); progn
(progn
(if nString
(setq nString (strcat nString (substr String 1 1)))
(setq nString (substr String 1 1))
); if
(setq String (substr String 2 (strlen String)))
); progn
); if
); progn
(progn
(if nString
(setq nString (strcat nString (substr String 1 1)))
(setq nString (substr String 1 1))
); if
(setq String (substr String 2 (strlen String)))
); progn
); if
); while
(setq tstr1 (vl-string->list nString))
(if (and (not (member 92 tstr1)) (member 123 tstr1))
(setq tstr1 (vl-remove-if '(lambda (x) (or (= x 123) (= x 125))) tstr1))
); if
(vl-list->string tstr1)
)