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