Change all entity's colors using VBA

[Anonymous]

Hi,

I need to:

• change the color (think that "truecolor") of all AcadText entities in AutoCAD (v. 2007) with VBA.
• place an entity to a other layer.

Any solutions

Thanks in advance.

[Ed.Jobe · Accepted solution]

This sub does something similar. You can modify it to suit you.

Public Sub ColorToByLayer()
    'This subroutine sets each entity's color from
    'a specific color to ByLayer and moves it to
    'a layer with the name of the former color.

    Dim objEntity As AcadEntity
    Dim objMS As AcadModelSpace
    Dim objPS As AcadBlock
    Dim objLayers As AcadLayers
    Dim objLayer As AcadLayer
    Dim objLayout As AcadLayout
    Dim cnt As Integer
    Dim strLayer As String

    Set objLayers = ThisDrawing.Layers
    cnt = 0

    For Each objLayout In ThisDrawing.Layouts
        'process ents in modelspace
        If objLayout.ModelType = True Then
            Set objMS = ThisDrawing.ModelSpace
            For Each objEntity In objMS
                If Not objEntity.color = acByLayer Then
                    strLayer = "CBL_" & objEntity.color
                    Set objLayer = objLayers.Add(strLayer)
                    objLayer.color = objEntity.color
                    objEntity.Layer = strLayer
                    objEntity.color = acByLayer
                    cnt = cnt + 1
                Else

                End If
            Next objEntity
        Else
            'process ents in paperspace
            Set objPS = objLayout.Block
            For Each objEntity In objPS
                If Not objEntity.color = acByLayer Then
                    strLayer = "CBL_" & objEntity.color
                    Set objLayer = objLayers.Add(strLayer)
                    objLayer.color = objEntity.color
                    objEntity.Layer = strLayer
                    objEntity.color = acByLayer
                    cnt = cnt + 1
                Else

                End If
            Next objEntity
        End If
    Next objLayout

    If cnt > 0 Then
        MsgBox cnt & " items were changed to color ByLayer.", vbInformation, "Change Color to ByLayer"
    Else
        'Everything is ok, minimize user interaction.
        ThisDrawing.Utility.Prompt "Color ByLayer check: OK" & vbCrLf & "Command: "
    End If

End Sub

[Anonymous]

Thank you, for the Code.

[santosh.loka]

if possible help me with drawing and code..i dont know where to change in code iam a biginner..its directly jumping not reading all the code..wher i need to modify?

i didnt get any error as well no modification in my drawing

[Ed.Jobe]

You don't provide enough detail in your explanation for me to help you. You could at least post a sample dwg you're having an issue with.