主要应用于水渠与道路方面的横断面数据提取，现为生成格式为纬地与重庆测绘院的断面格式。其实格式可以自己设定，需要帮助联系QQ：365149174. 具体请各自测试。。。
Public Sub numssg1ok() ‘生成中桩水平单及横断面数据
Dim text As AcadText, text1 As AcadText, text2 As AcadText
Dim object As AcadEntity
Dim str1 As String, str2 As String
Dim fpath As String, filepath As String
Dim selpoint As AcadSelecti**et, selp As AcadSelecti**et
Dim obje As AcadEntity
Dim point As Variant, point1 As Variant
Dim lin As AcadLine
Dim dis As Double
Dim hi As Double
Dim his As Double
Dim p(0 To 2) As Double, p1(0 To 2) As Double
Dim fipath As String
Dim ttstr As String
Dim i As Double
Dim fipatha1 As String
Dim ttstra1 As String
On Error Resume Next
Dim num As String
Dim filepath1 As String
fpath = “F:\纵断面.txt”
filepath1 = “F:\绘图横断面.txt”
fipath = “F:\纬地设计方横断面.txt”
fipatha1 = “F:\横断面原始数据.txt”
Open fpath For Append As #2
Open filepath1 For Append As #1
Open fipath For Append As #3
Open fipatha1 For Append As #4
100:
i = 0
Err.Number = 0
ThisDrawing.Utility.GetEntity object, selset**creen, “请选择中桩里程:”
If Err.Number <> 0 Then GoTo 200
Set text = object
str1 = text.TextString
Print #1, str1
Print #1, “Z”
Err.Number = 0
ThisDrawing.Utility.GetEntity object, selset**creen, “请选择对应中桩高程:”
‘If Err.Number <> 0 Then GoTo 200
Set text1 = object
str2 = text1.TextString
point = text1.InsertionPoint
p(0) = point(0)
p(1) = point(1)
p(2) = 0
ttstr = str1 & vbCrLf
ttstra1 = str1 + “/” + str2
Err.Number = 0
Set selpoint = ThisDrawing.Selecti**ets.Item(“选择文本对象”)
If Err.Number <> 0 Then ‘如果“选择文本对象”选项已经存在，则删除它
Err.Clear
Set selpoint = ThisDrawing.Selecti**ets.Add(“选择文本对象”)
End If
selpoint.Clear
selpoint.Select**creen
If Err.Number <> 0 Then ‘如果选择点错误，重新再选
Err.Clear
GoTo 200
End If
For Each obje In selpoint
If obje.ObjectName = “AcDbText” Then
Set text2 = obje
i = i + 1
point1 = text2.InsertionPoint
p1(0) = point1(0)
p1(1) = point1(1)
p1(2) = 0
Set lin = ThisDrawing.ModelSpace.AddLine(p, p1)
dis = lin.Length
lin.Delete
hi = Val(text2.TextString) – Val(text1.TextString)
his = Val(text2.TextString)
Print #1, Format(dis, “0.0”) + “,” + Format(hi, “0.00”)
If i = 1 Then ttstr = ttstr + Format(dis, “0.0”) + “/” + Format(hi, “0.00”)
If i <> 1 Then ttstr = ttstr + “、” + Format(dis, “0.0”) + “/” + Format(hi, “0.00”)
If i = 1 Then ttstra1 = Format(hi, “0.00”) + “/” + Format(dis, “0.0”) + “,” + ttstra1
If i <> 1 Then ttstra1 = Format(hi, “0.00”) + “/” + Format(dis, “0.0”) + “、” + ttstra1
End If
Next obje
i = 0
Print #1, “Y”
Err.Number = 0
Set selp = ThisDrawing.Selecti**ets.Item(“选择文本对象1”)
If Err.Number <> 0 Then ‘如果“选择文本对象”选项已经存在，则删除它
Err.Clear
Set selp = ThisDrawing.Selecti**ets.Add(“选择文本对象1”)
End If
selp.Clear
selp.Select**creen
If Err.Number <> 0 Then ‘如果选择点错误，重新再选
Err.Clear
GoTo 200
End If
For Each obje In selp
If obje.ObjectName = “AcDbText” Then
Set text2 = obje
i = i + 1
point1 = text2.InsertionPoint
p1(0) = point1(0)
p1(1) = point1(1)
p1(2) = 0
Set lin = ThisDrawing.ModelSpace.AddLine(p, p1)
dis = lin.Length
lin.Delete
hi = Val(text2.TextString) – Val(text1.TextString)
his = Val(text2.TextString)
Print #1, Format(dis, “0.0”) + “,” + Format(hi, “0.00”)
If i = 1 Then ttstr = ttstr + vbCrLf & Format(dis, “0.0”) + “/” + Format(hi, “0.00”)
If i <> 1 Then ttstr = ttstr + “、” + Format(dis, “0.0”) + “/” + Format(hi, “0.00”)
If i = 1 Then ttstra1 = ttstra1 + “,” + Format(hi, “0.00”) + “/” + Format(dis, “0.0”)
If i <> 1 Then ttstra1 = ttstra1 + “、” + Format(hi, “0.00”) + “/” + Format(dis, “0.0”)
End If
Next obje
Print #4, ttstra1
Print #3, ttstr
Print #2, str1 + “,” + str2
GoTo 100
200:
Close #2
Close #1
Close #3
Close #4
End Sub