公式：Hi=H1+Si/S*(H2-H1)

思路：

1、选择线LwpObj，新建3DPolyline(层颜色为绿色)，将3DPolyline设为当前层，在此层中加入LwpObj的结点编号。

2、选择起点：选择结点编号，输入起点高程值，得到起点的三维坐标

3、选择终点：选择终点编号，输入终点高程值，得到终点的三维坐标

4、使用LwpObj的坐标与起点和终点坐标做比较，如果与起点坐标相等，则得到起点位置StaVer；同理得到终点位置EndVer。再根据staVer和endVer得到一组坐标，绘制tmpLwp线，得S。

5、通过tmpLwp可求得Si数组，得出Si后即可通过篇头给出的公式得到Hi数组

6、通过二维坐标转Z0三维坐标函数得到一组Z值为0的三维坐标Pt3D

7、通过Hi数组，专门给Pt3D赋Z值

8、通过得到的三维坐标组Pt3D即可在3DPolyline层中绘出我们想要的三维多段线。

 

新建一窗体(Name:frmMain)

界面如图：

 

再新建两个模块

模块1：

Public Declare Function GetCursor Lib "user32" () As Long
Public Const VK_ESCAPE = &H1B      ' 代表Esc键
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

' 功能：判断用户是否按下某一个键
Public Function CheckKey(lngKey As Long) As Boolean
  If GetAsyncKeyState(lngKey) Then
    CheckKey = True
  Else
    CheckKey = False
  End If
End Function

Sub checktime(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systifrmmain As Long)
    If GetCursor() <> frmMain.sb And frmMain.yc = 1 Then frmMain.yc = 3
    If frmMain.yc = 3 Then '检测鼠标已移出窗体，开始左移进窗体
       If frmMain.Left <= frmMain.Image1.Width - frmMain.Width Then
          frmMain.Left = frmMain.Image1.Width - frmMain.Width
          frmMain.Image1.Visible = True
          frmMain.yc = 0
       Else
          frmMain.Move frmMain.Left - 10, frmMain.Top, frmMain.Width, frmMain.Height
       End If
    End If
    If frmMain.yc = 4 Then '检测鼠标已触及彩虹色条，准备右移出窗体
       If frmMain.Left >= 0 Then
          frmMain.Left = 0
          frmMain.yc = 1
       Else
          frmMain.Move frmMain.Left + 10, frmMain.Top, frmMain.Width, frmMain.Height
       End If
    End If
    If frmMain.Image1.Top <= -180 Then
       frmMain.Image1.Top = 0
    End If
    frmMain.Image1.Top = frmMain.Image1.Top - 2
End Sub

'选择LWPL，并给节点编号
Public Sub SelLwp()
On Error Resume Next
 
'******************************************************************************
'选择多段线
  Dim basePt As Variant

reSel:
  ThisDrawing.Utility.GetEntity LwpObj, basePt, vbCrLf & "请选择母线："
 
    ' 处理按下Esc键的错误
    If LwpObj Is Nothing Then
        If CheckKey(VK_ESCAPE) = True Then
            Exit Sub
        Else
            GoTo reSel
        End If
    End If
   
    ' 处理未选择到实体的错误
    If Err <> 0 Then
        Err.Clear
        GoTo reSel
    End If

'选择多段线结束
'******************************************************************************

'******************************************************************************
'为多段线每个结点加上标号

'加入一个名为3DPolyline的层
  Dim newLayer As AcadLayer
 
  '定义绿色
  Set corGreen = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
  Call corGreen.SetRGB(0, 255, 0)
 
  Set newLayer = ThisDrawing.Layers.Add("3DPolyline")
  newLayer.TrueColor = corGreen
  ThisDrawing.ActiveLayer = newLayer
 
  Dim CorLwp As Variant
      CorLwp = LwpObj.Coordinates
  Dim nVer As Integer
      nVer = (UBound(CorLwp) + 1) / 2
     
  Dim i As Integer
  Dim VerNum As Variant
  Dim insertPt(2) As Double
  Dim VerNumTxt As AcadText
  For i = 0 To nVer - 1
    VerNum = LwpObj.Coordinate(i)
    insertPt(0) = VerNum(0): insertPt(1) = VerNum(1): insertPt(2) = 0
    Set VerNumTxt = ThisDrawing.ModelSpace.AddText(Str(i), insertPt, 2.4)
  Next i
 
  ThisDrawing.Application.Update
'******************************************************************************

End Sub

'选择起点
Public Sub SelStartPt()
On Error Resume Next
'******************************************************************************
'选择起点文字
  Dim PtTxt As AcadText
  Dim basePt As Variant

reSel:
  ThisDrawing.Utility.GetEntity PtTxt, basePt, vbCrLf & "请选择起点："
 
    ' 处理按下Esc键的错误
    If PtTxt Is Nothing Then
        If CheckKey(VK_ESCAPE) = True Then
            Exit Sub
        Else
            GoTo reSel
        End If
    End If
   
    ' 处理未选择到实体的错误
    If Err <> 0 Then
        Err.Clear
        GoTo reSel
    End If

'选择起点文字结束
'******************************************************************************
  Dim PtVar As Variant
  PtVar = TxtInsertPt(PtTxt, StartPt())
  Dim H As String
  If VarType(EndPt(2)) <> vbEmpty Then
    H = InputBox("请输入起点高程值：", "输入高程值", EndPt(2))
  Else
    H = InputBox("请输入起点高程值：", "输入高程值")
  End If
  StartPt(0) = Format(StartPt(0), "0.0000")
  StartPt(1) = Format(StartPt(1), "0.0000")
  StartPt(2) = Format(Val(H), "0.0000")
 
End Sub

'选择起点
Public Sub SelEndPt()
On Error Resume Next
'******************************************************************************
'选择起点文字
  Dim PtTxt As AcadText
  Dim basePt As Variant

reSel:
  ThisDrawing.Utility.GetEntity PtTxt, basePt, vbCrLf & "请选择起点："
 
    ' 处理按下Esc键的错误
    If PtTxt Is Nothing Then
        If CheckKey(VK_ESCAPE) = True Then
            Exit Sub
        Else
            GoTo reSel
        End If
    End If
   
    ' 处理未选择到实体的错误
    If Err <> 0 Then
        Err.Clear
        GoTo reSel
    End If

'选择起点文字结束
'******************************************************************************
  Dim PtVar As Variant
  PtVar = TxtInsertPt(PtTxt, EndPt())
  Dim H As String
  H = InputBox("请输入终点高程值：", "输入高程值")
  EndPt(0) = Format(EndPt(0), "0.0000")
  EndPt(1) = Format(EndPt(1), "0.0000")
  EndPt(2) = Format(Val(H), "0.0000")
 
End Sub

'得起点和终点间的距离
'根据选择的线的结点坐标与起点和终点坐标进行判断，得一组点，然后根据这组点生产
'一条临时线，主要目的是得到S
Public Sub ReDraw3dLwp()
   
  '一定要先执行第一步
  If LwpObj Is Nothing Then
    MsgBox "请重新选择线", vbCritical, "未执行第一步"
    Exit Sub
  End If
 
  Dim CorLwp As Variant
      CorLwp = LwpObj.Coordinates
  Dim n As Integer
      n = UBound(CorLwp)
  Dim i As Integer  'LwpObj(总线)结点的循环
  Dim tmpPt() As Double
  Dim staVer As Integer
  Dim endVer As Integer
 
  For i = 0 To n
    '得起点位置
    If Format(CorLwp(i), "0.0000") = StartPt(0) And Format(CorLwp(i + 1), "0.0000") = StartPt(1) Then staVer = i
   
    '得终点位置
    If Format(CorLwp(i), "0.0000") = EndPt(0) And Format(CorLwp(i + 1), "0.0000") = EndPt(1) Then
       endVer = i + 1
       Exit For
    End If
  Next i
   
  '根据得到的起点和终点得一组点
  ReDim tmpPt(0 To endVer - staVer)
  Dim j As Integer
  j = 0
  For i = staVer To endVer
    tmpPt(j) = CorLwp(i)
    j = j + 1
  Next i

  '绘制tmpLwp
  Set tmpLwp = ThisDrawing.ModelSpace.AddLightWeightPolyline(tmpPt)
  tmpLwp.TrueColor = corGreen
  ThisDrawing.Regen acActiveViewport  '刷新
 
  '得到总长度
  S = tmpLwp.length
 
'得到Si
  Call GetSi(tmpLwp, Si())
  Dim m As Integer
  m = UBound(Si())
 
'通过Si得Hi
  ReDim Preserve Hi(0 To m)
  Dim k As Integer
  For k = 0 To m
    Hi(k) = StartPt(2) + Si(k) / S * (EndPt(2) - StartPt(2))
  Next k

'转三维点

  '定义线实体坐标集
  Dim CorLwp3D As Variant
  CorLwp3D = tmpLwp.Coordinates
  
  '坐标个数，这个坐标是二维的
  Dim k3d As Integer
  k3d = UBound(CorLwp3D) + 1
  '重新定义三维坐标个数
  Dim c3d As Integer
  c3d = k3d * 3 / 2 - 1
 
  Dim Pt3D() As Double
  ReDim Pt3D(0 To c3d) As Double
 
  '二维坐标转换成三位坐标，先不加入Z值
  '例如：(12.34,35.67)转换成(12.34,35.67,0)
  Dim g As Integer, v As Integer
  For g = 0 To k3d - 1
    v = g \ 2
    Pt3D(g + v) = CorLwp3D(g)
  Next g
 
  '加入Z值
  Dim n3d As Integer
  Dim m3d As Integer
  m3d = 5
  '首末点的Z值
  Pt3D(2) = StartPt(2): Pt3D(c3d) = EndPt(2)
  For n3d = 0 To m
    Pt3D(m3d) = Hi(n3d)
    m3d = m3d + 3
  Next n3d
 
  Set Lwp3D = ThisDrawing.ModelSpace.Add3DPoly(Pt3D)
  Lwp3D.TrueColor = corGreen
  tmpLwp.Delete  '删除临时线
  ThisDrawing.Application.Update  '刷新
 
End Sub

'得lwp每一段线的长度
Public Sub GetSi(ByVal pLwpobj As AcadLWPolyline, length() As Double)
Dim numVer As Integer
numVer = (UBound(pLwpobj.Coordinates) + 1) / 2
ReDim length(0 To numVer - 3)

Dim tmpLwpVerNum As Integer
tmpLwpVerNum = UBound(pLwpobj.Coordinates)

Dim m As Integer
Dim n As Integer
Dim k As Integer
    k = 0
Dim tmpPtSi() As Double
Dim corLwpSi As Variant
corLwpSi = pLwpobj.Coordinates
Dim tmpLwpSi As AcadLWPolyline

For m = 0 To tmpLwpVerNum - 4 Step 2
  For n = 0 To m + 3
    ReDim Preserve tmpPtSi(0 To m + 3)
    tmpPtSi(n) = corLwpSi(n)
  Next n
  Set tmpLwpSi = ThisDrawing.ModelSpace.AddLightWeightPolyline(tmpPtSi)
  length(k) = tmpLwpSi.length
  k = k + 1
  tmpLwpSi.Delete
Next m

End Sub

'选择文字插入点的函数
Public Function TxtInsertPt(ByVal Txt As AcadText, Pt() As Double) As Variant
    Dim insertPt As Variant
    insertPt = Txt.InsertionPoint
    Pt(0) = insertPt(0): Pt(1) = insertPt(1)
End Function

'删除结点标注
Public Sub DelVerTag()
  Dim VerSel As AcadSelectionSet
  Set VerSel = CreateSelectionSet
 
  Dim VerType As Variant
  Dim VerData As Variant
  BuildFilter VerType, VerData, 0, "Text", 8, "3DPolyline"
 
  VerSel.SelectOnScreen VerType, VerData
 
  Dim VerObj As AcadText
  For Each VerObj In VerSel
    VerObj.Delete
  Next
End Sub

'创建过滤器的函数
Public Sub BuildFilter(TypeArray, DataArray, ParamArray gCodes())
    Dim fType() As Integer, fData()
    Dim index As Long, i As Long
   
    index = LBound(gCodes) - 1
    For i = LBound(gCodes) To UBound(gCodes) Step 2
        index = index + 1
        ReDim Preserve fType(0 To index)
        ReDim Preserve fData(0 To index)
        fType(index) = CInt(gCodes(i))
        fData(index) = gCodes(i + 1)
    Next
    TypeArray = fType: DataArray = fData
   
End Sub

'创建空间选择集的函数
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet

    Dim ss As AcadSelectionSet
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    ss.Clear
    Set CreateSelectionSet = ss

End Function

 

模块：mdlPubVariable

Option Explicit

Public StartPt(2) As Double
'Public StartH As Double
'Public EndH As Double
Public EndPt(2) As Double
Public S As Double                '选择起点、终点间的长度
Public LwpObj As AcadLWPolyline   '要为哪一条线复高程值
Public tmpLwp As AcadLWPolyline   '定义临时画的线，为了求S和Si
Public Si() As Double             'tmpLwp每一个结点到第一个结点的距离
Public Hi() As Double             '每一节线的高程差值
Public corGreen As AcadAcCmColor  '定义绿色
Public Lwp3D As Acad3DPolyline    '加入高程值的三维线