请教关于填充的问题，总是返回“填充定义边界未闭合！”

☆一笑而过☆

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