铁路QC成果：水准测量标高计算之Microsoft Excel编程

段第二十九 次QC 成果发表材料

标高快算

V2

——水准测量标高计算之Microsoft Excel编程

发表人：***

***段***车间QC小组 20**年4月2日

第1页共18页

标高快算V2

——水准测量标高计算之Mrcrosoft Excel编程

一、 小组概况：

小组名称 ***段***车间QC小组 成立时间 2005年5月10日日 课题名称 2005年6月10日 登记时间 2007年11月10日 活动期限 20**.5.1~20**. 12.30 注 册 号 课题类型 登 记 号 活动次数 攻关型 22次/月 小 组 人 员 情 况 顺姓名 号 1 2 3 4 5 6 7 *** *** *** *** *** *** *** 接受QC 教育情况 接受QC 教育情况 年龄 性别 46 35 47 39 28 28 24 男 男 男 男 男 男 男 职务 领工员 助工 材料员 计工员 线路工 线路工 实习生 文化程度 中专 大专 大专 大专 中专 中专 大本 组内职务 负责课题布置 技术咨询 测量用具供应 生活后勤保障 程序编制 试用 技术咨询 人均接受TQC教育72小时以上并获考试合格证书 2001年“*****基床病害”获一等奖 2007年“****防护的工程实践” 图 表 1 制 表 人：*** 时 间：2008.3.25

第2页共18页

二、 可行性分析

***段现辖**、**、**、**、**和**六线，累计正线延长917.594km，站线全长418.456km，在长达数千公里的线路维修中，经常需要对纵断面进行抄平，观察其纵断面的坡度。除了线路抄平，在路基防水工程中施工时也要用水准测量，以设计出合理的排水坡度。在执行这些任务的过程中，一天测量下来累积的数据量非常大，这使得资料的整理和数据的计算变成一项非常繁重的工作。 原来用手工的方法直接在记录本上计算出标高，有如下几个缺点：?非常耗费时间，通常要2~3个小时的时间；?计算过程中难免读错数字、错按计算器的键等等，出现错误数据；?现场记录的格式、书写的清晰程度不一，影响数据的统一利用；?测量记录薄积累多了，保存起来也占有宝贵的办公空间。 利用计算机计算标高、整理抄平数据有如下优点：?比较有发展前途，随着电子水准仪的推广使用，有利于与电子水准协同工作，更全面和更深层的分析数据；?有可能将计算结果导入到**段现正使用的纵断面计算软件中去，减少录入人力；?用文字清晰、格式统一、成本廉价的方法保存标高资料，有利于数据再次利用，提高了测量任务的价值；?利用电子计算机的高速运算能力代替现实中简单而重复的计算是世界科学技术发展的趋势。

事实要求一种计算程序的出现，不仅能快速计算出结果，更有利于将结果保存成电子文件，提高水准抄平工作的实施质量。

三、 设计依据及程序简介

1、本程序的原名称叫“水准测量标高计算程序”，该程序已经经过了二~三年的试用，事实证明计算结果准确、可靠。本程序采用了原“水准测量标高计算程序”的核心算法，优化了原程序代码、增加了若干个功能，修正了一些错误。为了跟原程序相区别并简化名称，所以变更名称为“标高快算V2”（V是英文Version的意思，V2表示同一程序第二次升级版）。

2、因为Microsoft公司办公软件功能强大，普及面相当广，铁路工务的资料整理和技术工作中也大量使用到了Microsoft Office软件。其中，Microsoft Office Excel中有宏及Visual Basic编辑器，能够实现更复杂的计算，利用Microsoft Office Excel的Visual Basic编辑器进行标高计算有很多优势：?减小程序体积；?制作

第3页共18页

以后的程序免去安装这一步骤，移植起来很方便；?能够复制现有数据，横性兼容性很好；?能够利用Excel的打印、存储、图表等功能，提高了程序的效率。 3、程序的算法原理与手工计算的方法相同，闭合差校核依据是——两个水准点校核误差≥30√L（两个水准点之间的距离的平方根乘以30倍），平差采用了按置镜数平差。

4、软件环境。操作系统：要求是Windows XP或以上版本的系统；Office版本：完整安装了Microsoft Office Excel 2000或更高版本。

5、程序使用Visual basic语言编写，代码行数为约为727行，参考了Microsoft Visual Basci帮助。

四、功能介绍

1、 填写点号：在填写完测量起点里程和终点里程后能自动填写中间点的里程和点号。

2、 自动生成一张具有边框和格式的表格，表格大于适用于用A4纸进行打印，表格设计工整、紧凑，既保存了关键的信息（每个测段的允许差闭合差、测量日期人员、计算日期人员、页号等），又节约了纸张。

3、 自动计算标高：按表格内容填入各点的测量数据，以及前后两个水准点的里程与实际标高，执行指定的菜单项，只要闭合差合格，就可以迅速在表格的后三列生成标高数值；可以同时、连续地闭合计算多个水准点标高。

4、可以进行多种校核：如从当前选中的水准点校核到下一个水准点、从当前选中的水准点校核到最后一个水准点。

5、可以从另一个水准点表中搜索BM点的标高与里程。选中一个BM点，执行相应菜单项，如果水准点存在，并有当前水准点的标高与里程，就可以自动将水准点表中的BM点的里程与标高复制过来。

6、插入梭头、BM点、岔尖、岔跟等特殊点：原来插入一个特殊点需要点击3、4次鼠标，并还可能录入文字，现在将此操作集成在一个菜单项里，一步就可以实现，插入点号以后自动生成一个该点的里程（默认为前后点的里程的平均值）。 7、其它功能，可以汇总显示所有转点的数据。

第4页共18页

五、使用说明

1、

图 1

计算之前需要填写9项基本资料，分别为线别、行别、起点里程、终点里程、

测量日期、测量人员、计算日期、计算人员、测量间隔。其中起点里程、终点里程、测量间隔3项为必填资料，是程序计算的依据。如果你希望减少键盘录入工作量的话，可以单击线别或行别右边单元格的下拉箭头，程序内置了**段所管辖的所有正线，以及“上行”、“下行”、“单行”三个行别。起点里程和终点里程必须输入数值，不能输入“K### + ###”的形式，“K10+500”应输成“10.5”。测量日期和计算日期也要输入成数值的形式，如“2008年4月26日”应为“2008-4-26”，注意分隔年月日的是英文状态下的短横杠（也就是减号），另外年必须完整地输入4位，只输入后两位是不行的。测点间隔只有50米和25米两种情况，输入其它的数字会发生错误。

各项目输入完毕以后，请检查是否正确，因为以后的操作是不可恢复的。确认无误后将鼠标移动到写有“好”字的按钮上，单击鼠标左键。 2、

第5页共18页

图 2

计算表一共分为四个部份：?信息行即第一行，该行在执行计算以前显示本

次计算的名称，执行计算以后显示各测段的闭合差与允许差信息；?列标题即第2、3行；?数据区即列标题以下的空白单元格区域，这里是填写测量数据和显示计算结果的区域；?名称区即最下面的Excel表格的页标签，此页标签名为本次计算的名称，表达了本次测量的地点。

数据区一共分为10列5大栏：?测点里程：单位是公里，直接输入数字的形式而不要输入“K### + ###”的形式，中间点的里程都填好的，这是便于查找指定里程的测点，当要插入特殊点时，可能需要手工输入该点的里程，特别是BM点的里程，必须要填写，如果BM点外的里程为空白，则程序会忽略该BM点。另外，里程不接受负数；?测点说明：这里是相应里程对应的点号，便于阅读和跟测量簿上的数据相对应。在这一列填入“BM”（大写英文），说明此行是一个水准点的读数，任何其它的字符都不能表示此行为水准点的读数；?转点读数（单位：毫米）：包括后视读数与前视读数，一个水准点必须有后视读数或前视读数，除此以外不能在这两列填入数字；?读数（单位：毫米）：包括轨面、路肩、桩顶，是要录入的一栏。轨面读数是主要读数，可以明确表示出线路纵断面的状况，一般来说路肩与桩顶是表示同一个位置，只要完整填写一列即可，之所以增加一个桩顶列，是为了记录特殊情况下在一个纵断面有3个读数的情况；

第6页共18页

⑹标高（单位：米）： 与读数栏相对应包括轨面、路肩、桩顶。这一大栏是程序计算的结果，大部分不需要手工输入，唯一要输入的是BM点（水准点）的标高，BM点的标高应填入最后一列（桩顶）中。

数据区的第一行和最后一行必须为水准点，即在第2列填入BM字符。当输

入水准点（BM）的信息时，必须在该行的第1列和第10列填入数字，即必须告诉程序该水准点的位置与标高。 3、

图 3

程序的命令集成在“抄平计算”菜单中（图3中红色方框中圈中的菜单）。

这个菜单项跟Excel的其它标准菜单一样，用鼠标左健单击它会弹出一个详细的菜单。“抄平计算”菜单随着文件的打开自动增加，一般位于Excel软件菜单栏最后一项，关闭文件以后这个菜单自动删除。

4、各项功能的操作方法如下：

图 4

①抄平计算。选择这个菜单项程序会自动开始计算标高，这个功能一般是在你填写完了测量数据和前后BM点的里程标高以后执行，校核结果显示在Microsoft Excel的状态栏上。

注：可以将“视图(V)”菜单的“状态栏(S)”菜单项打上勾以显示状态栏。 ②校核到下一个BM点。选中一个BM点所在的行，执行此菜单项，程序会自动寻找下一个BM点并校核这两个BM点之间的测量误差。

③校核到最后一个已填好的BM点。选中一个BM点所在的行，执行此菜单项

第7页共18页

之后程序会自动寻找最后一个完整的BM点并校核这两个BM点之间的误差。 ④搜索BM点。这个功能要求你在本文件相同目录下建立一个名为“BM.XLS”的Excel文件，并将水准点的资料填入其中。也可以将原有的水准点复制到同目录下，并重命名为“BM”。选中一个BM点所在的行，执行此菜单项，程序自动寻找BM.XLS中的与BM点里程相近的水准点，并将其里程与标高复制到BM点所在行的第1列与第10列。

⑤插入梭头：选中要在其后插入的行，程序会在当前行的后面增加一行，并在第一列求出前后两个里程的平均值，在第2列填入“梭头”两个字。

⑥插入BM（插入岔尖，插入岔跟）：方法与“插入梭头”一样，“岔尖”表示道岔的基本轨处接头的读数，岔跟表示道岔辙叉后与轨后连接轨接头处的读数，一般岔尖与岔跟处只有轨面读数。

⑦隐藏中间点：执行此功能后程序会将所有转点读数栏为空的行隐藏起来，再次执行此菜单项会显示所有隐藏起来的行。

六、前景展望

1、加强“搜索BM点”的功能，对算法进行优化，使之能更加准确地进行匹配。 2、建立道岔、道口、桥梁的位置表，能根据道岔、道口、桥梁资料在测点中间自动插入特殊点。

3、对程序的价值进行纵深挖掘：①将标高结果导入到纵断面设计软件中去；②改善测量读数的输入方法，可以将电子经纬仪的数据导入到程序中。

4、 将程序移植到手持式计算机（Windows Mobile）上，利用手持式计算机，可

以在测量的同时使用该程序计算。

（附主程序代码）：

第8页共18页

标高快算V2主要程序代码

''代码整理于20**-12-17

Public intPubSort As Integer '测量类别

Public intPubSpace As Integer '测点间隔，米 Public Sub DataWrite() '抄平计算 On Error GoTo ERRORRAISE Dim sngBML As Single Dim sngBMH As Single Dim sngBMNextL As Single Dim sngBMNextH As Single Dim lngF As Long Dim lngHj() As Long

Dim zds As Integer '转点数

Dim intBM As Integer '起算水准点 Dim intBMNext As Integer '止算水准点 Dim intNum As Integer '第几个测段 '一：从BM点到BM点 '获取数值

'一）BM点资料

Cells(1, 1) = \

For intBM = ActiveCell.Row To ActiveSheet.UsedRange.Rows.Count ' If Cells(intBM, 2) = \Next

If intBM >= ActiveSheet.UsedRange.Rows.Count Then MsgBox (\没有找到起算水准点，无法继续计算！\

While intBM < ActiveSheet.UsedRange.Rows.Count

For intBMNext = intBM + 1 To ActiveSheet.UsedRange.Rows.Count If Cells(intBMNext, 2) = \Next

If intBMNext > ActiveSheet.UsedRange.Rows.Count Then MsgBox (\没有找到下一个水准点，计算已经中止！\

If IsEmpty(Cells(intBM, 1)) Or IsEmpty(Cells(intBM, 10)) Or IsEmpty(Cells(intBM, 3)) Then MsgBox (\请输入起算水准点的里程（A列）、标高（J列）和后视读数（C列）！\Rows(intBM).Select: Cells(intBM, 1).Activate: End If IsEmpty(Cells(intBMNext, 1)) Or IsEmpty(Cells(intBMNext, 10)) Or IsEmpty(Cells(intBMNext, 4)) Then MsgBox (\请输入闭合水准点的里程（A列）、标高（J列）和前视读数（D列）！\sngBML = Cells(intBM, 1) sngBMH = Cells(intBM, 10)

sngBMNextL = Cells(intBMNext, 1) sngBMNextH = Cells(intBMNext, 10) lngF = 0: Dim i As Integer For i = intBM To intBMNext

If i <> intBMNext And Not IsEmpty(Cells(i, 3)) Then lngF = lngF + Cells(i, 3) If i <> intBM And Not IsEmpty(Cells(i, 4)) Then lngF = lngF - Cells(i, 4) Next

lngF = (Cells(intBMNext, 10) - Cells(intBM, 10)) * 1000 - lngF

If Abs(lngF) > 30 * (Abs(sngBMNextL - sngBML)) ^ 0.5 Then Excel.Application.StatusBar = sngBML & \段误差过大，无法继续计算！\ End

'二）转点资料 zds = 0

For i = intBM To intBMNext - 1

If Not IsEmpty(Cells(i, 3)) Then zds = zds + 1

第9页共18页

Next i

ReDim lngHj(zds) As Long: Dim index As Integer lngHj(0) = Cells(intBM, 3): index = 1 For i = intBM + 1 To intBMNext - 1

If Not IsEmpty(Cells(i, 3)) Then lngHj(index) = Cells(i, 3) - Cells(i, 4): index = index + 1 Next i

lngHj(0) = sngBMH * 1000 + lngHj(0) + lngF / zds For index = 1 To zds - 1 '计算并修正仪高

lngHj(index) = lngHj(index - 1) + lngHj(index) + lngF / zds Next

Dim x As Integer

x = sngBMNextH * 1000 - (lngHj(zds - 1) - Cells(intBMNext, 4)) For index = zds - 1 To 0 Step -1 '修正多余量 lngHj(index) = lngHj(index) + x

If x = 0 Then Exit For Else If x > 0 Then x = x - 1 Else x = x + 1 Next index = 0

For i = intBM + 1 To intBMNext '填写测点高程

If i <> intBMNext And Not IsEmpty(Cells(i, 3)) Then index = index + 1 If Not IsEmpty(Cells(i, 5)) Then

Cells(i, 8).Value = Format((lngHj(index) - Cells(i, 5)) / 1000, \ End If

If Not IsEmpty(Cells(i, 6)) Then

Cells(i, 9).Value = Format((lngHj(index) - Cells(i, 6)) / 1000, \ End If

If Not IsEmpty(Cells(i, 7)) Then

Cells(i, 10).Value = Format((lngHj(index) - Cells(i, 7)) / 1000, \ End If Next i

Range(\Range(\Range(\Range(\Range(\Cells(1, 1) = Cells(1, 1) & IndexShu(intNum) & \

Cells(1, 1).Characters(Len(Cells(1, 1)) - 2, 3).Font.Subscript = True

Cells(1, 1) = Cells(1, 1) & sngBML & \& sngBMNextL & \& lngF & \≯\& Int(30 * (Abs(sngBMNextL - sngBML)) ^ 0.5) & \

intBM = intBMNext: intNum = intNum + 1 '统计下一段 Wend

With Cells(1, 1).Font

.Name = \ .Size = 12 End With Exit Sub

ERRORRAISE:

MsgBox \程序无法继续运行！\出现错误\End Sub

Public Function IndexShu(ByVal i As Integer) As String Select Case i Case 1

IndexShu = \①\ Case 2

IndexShu = \②\ Case 3

IndexShu = \③\ Case 4

第10页共18页

If Selection.RowHeight = 0 Then turned = True: Exit For Next

If turned Then

' ActiveSheet.UsedRange.RowHeight = 15.75

Range(Cells(forstRow, 1), Cells(ActiveSheet.UsedRange.Rows.Count, 10)).RowHeight = 15.75 Else

Range(Cells(forstRow, 1), Cells(ActiveSheet.UsedRange.Rows.Count, 10)).RowHeight = 0 For i = forstRow To ActiveSheet.UsedRange.Rows.Count

If Cells(i, 2) = \15.75 Next End If

Excel.Application.ScreenUpdating = True End ERR:

Excel.Application.ScreenUpdating = True End Sub

Public Sub Submit() On Error Resume Next

Application.ScreenUpdating = False

Dim sngInc As Single, sngEnd As Single '起点里程、终点里程

Dim strCaption As String, strFootnote As String '表格标题，表格脚注 Dim i As Integer '

sngInc = Cells(3, 2) sngEnd = Cells(4, 2)

strCaption = Cells(1, 2) & Cells(2, 3) & MileageString(sngInc) & \strFootnote = \测量：\ 计算：\Cells(7, 2)

intPubSpace = Cells(9, 2) '测点间隔 'ActiveSheet.Shapes(\'Selection.Delete

'Range(\

Sheets.Add , Sheets(Sheets.Count)

ActiveSheet.Name = strCaption

Cells.HorizontalAlignment = xlCenter Cells.VerticalAlignment = xlCenter

Cells(4, 1).Activate: ActiveWindow.FreezePanes = True '设置前3行为冻结行 Range(\Range(\Range(\With Cells(1, 1).Font .Size = 12

.Name = \黑体\End With

Range(\测点里程\测点说明\后视\前视\轨面\\路肩\桩顶\轨面\路肩\桩顶\

Range(\转点(mm)\读数(mm)\标高(m)\Range(\Range(\

Range(\Range(\Range(\With Range(\

第16页共18页

.Font.Name = \楷体_GB2312\ .Font.Bold = False

.Borders.LineStyle = xlContinuous

.Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .RowHeight = 15 End With

With Columns(1)

.ColumnWidth = 8

.HorizontalAlignment = xlLeft End With

With Columns(2)

.HorizontalAlignment = xlLeft .ColumnWidth = 11 End With

Range(\'设置表格的页眉与脚注 With ActiveSheet.PageSetup .PrintTitleRows = \ .LeftHeader = \

.LeftFooter = strFootnote

.HeaderMargin = Application.InchesToPoints(0.5) .FooterMargin = Application.InchesToPoints(0.5)

.CenterHeader = \宋体,加粗\第&P页，共&N页\' .LeftMargin = Application.InchesToPoints()

.RightMargin = Application.InchesToPoints(0.44) .TopMargin = Application.InchesToPoints(0.8) .BottomMargin = Application.InchesToPoints(0.8) .CenterHorizontally = True .Orientation = xlPortrait .Draft = False

.PaperSize = xlPaperA4 .Order = xlDownThenOver .Zoom = 100 End With

'填充点号

Cells(4, 2).Value = \'确定起点里程

If sngInc * 1000 Mod intPubSpace <> 0 Then sngInc = (sngInc * 1000 \\ intPubSpace) * intPubSpace: sngInc = sngInc / 1000

If sngEnd * 1000 Mod intPubSpace <> 0 Then sngEnd = (sngEnd * 1000 \\ intPubSpace) * intPubSpace: sngEnd = sngEnd / 1000

If sngInc > sngEnd Then intPubSpace = -intPubSpace

For i = 0 To Abs(sngEnd - sngInc) * 1000 / Abs(intPubSpace)

If sngInc = 0 And i = 0 Then Cells(5 + i, 1) = 0 Else Cells(5 + i, 1) = Format(sngInc + i * intPubSpace / 1000, \Next

Cells(5 + i, 2) = \While i >= 0

Cells(5 + i, 2) = Format((Cells(5 + i, 1) * 1000 Mod 1000) / 50, \ Cells(5 + i, 2) = replace(Cells(5 + i, 2), \' Cells(5 + i, 2) = replace(Cells(5 + i, 2), \

Cells(5 + i, 2).Characters(Len(Cells(5 + i, 2).Text) - 1, 1).Font.superScript = True Cells(5 + i, 2).Characters(Len(Cells(5 + i, 2).Text), 0).Font.superScript = False i = i - 1 Wend

第17页共18页

ActiveSheet.Cells(4, 3).Activate 'ActiveSheet.UsedRange.Select Application.ScreenUpdating = True 'ActiveWorkbook. End Sub

第18页共18页

本文来源：https://www.bwwdw.com/article/llw.html