请教关于填充的问题，总是返回“填充定义边界未闭合！”
Public Function AddHatch(ByRef objList() As AcadEntity, ByVal patType As Integer, ByVal patName 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.PatternScale = 10
'添加边界
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
Private Sub CommandButton1_Click()
UserForm2.Hide
Dim p1 As Variant
p1 = ThisDrawing.Utility.GetPoint(, "输入点:") '获取点坐标
Call AddRectangle(p1, 2)
End Sub
Public Function AddRectangle(ByVal pt1 As Variant, ByVal TH As Double) As AcadLWPolyline
Dim ptArr(0 To 14) As Double
Dim objList(0) As AcadEntity
Dim objPline1 As AcadPolyline
ptArr(0) = pt1(0): ptArr(1) = pt1(1): ptArr(2) = pt1(2)
ptArr(3) = ptArr(0) + 1500: ptArr(4) = ptArr(1): ptArr(5) = ptArr(2)
ptArr(6) = ptArr(3): ptArr(7) = ptArr(4) - 1000 * TH: ptArr(8) = ptArr(2)
ptArr(9) = ptArr(0): ptArr(10) = ptArr(1) - 1000 * TH: ptArr(11) = ptArr(2)
ptArr(12) = pt1(0): ptArr(13) = pt1(1): ptArr(14) = pt1(2)
Set objPline1 = AddPline(ptArr(), 0.01)
Set objList(0) = objPline1
AddHatch objList, 0, "LINEAR", True
End Function
Public Function AddPline(ByRef ptArr() As Double, ByVal width As Double) As AcadPolyline
Dim objPline As AcadPolyline
'错误处理
If (UBound(ptArr) + 1) Mod 3 <> 0 Then
MsgBox "数组元素个数必须为3的倍数！"
Exit Function
End If
Set objPline = ThisDrawing.ModelSpace.AddPolyline(ptArr)
objPline.ConstantWidth = width
objPline.Update
Set AddPline = objPline
End Function
页:
[1]