如何实现使用快捷提取多段线转为3dr格式？

syx2014

syx2014

0
                  7      0  79.04  -4  79.02  -10  78.24  -24.7  78.04  -35.3  77.34  -51.2  70.14  -70.4  65.34  
                  8      0  79.04  3.5  79.34  13.2  82.44  25.5  88.24  34.5  92.54  53.4  102.14  71.7  109.54  94.2  117.74  

79.04
                  7      0  79.04  -4  79.02  -10  78.24  -24.7  78.04  -35.3  77.34  -51.2  70.14  -70.4  65.34  
                  8      0  79.04  3.5  79.34  13.2  82.44  25.5  88.24  34.5  92.54  53.4  102.14  71.7  109.54  94.2  117.74  

79.04
                  7      0  79.04  -4  79.02  -10  78.24  -24.7  78.04  -35.3  77.34  -51.2  70.14  -70.4  65.34  
                  8      0  79.04  3.5  79.34  13.2  82.44  25.5  88.24  34.5  92.54  53.4  102.14  71.7  109.54  94.2  117.74  

79.04
                  7      0  0  -4  -.02  -10  -.8  -24.7  -1  -35.3  -1.7  -51.2  -8.9  -70.4  -13.7  
                  8      0  0  3.5  .3  13.2  3.4  25.5  9.2  34.5  13.5  53.4  23.1  71.7  30.5  94.2  38.7  

79.04
                  7      0  0  -4  -.02  -10  -.8  -24.7  -1  -35.3  -1.7  -51.2  -8.9  -70.4  -13.7  
                  8      0  0  3.5  .3  13.2  3.4  25.5  9.2  34.5  13.5  53.4  23.1  71.7  30.5  94.2  38.7  

79.04
                  7      0  0  -4  -.02  -10  -.8  -24.7  -1  -35.3  -1.7  -51.2  -8.9  -70.4  -13.7  
                  8      0  0  3.5  .3  13.2  3.4  25.5  9.2  34.5  13.5  53.4  23.1  71.7  30.5  94.2  38.7  

79.04
                  7      0  0  -4  -.02  -10  -.8  -24.7  -1  -35.3  -1.7  -51.2  -8.9  -70.4  -13.7  
                  8      0  0  3.5  .3  13.2  3.4  25.5  9.2  34.5  13.5  53.4  23.1  71.7  30.5  94.2  38.7  

图纸中只针对绿色多段线提取，格式如上，
我编写了一个小程序，不过分几步操作，效率太低，现在想实现一站式功能，譬如直接读取dwg文件内容或鼠标框选等快捷方式，提取坐标并转化为3dr格式（纬地）

源代码如下：麻烦高手给修改 一下 谢谢
通用模块代码：
Public acadAPP As AcadApplication
Public acadDOC As AcadDocument
Public ucsOBJ As AcadUCS





Public Sub 连接CAD()
On Error Resume Next
    Set acadAPP = GetObject(, "AutoCAD.Application")
    'acadAPP.Documents.Add
    If Err Then
            Err.Clear
            Set acadAPP = CreateObject("AutoCAD.Application")
            If Err Then
                MsgBox Err.Description
                Exit Sub
            End If
        End If
        acadAPP.Visible = True
        acadAPP.WindowState = acMax
        
       AppActivate acadAPP.Caption
End Sub



各按钮代码：
Private Sub Command1_Click()
   
    Dim xAxisPnt(0 To 2) As Double  'X轴向量
    Dim yAxisPnt(0 To 2) As Double  'Y轴向量
    Dim origin(0 To 2) As Double    '原点坐标
    Dim returnObj As AcadObject
    Dim returnOb0j As AcadObject
    Dim basePnt0 As Variant
    Dim basePnt1 As Variant
    Dim returnPnt As Variant
    Dim basePnt2(0 To 2) As Double
    Dim pntWCS(0 To 2) As Double
    Dim pntUCS  As Variant
    Dim Coord_2D As Variant
On Error Resume Next
    Call 连接CAD
Repick:
    returnPnt = acadAPP.ActiveDocument.Utility.GetPoint(, "请拾取原点")
   

    acadAPP.ActiveDocument.Utility.GetEntity returnOb0j, basePnt0, "拾取中桩桩号"
    If returnOb0j.ObjectName = "AcDbText" Then
        Dim str0GC As Double
                str0GC = CDbl(returnOb0j.TextString)
        returnOb0j.Color = acBlue
    End If
   
    acadAPP.ActiveDocument.Utility.GetEntity returnObj, basePnt1, "拾取中桩高程"
    If returnObj.ObjectName = "AcDbText" Then
        Dim strGC As Double
        strGC = CDbl(returnObj.TextString)
        returnObj.Color = acRed
    End If



    origin(0) = returnPnt(0): origin(1) = returnPnt(1): origin(2) = 0
    xAxisPnt(0) = origin(0) + 1: xAxisPnt(1) = origin(1): xAxisPnt(2) = 0
    yAxisPnt(0) = origin(0): yAxisPnt(1) = origin(1) + 1: yAxisPnt(2) = 0

    Set ucsOBJ = acadAPP.ActiveDocument.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "NewUcs1")
    acadAPP.ActiveDocument.ActiveUCS = ucsOBJ

    acadAPP.ActiveDocument.Utility.GetEntity returnObj, basePnt1, "拾取多段线"
    Dim pLine As AcadLWPolyline
   
    If returnObj.ObjectName = "AcDbPolyline" Then
        Set pLine = returnObj

        Dim i As Integer
        Dim ip As Integer
        Dim zi As Integer
        Dim yi As Integer
        
        
        Open "zuobiao.txt" For Append As #1
            Print #1, str0GC '; " "; strGC
            ip = (UBound(pLine.Coordinates) + 1) / 2
            ReDim Index(ip, 2) As Double
  '---------------------------------------------------------------------------------------------------------建立用户坐标系
        For i = 0 To (UBound(pLine.Coordinates) + 1) / 2 - 1
            Coord_2D = pLine.Coordinate(i)
            pntWCS(0) = CDbl(Coord_2D(0)): pntWCS(1) = CDbl(Coord_2D(1)): pntWCS(2) = 0
            pntUCS = acadAPP.ActiveDocument.Utility.TranslateCoordinates(pntWCS, acWorld, acUCS, False)
            'strb = Format(pntUCS(0), "#0.000") & " " & Format(pntUCS(1), "#0.000")
            Index(i, 1) = Format(pntUCS(0), "#0.0000")
            Index(i, 2) = Format(pntUCS(1), "#0.0000")
           ' Print #1, Format(pntUCS(0), "#0.000") & " " & Format(pntUCS(1), "#0.000")
        Next i
        '------------------------------------------------------------------------------------------------获取在右侧数据对个数
       zs = 0
       ys = 0
        For i = 0 To (UBound(pLine.Coordinates) + 1) / 2 - 1
   
     If Index(i, 1) <= 0 Then zs = zs + 1
     Next i
          For i = 0 To (UBound(pLine.Coordinates) + 1) / 2 - 1
     If Index(i, 1) >= 0 Then ys = ys + 1

        Next i
'----------------------------------------------------------------------------------------------------------------读写左侧数据对并排列
        Print #1, "                  "; zs & "      ";
          For i = zs - 1 To 0 Step -1
         
          Print #1, Index(i, 1) & "  "; Index(i, 2) + strGC & "  ";
           Next i
'-------------------------------------------------------------------------------------------------------------读取右侧数据对并排列
          Print #1,
            Print #1, "                  "; ys & "      ";
          For i = 0 To (UBound(pLine.Coordinates) + 1) / 2 - 1
         
          If Index(i, 1) >= 0 Then Print #1, Index(i, 1) & "  "; Index(i, 2) + strGC & "  ";
          Next i
         
        Print #1,
'------------------------------------------------------------------------------------------------------空一行
        For i = 1 To 1
        Print #1,
        Next i
              Debug.Print acWorld
        pLine.Color = acRed
        pLine.Update
        Close #1
        
    End If
    If Err Then
     Exit Sub
    End If
    GoTo Repick
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub m0_Click(Index As Integer)
    MsgBox "操作步骤：1、拾取中桩点——拾取中桩桩号--拾取中桩高程——拾取多段线" & vbCrLf _
           & "2、重复以上操作或按esc键退出 "
End Sub

syx2014

程序是用vb6.0版本为基础上编制，源代码程序在压缩包里面。

希望高手给优化一下，实现快捷的方式提取cad设计线（绿色），形成纬地3dr数据格式。
我有个想法：就是在cad环境中用鼠标框选整个图行，直接提取里面的信息（中桩号，多段线坐标（设计高程）），然后分别以中心线为分界，左右分别提取设计线设计高程，最后形成3dr数据。这个想法，我想了很长时间，不知道如何实现，希望高手们，能给解决一下，我只会vb语言，lisp 语言不懂，有懂的高手们，也可以从vba lisp语言给解决一下。
谢谢

wangshuping42

可以短消息我。

syx2014

我已经发信息给你了
我的qq78847393
你的qq好多呢？
谢谢了

syx2014

你留一个电子邮箱吧 我把求助的问题 整理一下发到你邮箱

syx2014

已研发成功