|
|
运用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
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 |
|
置顶卡
