《利用高程点生成断面数据VBA程序.docx》由会员分享，可在线阅读，更多相关《利用高程点生成断面数据VBA程序.docx（39页珍藏版）》请在金锄头文库上搜索。
1、利用高程点生成断面数据VBA程序。主要应用于水渠与道路方面的横断面数据提取，现为生成格式为纬地与重庆测绘院的断面格式。其实格式可以自己设定，需要帮助联系QQ：365149174.具体请各自测试。Public Sub numssg1ok()生成中桩水平单及横断面数据Dim text As AcadText, text1 As AcadText, text2 As AcadTextDim object As AcadEntityDim str1 As String, str2 As StringDim fpath As String, filepath As StringDim selpoint
2、As AcadSelecti*et, selp As AcadSelecti*etDim obje As AcadEntityDim point As Variant, point1 As VariantDim lin As AcadLineDim dis As DoubleDim hi As DoubleDim his As DoubleDim p(0 To 2) As Double, p1(0 To 2) As DoubleDim fipath As StringDim ttstr As StringDim i As DoubleDim fipatha1 As StringDim ttst
3、ra1 As StringOn Error Resume NextDim num As StringDim filepath1 As Stringfpath = F:纵断面.txtfilepath1 = F:绘图横断面.txtfipath = F:纬地设计方横断面.txtfipatha1 = F:横断面原始数据.txtOpen fpath For Append As #2Open filepath1 For Append As #1Open fipath For Append As #3Open fipatha1 For Append As #4100:i = 0Err.Number = 0
4、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.Tex
5、tString point = text1.InsertionPoint p(0) = point(0) p(1) = point(1) p(2) = 0ttstr = str1 & vbCrLfttstra1 = str1 + / + str2 Err.Number = 0Set selpoint = ThisDrawing.Selecti*ets.Item(选择文本对象) If Err.Number 0 Then 如果“选择文本对象”选项已经存在，则删除它 Err.Clear Set selpoint = ThisDrawing.Selecti*ets.Add(选择文本对象) End If
6、 selpoint.Clear selpoint.Select*creen If Err.Number 0 Then 如果选择点错误，重新再选 Err.Clear GoTo 200 End IfFor 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.AddLin
7、e(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
8、, 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 IfNext obje i = 0 Print #1, Y Err.Number = 0Set selp = ThisDrawing.Selecti*ets.Item(选择文本对象1) If Err.Number 0 Then 如果“选择文本对象”选项已经存在，则删除
9、它 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) = poin
10、t1(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)
11、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 IfNext obje Print #4, ttstra1Print #3, ttstrPrint #2, str1 + , + str2G
12、oTo 100200:Close #2Close #1Close #3Close #4End Sub功能：能将杂乱的野外断面数据处理成常规的断面数据;亦可将此转换为绝对的工程点位坐标，以及CASS软件能识别的里程文件。后期处理可用CASS软件将该里程文件直接绘制成断面图，以及土方量的计算。在很多采用非全站仪进行的横断面测量中，常采用如下记录格式（野外断面数据经此程序“处理后”也将生成如下格式的数据）k0+000 中桩的编号3.5,-0.5,2,0.8, 左断面数据至上一个断面点的)水平距离,高差,水平距离,高差,.4,0.2,3,0.5, 右断面数据至上一个断面点的)水平距离,高差,水平距离,高差,.k0+020 中桩的编号.在中桩坐标已知的前提下，可以编辑成如下格式，然后用此程序能快速的将断面数据转换成一个个绝对的工程坐标点。也可以转换成CASS软件能识别的“里程文件”。1,k0+000,16369.32,20117.969,552.82 点号,中桩的编号,Y,X,h2,k0+020,16379.751,20103.15,552.58 点号,中桩的编号,Y,X,h4,k0+060,16409.614,20073.512,551.194 点号,中桩的编号,Y,X,h.以上依次是“处理后”，“中桩坐标”的数据格式，下面为原始坐标数据格式：6,k0+020
