apply vba to subentities of block

[handasa]

i have a vba macro which used to apply bylayer color to the bylayer colored objects

but it didn't apply for blocks sub entities

i wish some one can modify the vba code to be applied to blocks and nested blocks

 

 

Public Sub ColorToEntity()
   'This subroutine sets each entities color from ByLayer
   'to the color of the layer it's on.
   Dim sset As AcadSelectionSet
   Set sset = ThisDrawing.SelectionSets.Add("SS1")

   ' Prompt the user to select objects
   ' and add them to the selection set.
   sset.SelectOnScreen

   
   ' Step through the selected objects and change
   ' each object's color to Green
   Dim objEntity As AcadEntity
   Dim objMS As AcadModelSpace
   Dim objPS As AcadPaperSpace
   Dim objLayers As AcadLayers
   Dim objLayer As AcadLayer
   Dim strLayer As String
   
   Set objMS = ThisDrawing.ModelSpace
   Set objPS = ThisDrawing.PaperSpace
   Set objLayers = ThisDrawing.Layers
   'process ents in modelspace
   For Each objEntity In objMS
       strLayer = objEntity.Layer
       Set objLayer = objLayers.Item(strLayer)
       objEntity.color = objLayer.color
   Next objEntity
   'process ents in paperspace
   For Each objEntity In objPS
       strLayer = objEntity.Layer
       Set objLayer = objLayers.Item(strLayer)
       objEntity.color = objLayer.color
   Next objEntity
   ' Remove the selection set at the end
   sset.Delete
End Sub