CAD等高线批量赋值

刚在网上翻到一段VBA代码据说是可以指量赋值，哪位大大看看能否把它转为cad的外挂程序，谢谢
Private Sub CmdH_Click()
'接受输入步长值和增量
Dim dblStart As Double, dblStep As Double
Dim dblStart0 As Double
On Error Resume Next
dblStart = 0
dblStep = 1
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
Pnt1 = ThisDrawing.Utility.GetPoint(, "请输入起点：")
Pnt2 = ThisDrawing.Utility.GetPoint(Pnt1, "请输入终点：")
'选择线段经过的多段线，构成选择集
On Error Resume Next
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets("CONTOUR_SSET")
If ssetObj Is Nothing Then
Set ssetObj = ThisDrawing.SelectionSets.Add("CONTOUR_SSET")
Err.Clear
End If
Dim FilterType(0 To 4) As Integer, FilterData(0 To 4) As Variant
FilterType(0) = -4
FilterData(0) = "<OR"
FilterType(1) = 0
FilterData(1) = "LWPolyline"
FilterType(2) = 0
FilterData(2) = "Polyline"
FilterType(3) = 0
FilterData(3) = "Line"
FilterType(4) = -4
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)
ssetObj.Clear
ssetObj.SelectByPolygon acSelectionSetFence, PntList, FilterType, FilterData
'依次为选择集中每条多段线设置高程
Dim ent As Object
Dim NP As Variant
Dim i As Integer
For Each ent In ssetObj
Select Case TypeName(ent)
Case "IAcadLine"
'给直线的起止点赋高程
NP = ent.StartPoint
NP(2) = dblStart
ent.StartPoint = NP
NP = ent.EndPoint
NP(2) = dblStart
ent.EndPoint = NP
Case "IAcadLWPolyline"
'给LWPolyline赋高程
ent.Elevation = dblStart
Case "IAcadPolyline"
'给LWPolyline赋高程
ent.Elevation = dblStart
Case Else
'给3DPolyline赋高程
ReDim NPS(UBound(ent.Coordinates)) As Double
NPS = ent.Coordinates
For i = 2 To UBound(ent.Coordinates) Step 3
NPS(i) = dblStart
Next i
ent.Coordinates = NPS
End Select
ent.color = acRed
dblStart = dblStart + dblStep
Next
'输出执行结果汇报
If Err.Number = 0 Then
ThisDrawing.Utility.Prompt "已成功的为等高线设置高程。

" + vbCrLf Else
ThisDrawing.Utility.Prompt "执行过程中出现错误。

" + vbCrLf End If
GoTo loop1
ThisDrawing.SelectionSets("CONTOUR_SSET").Delete
Exit Sub
ExitLabel:
'MsgBox Err.Description
End Sub
Private Sub cmdHTd_Click()
Dim 标高As Single
Dim sset As AcadSelectionSet '定义选择集对象
Set sset = ThisDrawing.SelectionSets.Add(CStr(Timer)) '新建一个选择集sset.SelectOnScreen '提示用户选择
标高= sset.Item(0).Elevation
Set sset = ThisDrawing.SelectionSets.Add(CStr(Timer)) '新建一个选择集sset.SelectOnScreen '提示用户选择
sset.Item(0).TextString = CStr(标高)
End Sub。