如何实现使用快捷提取多段线转为3dr格式？
0
7 079.04-479.02-1078.24-24.778.04-35.377.34-51.270.14-70.465.34
8 079.043.579.3413.282.4425.588.2434.592.5453.4102.1471.7109.5494.2117.74
79.04
7 079.04-479.02-1078.24-24.778.04-35.377.34-51.270.14-70.465.34
8 079.043.579.3413.282.4425.588.2434.592.5453.4102.1471.7109.5494.2117.74
79.04
7 079.04-479.02-1078.24-24.778.04-35.377.34-51.270.14-70.465.34
8 079.043.579.3413.282.4425.588.2434.592.5453.4102.1471.7109.5494.2117.74
79.04
7 00-4-.02-10-.8-24.7-1-35.3-1.7-51.2-8.9-70.4-13.7
8 003.5.313.23.425.59.234.513.553.423.171.730.594.238.7
79.04
7 00-4-.02-10-.8-24.7-1-35.3-1.7-51.2-8.9-70.4-13.7
8 003.5.313.23.425.59.234.513.553.423.171.730.594.238.7
79.04
7 00-4-.02-10-.8-24.7-1-35.3-1.7-51.2-8.9-70.4-13.7
8 003.5.313.23.425.59.234.513.553.423.171.730.594.238.7
79.04
7 00-4-.02-10-.8-24.7-1-35.3-1.7-51.2-8.9-70.4-13.7
8 003.5.313.23.425.59.234.513.553.423.171.730.594.238.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 pntUCSAs 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 于 2014-9-12 23:47 编辑
程序是用vb6.0版本为基础上编制，源代码程序在压缩包里面。
希望高手给优化一下，实现快捷的方式提取cad设计线（绿色），形成纬地3dr数据格式。
我有个想法：就是在cad环境中用鼠标框选整个图行，直接提取里面的信息（中桩号，多段线坐标（设计高程）），然后分别以中心线为分界，左右分别提取设计线设计高程，最后形成3dr数据。这个想法，我想了很长时间，不知道如何实现，希望高手们，能给解决一下，我只会vb语言，lisp 语言不懂，有懂的高手们，也可以从vba lisp语言给解决一下。
谢谢 可以短消息我。 我已经发信息给你了
我的qq78847393
你的qq好多呢？
谢谢了 你留一个电子邮箱吧 我把求助的问题 整理一下发到你邮箱
已研发成功
页:
[1]