TheSwamp

Code Red => VB(A) => Topic started by: nivuahc on February 01, 2006, 10:22:04 AM

Title: Convert all to BYLAYER
Post 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.

Code: [Select]
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

Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 10:27:32 AM
This should be pretty easy to do.  What kind of time frame do you have?
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 10:28:28 AM
This is what I have we can work with
Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 10:49:46 AM
so im thinking you want to
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 10:52:48 AM
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 :)
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 10:55:31 AM
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.
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 11:21:08 AM
Okie doke, here is my attempt to "break it down, now"


Code: [Select]
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.

Code: [Select]
    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?

Code: [Select]
    ThisDrawing.Regen acAllViewports
End Sub

Regen! :)

Code: [Select]
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")) )

Code: [Select]
Set OBJSELSET = ThisDrawing.SelectionSets.Add("EBL")
OBJSELSET.Select acSelectionSetAll

hmmmm... probably. And I'm guessing that this creates said selection set and selects "all"

Code: [Select]
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)

Code: [Select]
ZoomExtents
Now that's a real head scratcher ;)

Code: [Select]
ThisDrawing.Application.Update
Exit_Here:
Exit Sub
End Sub

Wrap it all up and we're done.

How was that?
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 11:33:52 AM
awsome!!! you can do this!  I have got the next part for you as well
Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 11:36:22 AM
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.
Title: Re: Convert all to BYLAYER
Post by: ronjonp on February 01, 2006, 12:53:41 PM
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
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 01:23:32 PM
This is mostly where you want to be
Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 01:52:20 PM
Round 2...

Code: [Select]
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)

Code: [Select]
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

Code: [Select]
    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.

Code: [Select]
    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?

Code: [Select]
    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?

Code: [Select]
            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.
   
Code: [Select]
    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.

Code: [Select]
End Sub
This is the end of our first called sub-function (DELETELAYERS)

What follows is our second called sub-function (SETUPLAYERS)

Code: [Select]
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)

Code: [Select]
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.

Code: [Select]
'this is where we are at so far
A comment! :D

Code: [Select]
End Sub
This is the end of our third called sub-function (SETCOLORLINETYPE)

What follows is our fourth called sub-function (CHANGELAYER)

Code: [Select]
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! :)
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 02:13:49 PM
Code: [Select]
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?

Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 02:33:39 PM
Code: [Select]
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?

Code: [Select]
objLayer.Color = acByLayer
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 02:34:08 PM
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
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 02:36:46 PM
I updated this code to reflect your last post
Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 02:37:45 PM
This is everything I have so far

Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 01, 2006, 03:17:55 PM
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).
Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 03:21:34 PM
PMFJI - ??

I threw it together, and hadn't gone back to optimize it yet
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 01, 2006, 03:32:33 PM
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*
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 03:35:00 PM
By all means jump in, I could use the help
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 03:44:48 PM
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  :-)
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 03:48:35 PM
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?
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 03:51:05 PM
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?
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 01, 2006, 04:02:29 PM
<*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*>

Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 04:08:45 PM
Using my hypothetical:

Each entity would be set as such
(Entity - Color - Linetype)

Code: [Select]
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.
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 01, 2006, 04:14:15 PM
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......
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 04:16:13 PM
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.
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 04:21:32 PM
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
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 04:26:47 PM
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 :)
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 01, 2006, 05:01:43 PM
I hope you guys have Flash installed so you can see (and hear) this (http://www.careerbuilder.com/monk-e-mail/?mid=2878065). :)
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 01, 2006, 05:39:42 PM
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!
Code: [Select]
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
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 01, 2006, 08:58:53 PM
good job, I see that I have a lot to learn still
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 02, 2006, 11:15:28 AM
Code: [Select]
'requires reference to MS Scripting Runtime :?

is that why I get an error on this line when I try to run it?

Code: [Select]
Dim colLays As New Dictionary
Quote from: That nifty little error dialog
Compile error:

User-defined type not defined

A little enlightenment might be in order  :angel:
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 02, 2006, 11:24:19 AM
i'll go out on a limb here, but i think in the IDE, go to Tools->references and find the MS Scripting Runtime
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 02, 2006, 11:29:45 AM
Yep, that's it! Just make sure to add a check mark next to it once found :-)
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 02, 2006, 11:44:00 AM
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)
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 02, 2006, 11:55:45 AM
oops!

Forgot to mention that I added this towards the end:

Code: [Select]
    End If
Next
ThisDrawing.PurgeAll
End Sub
Title: Re: Convert all to BYLAYER
Post by: CmdrDuh on February 02, 2006, 11:56:41 AM
I would also add ThisDrawing.Save
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 02, 2006, 05:33:22 PM
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......
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 02, 2006, 07:12:43 PM
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.
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 02, 2006, 08:18:47 PM
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.....
Title: Re: Convert all to BYLAYER
Post by: nivuahc on February 03, 2006, 08:33:37 AM
ooooo... and MText. How would I go about changing the color of Mtext? That doesn't seem to work either  :|
Title: Re: Convert all to BYLAYER
Post by: Jeff_M on February 03, 2006, 12:01:22 PM
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.
Title: Re: Convert all to BYLAYER
Post by: T.Willey on February 03, 2006, 12:06:00 PM
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.
Code: [Select]
(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)
)