AutoCAD VBA图案填充，包括图案填充、真彩色填充和渐变填充，代码如下。
Public Function AddHatch(ByRef objList() As AcadEntity, ByVal patType As Integer, ByVal parName As String, ByVal associativity As Boolean) As AcadHatch
On Error GoTo errHandle
Dim objHatch As AcadHatch
Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, associativity, acHatchObject)
objHatch.AppendOuterLoop (objList)
objHatch.Evaluate
ThisDrawing.Regen True
Set AddHatch = objHatch
Exit Function
errHandle:
If Err.Number = -2145386493 Then
MsgBox "填充定义边界未闭合", vbCritical
End If
Err.Clear
End Function
Public Function AddHatchGC(ByRef objList() As AcadEntity, ByVal parType As Integer, ByVal parName As String, ByVal associativity As Double, ByVal color1 As AcadAcCmColor, ByVal color2 As AcadAcCmColor) As AcadHatch
On Error GoTo errHandle
Dim objHatch As AcadHatch
Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, True, acGradientObject)
objHatch.GradientColor1 = color1
objHatch.GradientColor2 = color2
objHatch.AppendOuterLoop (objList)
objHatch.Evaluate
ThisDrawing.Regen True
Set AddHatchGC = objHatch
Exit Function
errHandle:
If Err.Number = -2145386493 Then
MsgBox "填充定义边界未闭合", vbCritical
End If
Err.Clear
End Function
Public Function AddHatchPt(ByRef ptArr() As Double, ByVal parType As Integer, ByVal patName As String, ByVal associativity As Boolean) As AcadHatch
Dim objPline As AcadLWPolyline
If (UBound(ptArr) + 1) Mod 2 Then
MsgBox "数组元素必须为偶数"
Exit Function
End If
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.Closed = True
Dim objList(0) As AcadEntity
Set objList(0) = objPline
Set AddHatchPt = AddHatch(objList, patType, patName, associativity)
End Function
Public Function AddHatchTC(ByRef objList() As AcadEntity, ByVal patName As Integer, ByVal associativity As Boolean, ByVal color As AcadAcCmColor) As AcadHatch
On Error GoTo errHandle
Dim objHatch As AcadHatch
Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, "LINEAR", True, acGradientObject)
objHatch.GradientColor1 = color
objHatch.GradientColor2 = color
objHatch.AppendOuterLoop (objList)
objHatch.Evaluate
ThisDrawing.Regen True
Set AddHatchTC = objHatch
Exit Function
errHandle:
If Err.Number = -2145386493 Then
MsgBox "填充边界闭合！", vbCritical
End If
Err.Clear
End Function
Public Function MoveEntity(ByVal objEntity As AcadEntity, ByVal x As Double, ByVal y As Double, Optional z As Double = 0)
Dim ptBase(2) As Double
Dim ptDest(2) As Double
ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
ptDest(0) = x: ptDest(1) = y: ptDest(2) = z
objEntity.Move ptBase, ptDest
End Function
Public Sub TestHatch()
Dim objList(1) As AcadEntity
Dim pt(0 To 2) As Double
Dim objArc As AcadArc
Dim objLine As AcadLine
Dim objCircle As AcadCircle
pt(0) = 100: pt(1) = 100: pt(2) = 0
Set objArc = ThisDrawing.ModelSpace.AddArc(pt, 30, 0, 2.5)
Set objLine = ThisDrawing.ModelSpace.AddLine(objArc.StartPoint, objArc.EndPoint)
Set objList(0) = objArc
Set objList(1) = objLine
AddHatch objList, 0, "ANSI31", True
Dim color As AcadAcCmColor
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
Call color.SetRGB(0, 255, 127)
Set objList(0) = objArc.Copy
MoveEntity objList(0), 0, 30
Set objList(1) = objLine.Copy
MoveEntity objList(1), 0, 30
AddHatchTC objList, 0, True, color
Dim color2 As AcadAcCmColor
Set color2 = AcadApplication.GetInterfaceObject("autocad.accmcolor.16")
color2.SetRGB 255, 0, 25
Set objList(0) = objArc.Copy
MoveEntity objList(0), 80, 30
Set objList(1) = objLine.Copy
MoveEntity objList(1), 80, 30
AddHatchTC objList, 0, True, color
AddHatchGC objList, 0, "LINEAR", True, color, color2
Dim ptArr(7) As Double
ptArr(0) = 160: ptArr(1) = 90: ptArr(2) = 200: ptArr(3) = 90
ptArr(4) = 200: ptArr(5) = 120: ptArr(6) = 160: ptArr(7) = 120
AddHatchPt ptArr, o, "ANSI31", True
End Sub
代码完。