Setting Entities in all blocks to layer 0, ByLayer...etc..

I'm looking to come up with a VBA routine that redefines all the entities in
all block definitions to layer 0, byLayer, etc. I've come up with something
that mostly works, however when i go to purge out the layers that were
previously used in the blocks, some of them can't be purged, even though as
far as i can tell they're not used anywhere else in the drawing.

Now, when i use the layer delete express tool to delete those layers, it
works, however in the console it mentions that it's deleting the layers from
blocks who've supposedly everything had everything in them set to layer 0.
Is there some other step i'm missing here in order for this to work?

-Chris

---------------------------

Public Sub cleanblocks()

Dim objBlock As AcadBlock
Dim objEnt As AcadEntity

'For every block definition in drawing
For Each objBlock In ThisDrawing.Blocks

'Make sure the block def isn't an xref or layout
If (objBlock.IsLayout = False) And (objBlock.IsXRef = False) Then

'For every entity in block defintion
For Each objEnt In objBlock

'Set all entities in block defintion to 0, ByLayer
objEnt.color = acByLayer
objEnt.Layer = "0"
objEnt.Linetype = "ByLayer"
objEnt.Lineweight = acLnWtByLayer
objEnt.Update

Next objEnt

End If

Next objBlock

'Regenerate The Drawing
ThisDrawing.Regen acAllViewports

End Sub

 

have you checked for seqends?
also layers frozen in vports???
references in dictionaries, extension dictionaries, xdata ???

Option Explicit
Public Sub testSeq()
Dim colRtn As Collection
Set colRtn = GetSeqEnds(ThisDrawing)

End Sub

Public Function GetSeqEnds(oDoc As AcadDocument) As Collection
Dim oEnt As AcadEntity
Dim oSeq As AcadEntity
Dim colRtn As Collection
Set colRtn = New Collection
Dim lIdx As Long
Dim sRpt As String

For Each oEnt In oDoc.ModelSpace
'Debug.Print "Objectname: " & oEnt.ObjectName
Set oSeq = GetSeqEnd(oEnt)
If Not oSeq Is Nothing Then
colRtn.Add oSeq
End If
Next oEnt
For Each oEnt In oDoc.PaperSpace
'Debug.Print "Objectname: " & oEnt.ObjectName
Set oSeq = GetSeqEnd(oEnt)
If Not oSeq Is Nothing Then
colRtn.Add oSeq
End If
Next oEnt

If colRtn.Count > 0 Then
For lIdx = 1 To colRtn.Count
'Debug.Print colRtn(lIdx).Layer
sRpt = sRpt & colRtn(lIdx).Layer & vbCrLf
Next lIdx
MsgBox "Found seqends on following layers" & vbCrLf & sRpt
Else
MsgBox "No seqends found"
End If '
Set GetSeqEnds = colRtn

End Function

'this function posted here in past
'unfortunately I didn't save the op's name
'very bad form....:-(
'if the original author(s) would please stand up....I'd love to add the
proper credits to this code
'(the names Wayne Ivory, Ed Jobe, and Mike Tuersley come to mind...but my
memory is failing fast...)

Public Function GetSeqEnd(objEntity As AcadEntity) As AcadEntity
Dim objSeqEnd As AcadEntity
Dim oDoc As AcadDocument
Set oDoc = objEntity.Document
Dim strIHex As String
Dim strHandle As String
Dim strLeftHex As String
Dim strOwner As String
On Error GoTo Err_Control
strHandle = objEntity.Handle
'Debug.Print "strHandle: " & strHandle
'all i did was change Left to Left$ and Right to Right$
strLeftHex = Left$(strHandle, Len(strHandle) - 2)
strIHex = "&H" & Right$(objEntity.Handle, 2)
Do
'changed strIHex = strIHex + 1 to strIHex = CStr(CInt(strIHex) + 1)
'just cause, although vb converts types on the fly it just seemed dirty to
do arithmetic on strings
strIHex = CStr(CInt(strIHex) + 1)
Set objSeqEnd = _
oDoc.HandleToObject(strLeftHex & Hex(strIHex))
strOwner = objSeqEnd.OwnerID
Debug.Print "Owner: " & strOwner
If objSeqEnd.ObjectName = "AcDbSequenceEnd" Then
Set GetSeqEnd = objSeqEnd
Exit Do
End If
'Keep the loop from exceeding the reference members
Loop Until strOwner <> objEntity.ObjectID
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case -2145386484
'Not a valid handle
'So no SeqEnd entity, Exit
Err.Clear
Resume Exit_Here
Case Else
'something else is going on here because if I uncomment this I get "Type
Mismatch" err.
'havent' found where that error is occuring...
'MsgBox Err.Description
Err.Clear
Resume Exit_Here
End Select
End Function

 

Word of caution, you make wan to include some checking for the layer the
block resides on. If it is on a locked layer, your code will error out.
Dan