CAD等高线自动标高赋值VBX代码

FilterData(1) = "LWPolyline"
FilterType(2) = 0
FilterData(2) = "Polyline"
FilterType(3) = 0
FilterData(3) = "Line"
FilterType(4) = -4
Private Sub CmdH_Click()
'接受输入步长值和增量
Dim dblStart As Double, dblStep As Double
Dim dblStart0 As Double
On Error Resume Next
dblStart = 0
dblStep = 1
Next
&#= 0 Then
ThisDrawing.Utility.Prompt "已成功为等高线设置高程哈哈。" + vbCrLf
Else
ThisDrawing.Utility.Prompt "执行过程中出现错误呵呵呵。" + vbCrLf
'给3DPolyline赋高程
ReDim NPS(UBound(ent.Coordinates)) As Double
NPS = ent.Coordinates
For i = 2 To UBound(ent.Coordinates) Step 3
Dim i As Integer
For Each ent In ssetObj
Select Case TypeName(ent)
Case "IAcadLine"
'给直线的起止点赋高程
NP = ent.StartPoint
dblStart = ThisDrawing.Utility.GetReal(vbCrLf + "请输入起始高程值(0): ")
If Err.Number = -2145320928 Then Err.Clear
dblStart0 = dblStart
dblStep = ThisDrawing.Utility.GetReal("请输入增量高程值(1): ")
If Err.Number = -2145320928 Then Err.Clear
Dim index As Integer
loop1:
'接受输入起止点
dblStart = dblStart0
On Error GoTo ExitLabel
Dim Pnt1 As Variant, Pnt2 As Variant
FilterData(4) = "OR>"
Dim PntList(0 To 5) As Double
PntList(0) = Pnt1(0): PntList(1) = Pnt1(1): PntList(2) = Pnt1(2)
PntList(3) = Pnt2(0): PntList(4) = Pnt2(1): PntList(5) = Pnt2(2)
Dim 标高 As Single
Dim sset As AcadSelectionSet '定义选择集对象
Set sset = ThisDrawing.SelectionSets.Add(CStr(Timer)) '新建一个选择集
sset.SelectOnScreen '提示用户选择
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets("CONTOUR_SSET")
If ssetObj Is Nothing Then
Set ssetObj = ThisDrawing.SelectionSets.Add("CONTOUR_SSET")
标高 = sset.Item(0).Elevation
Set sset = ThisDrawing.SelectionSets.Add(CStr(Timer)) '新建一个选择集
sset.SelectOnScreen '提示用户选择
sset.Item(0).TextString = CStr(标高)
'给LWPolyline赋高程
ent.Elevation = dblStart
Case "IAcadPolyline"
'给LWPolyline赋高程
ent.Elevation = dblStart
Case Else
NPS(i) = dblStart
Next i
ent.Coordinates = NPS
End Select
ent.color = acRed
dblStart = dblStart + dblStep
ssetObj.Clear
ssetObj.SelectByPolygon acSelectionSetFence, PntList, FilterType, FilterData
'依次为选择集中每条多段线设置高程
Dim ent As Object
Dim NP As Variant
Err.Clear
End If
Dim FilterType(0 To 4) As Integer FrilterData(0 To 4) As Variant
FilterType(0) = -4
FilterData(0) = "<OR"
FilterType(1) = 0
End If
GoTo loop1
ThisDrawing.SelectionSets("CONTOUR_SSET").Delete
Exit Sub
ExitLabel:
'MsgBox Err.Description
End Sub
Private Sub cmdHTd_Click()
NP(2) = dblStart
ent.StartPoint = NP
NP = ent.EndPoint
NP(2) = dblStart
ent.EndPoint = NP
Case "IAcadLWPolyline"
End Sub
Pnt1 = ThisDrawing.Utility.GetPoint(, "请输入起点：")
Pnt2 = ThisDrawing.Utility.GetPoint(Pnt1, "请输入终点：")
'选择线段经过的多段线，构成选择集
On Error Resume Next