Как закрасить объект

ThisDrawing.SendCommand("-hatch.....")

Option Explicit

'based on module written by SMEL

Public Sub Hatching(ac As Object)
  Dim oEnt As AcadObject
  Dim delObjs(0) As AcadEntity
  Dim oSset As AcadSelectionSet
  Dim cmdStr As String
  Dim i
                Set oSset = GetSelection
                Set oEnt = oSset.Item(0)
                cmdStr = "_-BHATCH" & vbCr & "S" & vbCr & "(handent " & Chr(34) & oEnt.Handle & Chr(34) & ")" '& vbCr

                For i = 1 To oSset.Count - 1
                Set oEnt = oSset.Item(i)
                    cmdStr = cmdStr & vbCr & "(handent " & Chr(34) & oEnt.Handle & Chr(34) & ")" '& vbCr
                Next
                
                cmdStr = cmdStr & vbCr & vbCr & vbCr
                SendCmdEX ac, cmdStr, True
                
                cmdStr = "(princ)" & vbCr
                SendCmdEX ac, cmdStr, False

End Sub

Public Function GetSelection() As AcadSelectionSet

  On Error Resume Next

     Dim oSset As AcadSelectionSet
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add("$NewOne$")
          End With
          
oSset.SelectOnScreen

Set GetSelection = oSset
Set oSset = Nothing
End Function

Public Sub SendCmdEX(ac As Object, cmd As String, Optional ChOsmode As Boolean = False)
 If ChOsmode Then
  ac.SendCommand cmd
 Else
  Dim osmode As Integer
  osmode = CInt(GetVar(ac, "OSMODE"))
  ac.SendCommand cmd
  SetVar ac, "OSMODE", osmode
 End If
End Sub

Public Sub SetVar(ac As Object, varName As String, varValue)
ac.SetVariable varName, varValue
End Sub

Public Function GetVar(ac As Object, varName As String) As Variant
GetVar = ac.GetVariable(varName)
End Function

Sub Test()
Dim ac As Object
On Error GoTo HoustonWeHaveAProblem
Set ac = ThisDrawing
SetVar ac, "hpname", "ANSI37"
SetVar ac, "hpscale", 5#
SetVar ac, "hpang", 1.5708

Call Hatching(ac)

HoustonWeHaveAProblem:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub

Sub Example_AddHatch()
    ' This example creates an associative hatch in model space.
   
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    
    ' Define the hatch
    patternName = "SOLID"
    PatternType = acHatchPatternTypePreDefined
    bAssociativity = True
    
    ' Create the associative Hatch object in model space
    Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
    hatchObj.color = acWhite
    
    ' Create the outer boundary for the hatch (a circle)
    Dim outerLoop(0 To 0) As AcadEntity
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 3: center(1) = 3: center(2) = 0
    radius = 1
    Set outerLoop(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
    
    ' Append the outerboundary to the hatch object, and display the hatch
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Evaluate
    ThisDrawing.Regen True
End Sub