用Vlax、Curve类离散地形等高线为文字为什么有时会自动退出ACAD

xiongchen

运用Vlax、Curve类 写了一个离散等高线为文字的函数，但性能不稳定，有时多选几条等高线后会出现参数过多的提示或自动退出ACAD，请大侠帮忙看看问题何在？拜托！

Sub dgx_text()
    '定义选择集
    Dim SsetObj As AcadSelectionSet
    Dim FilterType(0 To 1) As Integer
    Dim FilterData(0 To 1) As Variant
   
    '定义循环变量
    Dim N As Long
    Dim I As Long, J As Long, K As Long, II As Long, JJ As Long
   
    '定义文字变量
    Dim High As Double
    Dim XText As AcadText
    Dim insPt(0 To 2) As Double
   
     '定义引用曲线类模块
     Dim ObjCurve As Curve
     Set ObjCurve = New Curve
     '获取曲线变量
     Dim sPt As Variant
     Dim ePt As Variant
     Dim Pt As Variant
     Dim ENT As AcadEntity
   
    '配置参数
    Dim Dist As Double
    Dim Htext As Double
    Dim Color1 As Integer
    Dim Color2 As Integer
    Dim Color3 As Integer
   
    'Op.Show
    'Dist = Val(Op.TextBox1.Text)
    'Htext = Val(Op.TextBox2.Text)
    'Color1 = Val(Op.TextBox3.Text)
    'Color2 = Val(Op.TextBox4.Text)
    Dist = 5
    Htext = 1
    Color1 = 3
    Color2 = 1
   
   
   
    '选择曲线
    On Error Resume Next
    Set SsetObj = ThisDrawing.SelectionSets.Add("b")
    If Err Then
        Err.Clear
        Set SsetObj = ThisDrawing.SelectionSets.Item("b")
    End If
    SsetObj.Clear
    SsetObj.SelectOnScreen
    N = SsetObj.Count
   
   
    Dim Length As Double
    Dim mLength As Double
    '循环选择对象
    For I = 0 To N - 1
        If SsetObj.Item(I).ObjectName = "AcDbLine" Or _
           SsetObj.Item(I).ObjectName = "AcDbCircle" Or _
           SsetObj.Item(I).ObjectName = "AcDbArc" Or _
           SsetObj.Item(I).ObjectName = "AcDbSpline" Or _
           SsetObj.Item(I).ObjectName = "AcDb3dPolyline" Or _
           SsetObj.Item(I).ObjectName = "AcDbPolyline" Or _
           SsetObj.Item(I).ObjectName = "AcDb2dPolyline" Or _
           SsetObj.Item(I).ObjectName = "AcDbEllipse" Or _
           SsetObj.Item(I).ObjectName = "AcDbLeader" Then
          
            If SsetObj.Item(I).ObjectName = "AcDbLine" Then
                High = SsetObj.Item(I).StartPoint()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbCircle" Then
                High = SsetObj.Item(I).CenterPoint()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbArc" Then
                High = SsetObj.Item(I).CenterPoint()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbSpline" Then
                High = SsetObj.Item(I).ControlPoints(0)(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDb3dPolyline" Then
                High = SsetObj.Item(I).Coordinates()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbPolyline" Then
                High = SsetObj.Item(I).Elevation
            ElseIf SsetObj.Item(I).ObjectName = "AcDb2dPolyline" Then
                High = SsetObj.Item(I).Elevation
            End If
            Set ENT = SsetObj.Item(I)
            '亮显要处理的曲线以方便输入曲线代表高程
            Color3 = SsetObj.Item(I).color
            SsetObj.Item(I).color = Color1
            SsetObj.Item(I).Update
            ENT.Highlight True
            If High <= 0 Then
                High = ThisDrawing.Utility.GetReal("输入等高线高程：")
            End If
            If High > 0 Then
                Set ObjCurve.Entity = ENT
                sPt = ObjCurve.StartPoint
                ePt = ObjCurve.EndPoint
                Length = ObjCurve.Length
                ThisDrawing.ModelSpace.AddText Trim(Str(High)), sPt, Htext
                ThisDrawing.ModelSpace.AddText Trim(Str(High)), ePt, Htext
                If Length > Dist Then
                    mLength = 0
                    Do
                      mLength = mLength + Dist
                      If mLength < Length Then
                        Pt = ObjCurve.GetPointAtDistance(mLength)
                        ThisDrawing.ModelSpace.AddText Trim(Str(High)), Pt, Htext
                      Else
                        Exit Do
                      End If
                    Loop
                End If
                ENT.Highlight False
                SsetObj.Item(I).color = Color2
                High = 0
            Else
                SsetObj.Item(I).color = Color3
            End If
        End If
    Next I
    SsetObj.Clear
End Sub