测绘程序设计(VB)
课间实习报告
姓名:__________________________
学号:__________________________
班级:__1141502_________________________
20##年10 月
目录
1 实习目的... 3
2 实习仪器与软件... 3
2.1 Visual Basic 6.0. 3
3 实习要求... 4
4 实习内容... 4
5 实习步骤... 4
5.1 坐标正反算... 4
5.2 水准测量... 5
5.3 导线计算... 5
5.4 集成化设计... 5
6 实习总结... 5
6.1 实习问题总结... 5
6.2 程序调试总结... 5
7 附录... 5
7.1 正算代码... 5
测绘程序设计实习报告
1 实习目的
掌握Visual Basic(VB)程序设计的基本理论、方法和应用,掌握VB程序应用于测绘专业的程序开发,理解程序设计在测绘数据处理中的作用和地位,学会利用模块化程序设计的基本技术,掌握面向对象程序设计方法,应用测绘专业的基本技能,测绘专业模块程序包开发的基本方法,以及掌握一些最基本的知识,编程里面的英语以及函数有很多不知道,以至学习编程有点困难。、 对水准网观测高程间接平差理论内容的验证与应用。通过学习掌握测绘软件开发过程与方法,初步具备测绘软件开发基本技能。、实验原理和过程通过本学期对《测绘程序设计》课程的学习,编写一份综合性实验报告我选取的题目是利用vb语言进行编程。 熟悉程序设计任务书的基本内容,调查了解软件需求状况,进行需求分析,。计算机的基础比较差,要想将编程学好得掌握更多的函数以及专用的编程语言,工程测量运用编程来计算是比较普遍的,运用编程的方面也比较多,因此努力去掌握一些基础非常重要,为学习后续课程和专业技术工作打下基础。
2 实习仪器与软件
实习期间主要用到的软件有Visual Basic(VB),数据库软件Access、Office软件Word等。
2.1 Visual Basic 6.0
VB是美国microsoft公司在1991年推出的windouus环境下的软件开发工具。Visual意思为可视化的,指的是一种开发图形用户界面的方法。Basic是20世纪60年代出场的一门计算机程序语言,它以简单易学,使用方便的特点,得到广泛应用。VB语言是一种面向对象的可视化程序设计语言。这门语言进行简要的叙述,包括VB的开发环境,对象的概念以及编写VB应用程序的步骤。通过本章的学习,使读者对VB有个大致的了解,并能够编写一些简单的程序。VB使用了可以简单建立应用程序的GUI系统,但是又可以开发相当复杂的程序。VB的程序是一种基于窗体的可视化组件安排的联合,并且增加代码来指定组件的属性和方法。因为默认的属性和方法已经有一部分定义在了组件内,所以程序员不用写多少代码就可以完成一个简单的程序。过去的版本里面VB程序的性能问题一直被放在了桌面上,但是随着计算机速度的飞速增加,关于性能的争论已经越来越少。
VB是基于basic语言可视化程序设计语言。它继承了其先辈basic所具有的简单易用的特点,又采用了面向对象,事件驱动的编程机制,提够了一种所见及所得的可视化界面设计方法。
VB使得大量的外界控件有了自己的生存空间。大量的第三方控件针对VB提供。VB也提供了建立、使用和重用这些控件的方法,但是由于语言问题,从一个应用程序创建另外一个并不简单。
。。。。。
3 实习要求
1.较为熟练地掌握VB程序设计与开发
2.掌握测绘外业工作需要的一些基本理论与方法
3.掌握测绘内业数据处理的流程
4.掌握常用测绘专业软件的交换格式。
5 每次去机房首先找到与今天相关的程序进行调试
6 对程序的调试发挥自己所有的知识对程序进行编改
7 可以通过网络相结合找到一些相关的知识惊醒运用
8 每次将调试后的程序进行运行,如果没用继续调试,直到调试能够运行
9 如果实在不行可以以邮件形式进行询问
10 每次的作业以电子邮件的形式发
11 按时间交作业
4 实习内容
充分学习VB可视化编程以后,熟悉各种常用控件的使用。再结合测量专业数据处理,编写全部或部分专业程序。要求进行循序渐进的方式,先采用基本结构编写,在随后的课程学习当中,采用数组,函数,再生成数据文件格式,从低级到高级应用,最后通过窗体应用与函数的方法进行集成,将所有的实习最后集成到一个程序当中,使之进一步完善与改进等。
① 坐标正反算
坐标反算一般主要应用于测绘工程、建设工程之中,具体在建筑设计,工程测量,测绘制图等领域。总的来说坐标计算分为坐标正算和坐标反算两种,这两种在实际中是较常见的。所要求的公式为:
XB=XA+lcosaAB
YB=YA+lsinaAB
l= (XB-XA)²+(YB-YA)²
② 简易水准平差
平差公式=(闭合差/线路总长)*距离
③ 交会测量程序
交会测量(intersection survey)是根据多个已知点的平面坐标(或高程),通过测定已知点到某待定点的方向或(和)距离(或测定其竖直角),以推求此待定点平面坐标(或高程)的测量技术和方法。以确定待定点平面坐标为目的者,称平面交会测量;以确定待定点高程者,称高程交会测量;以确定待定点三维坐标的,称空间交会测量;若仅在已知点设站进行观测称前方交会,仅在待定点设站进行观测称后方交会既在待定点设站又在个别已知点设站进行观测称侧方交会。在平面和空问交会测量中,若经观测获得的仅有角元素称测角交会,而经观测获得的仅有边元素者称测边交会,经观测直接或间接获得的既有角元素又有边元素则称边角交会。在平面测角交会中,若控制点的平面位置是用解析法求得平面坐标值称解析交会,用图解法确定且直接展绘到图板上则称图解交会。[
4角度与弧度的转换
在python和Delphi中,牵涉到角度计算时,例如:sin(x),cos(x)等,这里的x都是弧度,而不是直接的角度。
因此,在计算对应角度的三角函数时,需要先将角度转换成弧度再计算。
弧度和角度的转换公式是:
角度=弧度*180.0f/PI
弧度=角度*PI/180.0f
(根据实际实习内容写)
5 实习步骤
实习主要在北区机房内进行,主要按实习内容进行
1要对每次的实习作业要进行早预习
2每次读应该对实习做一个充分的准备
3调试的程序一般在光盘上需要每次带好
4一到机房的第一件事情就是找到相关的程序,并进行观察以及查找什么地方能够进行改写
6对于调试一个程序就是讲程序改成最简单,不会很复杂
7对于调试好的程序接下来就是对界面的设计,界面需要整洁以及美观等等。调试好的程序哟按那个狗运行
8最后看程序是否能够运用一些数学函数来编写,那样能够使程序更加简易以及更加的的容易看
9最后就是将调试好的程序以电子邮件发送到邮箱时间在一周之内。
10实习完应该对之进行体会与思考,将知识掌握得跟好
5.1 坐标正反算
坐标反算是根据已知点坐标,计算两点间距离和角度,正算公式为:
a为坐标方位角,S为两点的距离
公式分析:
从式上可以知道公式需要知道初始始坐标,距离和角度,即需要四个输入,若需要在一个函数中实现,返回值有二个,可以有二种方法
1. 单个函数实现
Function Dis2xy(ByVal Dis as Double ,ByVal Ang as Double) as Double
利用数据返回
End Function
2. 两个函数实现
Function Dis2xy(ByVal Dis as Double,ByVal Ang as Double,ByVal Flag as Integer) as Double
增加参数控制
End Function
5.2 水准测量
水准测量又名“几何水准测量”,是用水准仪和水准尺测定地面上两点间高差的方法。在地面两点间安置水准仪,观测竖立在两点上的水准标尺,按尺上读数推算两点间的高差。通常由水准原点或任一已知高程点出发,沿选定的水准路线逐站测定各点的高程。由于不同高程的水准面不平行,沿不同路线测得的两点间高差将有差异,所以在整理国家水准测量成果时,须按所采用的正常高系统加以必要的改正,以求得正确的高程。
本节介绍水准测量成果的计算程序采用多窗口的方式组织,在主窗体上显示信息和执行各种操作,再输入窗口输入数据。方便主窗口与输入窗口的数据传递,本程序还是用了标准模块
水准路线依据工程的性质和测区情况,可以布设以下几种形式。
1 闭合水准路线
高程控制测量(即水准路线测量)分为闭合水准路线测量、附和水准路线测量和支水准路线测量。闭合水准路线测量有一个已知高程点,待测点分布成一个闭合环(所有点—已知高程点、待测点都在这个圈里,按序依次测量),即从已知点出发,到已知点结束。附和水准线路测量有两个已知点,待测点分布成一个弯折的线,从一个已知点出发,到另一个已知点结束(通常这两个已知点距离很远,甚至数十公里)。支水准路线测量往往依附于上面两种水准路线,作为布线死角的补充,有一个已知点,待测点数个成线状分布,从已知点出发,到最后一个待测点后,再原路返测(即往返侧)。闭合水准路线线路封闭,易于平差和纠错;特殊情况下可以做独立高程系统。
2 符合水准路线
附合水准路线是测量学的术语。从某个已知高程的水准点出发,沿路线进行水准测量,最后连测到另一已知高程的水准点上,这样的水准路线称为附合水准路线。
∑h理=H终一H始 (式中H终与H始分别表示最终点与起始已知点的高程)。
按高差闭合差的定义可知:
fh =∑h测-∑h理=∑h测一(H终一H始) (3—12)
高差闭合差的允许值和校核要求与闭合水准路线相同。现以图3-20和表3-3中的观测数据为例来说明附合水准路线高差闭合差调整与高程计
∑h理=H终一H始 (式中H终与H始分别表示最终点与起始已知点的高程)。
按高差闭合差的定义可知:
fh =∑h测-∑h理=∑h测一(H终一H始) (3—12)
高差闭合差的允许值和校核要求与闭合水准路线相同。
3 支水准路线
支水准路线是从一已知高级水准点出发,终点不附合于另一已知高级水准点的水准路线。.从给定的已知点出发,在已知点和ZDl间安置水准仪。立尺于已知点上,读取其后视读数,记入手簿相应栏内。立尺于ZDl的尺垫上,该取其前视读数,记入手簿相应栏内。至此,第一站观测完毕,计算第一站高差并记入手簿相应栏内;.ZDl尺垫不动,水准仪迁站,安置于ZD1和ZD2之间,依同法读取ZD1的后视读数和ZD2的前视读数,记入手簿相应栏内,并计算第二站的高差。依同法直至最后一站,读取并完成相应的记录和计算,以上为往测,计算往测的后视读数总和Σa、前视读数总和Σb和高差总和Σh,并进行计算检核,即Σa-Σb=Σh,应成立,依同法完成返程的观测、记录、计算及其检核。根据往、返测的高差计算高差闭合差fh,根据指导教师给定的单程水准路线长度L计算容许高差闭合差Fh。比较二者,若fh>Fh,表明未达到精度,应予重测,若fh Fh,表明达到精度,则在固定表格内计算高差最或是值并推算未知点的高程。注意事项1.照准目标应检查并消除视差;2.读数时,符合水准长气泡应严格居中;3.前、后视距离应大致相等(扶尺员可用步测);4.最大视线长度不得大于100 m;5.最小尺读数不得小于0.3m;6.在已知点和未知点上立尺时不得安放尺垫;
4 闭合差的计算
(1)闭合水准路线。闭合差为实测高差总合即:
f = ∑h测
(2)符合水准路线。闭合差为起点高程,中点高程差与实测高程总和之差,即:
f = ∑h测 – ( h终-h始)
(3)支水准路线。闭合为往,放测量的高差代数和,即:
f=∑h往-∑h返
5 高差闭合差不超过一定的限度时,认为精度合格,成果可用。普通水准测量终容许高差闭合差一般规定为:
F容=+-40√l
F容==-12√n
式中 L- 水准路线长度,单位km
n- 测站数
闭合差不超过限时,以距离为权分配闭合差。设整条线录长为L,莫段水准路线长为S
整条路线闭合差为f,则该站分配到的闭合差为:
H=-f*s/l
程序分析和设计
Public Sub AddData(iMark As Integer, dist, dH As Single)
dis(iMark) = dist
detH(iMark) = dH
End Sub
7 在闭合差符合要求的情况下,将闭合差以每一站的前后视距和为权进行分配,最后得出每一转点的高程。
5.3 导线计算
导线是将一系列测量控制点,依相邻次序连接而构成折线形式的平面控制图形。由一系列导线元素构成:导线点,是导线上的已知点和待定点;导线边,是连接导线点的折线边;导线角,指导线边之间所夹的水平角。与已知方向相连接的导线角称为连接角(亦称定向角)。导线角按其位于导线前进方向的左侧或右侧而分别称为左角或右角,并规定左角为正、右角为负;单一导线与导线网,其区别在于前者无结点,而后者具有结点。单一导线可布设成:附合导线,起始于一个已知点而终止于另一个已知点;闭合导线,起闭于同一个已知点;支导线,是从一个已知点出发,既不附合于另一个已知点,也不闭合于同一个已知点。导线网可布设为:附合导线网,具有一个以上已知点或具有其他附合条件;自由导线网,网中仅有一个已知点和一个起始方位角而不具有附合条件。
本节将介绍导线计算的程序设即方法,包括必和导线和符合导线的输入检查,容差计算和简易评查计算。本程序的界面采用主窗体和关于窗体的方式,主窗体上使用菜单来组织,数据的输入和输出都采用读写文件的方式来完成,数据的显示和提示信息在主窗体上的文本框中显示。
导线测量是道路及桥梁工程中常采用的一种控制布网方式,但由于受到施工现场的地形及环境限制,导线的布设方式就会有很大的随意性,这样就涉及到各种形式的导线平差计算问题。然而实际工作中所使用的大多数全站仪却只有支导线点的计算功能,这就给在施工现场进行导线测量的平差
1 导线的简易计算
将测区内相邻口指点连接成直线的折现,称为导线。这些控制点,称为导线点。导线测量就是一次侧定格导线边的长度和各折角值,根据起算数据推算各边的坐标方位角,从而求出个导线的坐标。
导线测量是建立小地区平面控制网常用的一种方法,特别是地物分布较复杂的建筑区,实现障碍较多的隐蔽区和带状地区,多采用导线测量的方法,通常分为一级导线,二级导线,三级导线和图更导线登几个等级。根据测区的不同情况和要求,导线可不设成必和导线复合导线一级无定向导线和支导线等级形式。本节介绍计算前两种导线的程序设计方法,后两种形式导线的计算留给读者完成。
(1)闭合导线。起讫于同一己知点的导线,称闭和导线
闭合导线是导线测量的一种,根据测量夹角和边长,推算出平面坐标的测量称为导线测量,常用的导线测量还包括附和导线和支导线。闭合导线就是已知一条边,测量若干个边长和夹角后又闭合到已知边的导线测量方法。通过计算平差后,可计算得到经过的未知点的平面坐标。
闭合导线平差计算步骤:
1,绘制计算草图,在图上填写已知数据和测量数据。
2,角度闭合差的计算与调整。
3,按新的角值,计算各边坐标增量。
4,坐标增量闭合差得计算与调整。
5,根据坐标增量计算坐标。
(2)附合导线。布设在两已知点间的导线,称为附合导线
附合导线是导线测量的一种,通过测量夹角和边长计算点的平面坐标的方法称为导线测量,它还包括闭合导线和支导线。附合导线是由一个已知点出发开始测量,经过若干未知点,到达另一个已知点,然后通过平差计算得到未知点平面坐标的导线测量。
附合导线平差的一般步骤:
1,绘制计算草图,在图上填写已知数据和测量数据。
2,角度闭合差的计算与调整。
3,按新的角值,计算各边坐标增量。
4,坐标增量闭合差得计算与调整。
5,根据坐标增量计算坐标。
(3)闭合导线的计算
1角度闭合差的计算于调整:
∑b=(n-2)*180
由于观测角不可避免地含有误差,因此会产生角度闭合差:
Fb=∑b-∑b1
角度闭合差的容许值,说明电线的确定,图根导线规定为:
Fb==-40n1\2
若角度闭合差超过容许值,说明所测的角度不符合要求,应重新检测角度,若不超过,可将闭合差反符号平均分配到各个观测角中。改正之后内角和应为(n-2)*180,一座计算校队。2用改正值的导线左角或右角
5.4 集成化设计
集成化设计是基于并行工程思想的设计,它利用现代信息技术把传统厂品设计过程中相对独立的阶段、活动及信息有效的结合起来,强调产品设计及其过程同时交叉进行,减少设计过程的多次反复,力求使产品开发人员在设计一开始就考虑到厂品整个生命周期中从概念形成到产品报废处理的所有因素,从而最大限度地提高设计效率、降低生厂成本的设计方法。
集成化设计的一个重要特征是:详细用户界面设计的整体方法(即框架)要在初期进行开发和测试。这是以用户为中心的设计和其他单纯的递增技巧之间存在的重要差异。它确保此后各阶段中进行的递增式设计能够天衣无缝地适合框架,而且用户界面在外观、术语和概念上都能保持一致
6 实习总结
6.1 实习问题总
在这一段时间的实习中,学到一些关于程序调试的知识,但是有感觉到什么也没有学到一样,可能对于vb的知识不够好吧。反正学习vb也有两年了,说没有学到什么又不能,最起码对vb这个软件的了解熟了,并且对于一些简单的程序是能够编写出来,英雌我的体会就是不是没有学到,而是所做的练习较少以及实际操作少。我可能还有个原因是对电脑的基本知识也少,因此对于vb差的原因也归纳与以上几个方面。在编程过程中遇到了较多的问题,解决问题的过程是漫长而艰苦的,然而在问题得到解决的一刹那是很快乐。比如在调节一个程序的时候,当在你不经意的时候将一个能够运行的程序改成了另一种方法来运行,那么你的心里会感觉到无比的兴奋。即使你也不知道是怎么改来的,但这也体现了你的坚持以及一些基础,但是这样的事情也只是很不可能的事情,因此以后还要加强对vb的学习。
6.2 程序调试总结
1、设计模块和过程
(1)模块和过程是应用程序代码的框架,建立这样的框架是应进行慎密的多方面的考虑
(2)涉及术语
过程:包括Sub过程,Function过程和Property(属性)过程。是专门用于一个特定
进程 的一串语句,过程可以拥有一组参数,通过这些参数与程序的其他部分进
行通信,也可以返回一个值,供程序的其他部分使用。
Sub 过程:用关键字Sub 说明的一种过程,不返回任何值。
Function 过程:用关键字function 说明的一种过程,返回相应的值。
Property 过程:用关键字Property、Get、 Property Let 或 Property Set 说明的一种过程
(3) 观察是否出现了可以给过程分组的条件,然后就可以考虑为过程的分组,而创建新模通过创建专用模块,能增强模块的内聚力。模块的基本目的是创建相当独立的程序单元.
(4) 尽量使过程成为自成一体的独立过程,除了尽量使过程成为专用过程外,还应该尽量使之成为独立的过程。应该尽量减少过程之间的连接关系,方法之一是尽量减少全局变量和模块级变量创建专用过程指导原则。
(5)当某个过程被许多其他过程调用(并且因此 许多其他过程依赖于他)时,就说明它是个高度扇入的过程,这是件好事。高度扇入的过程通常是封装很好的过程,它支持代码复用的思路。如果一个过程要调用许多其他过程,而它又 是个高度扇出的过程,那么情况就不那么好了,高度扇出意味着该过程要依赖于许多其他过程才能完成它的工作。
(6)设计模块和过程要达到的目的
1. 创建更加容易调试和维护的过程,
2. 创建具有强大内聚力的模块, 3. 创建高度专用的过程,
4. 创建松散连接的过程 5. 尽量使过程具有独立性
6. 提高过程的扇入性 7 . 降低过程的扇出性
(7)编程原则
(1)使代码更加容易理解,使程序工程的调试和维护工作大大改观。
方法: (1) 给过程命名时应该大小写字母混合使用
(2) 定义过程名时不使用缩写
2、为每个过程赋予单个退出点
优点:使过程更像是黑箱。代码的执行从一个门进来,代码的退出则从另一个门出
因此产生的错误比较少,调试也不太难。
方法:在每个过程中创建一个PROC_EXIT标注。 在这个标注下面,放入所有必要的清除代码和一个
相应的Exit语句(Exit Sub、Exit Function和Exit Property)。
每当你需要退出该过程时,只需加上一个GoTo PROC_Exit,而不必直接调用Exit命令。
3、 为每个过程赋予明确定义的作用域
作用域:工程中的变量或过程的可视性。创建过程 时,始终都应显式地定义它的
作用域。
(8 用参数在过程之间传递数据
(1)应该尽量避免使用模块级变量。
(2)为了减少模块级变量和全局变量,方法之一是将数据作为参数在不同过程之间传递而不是让过程共享全局变量或模块级变量。
(3)为每个参数指定数据类型,创建带有参数的过程时,请务必将每个参数明确说明为一个特定的数据类型。
(4)根据情况传递数据ByVal或ByRef。
(5)始终要对数进行检验,决不要假设你的数据没有问题。
(6)当参数只接受较小的一组值时,请使用枚举值。(7)使用统一和直观明了的方式来调用过程
(8)应该避免省略call这种方法。
(9)调用Sub过程时始终都要使用Call关键字。通过使用Call关键字,更容易将Sub调用与Function调用区分开来
(10)对于调试后进行归纳总结,以助更好的学习v7 附录
7.1 正算代码
1 水准测量
'累计高差和高差闭合差
tDist = tDist + dis(i)
Next i
totalDetH = 0
For i = 1 To nMarks '计算累计高差
totalDetH = totalDetH + detH(i)
Next i
'计算闭合差
startPoint = Val(txtStartPoint.Text)
endPoint = Val(txtEndPoint.Text)
If optAnnex.Value Then '附合水准
closeDetH = (endPoint - startPoint) - totalDetH
Else '闭合水准和支水准
closeDetH = -totalDetH
End If
'检查闭合差是否超限
If closeDetH > 0.04 * Sqr(tDist) Then '采用40*Sqr(L)来计算,单位是毫米
MsgBox "闭合差超限,测量成果不合格!", , "闭合差超限"
txtShowResult.Text = txtShowResult.Text & "闭合差超限,测量成果不合格!"
Exit Sub
Else
MsgBox "闭合差合格,继续计算转点高程!", , "闭合差合格"
End If
Dim temp!
temp = startPoint
txtShowResult.Text = txtShowResult.Text & "平差后的高程为:" & vbCrLf
For i = 0 To nMarks
temp = temp + detH(i) + closeDetH * dis(i) / tDist
txtShowResult.Text = txtShowResult.Text & " (" & Str(i) & "):" & Str(Format(temp, "0.000")) & vbCrLf
Next i
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub cmdInput_Click()
'检查输入的几个文本框:是否已经输入了
If txtStartPoint.Text = "0" Then
MsgBox "还没有输入起始点高程!"
Exit Sub
End If
If txtEndPoint.Text = "0" And optAnnex.Value = True Then
MsgBox "还没有输入终点高程!"
Exit Sub
End If
If txtBMNum.Text = "0" And optAnnex.Value = True Then
MsgBox "还没有输入测站数!"
Exit Sub
End If
frmInput.Show
End Sub
Private Sub optAnnex_Click()
txtEndPoint.Enabled = optAnnex.Value
End Sub
Private Sub optClose_Click()
txtEndPoint.Enabled = Not optClose.Value
End Sub
Private Sub optSpur_Click()
txtEndPoint.Enabled = Not optSpur.Value
End Sub
Private Sub txtStartPoint_LostFocus()
If Not IsNumeric(txtStartPoint.Text) Then
MsgBox "输入的高程含有非数字字符!"
txtStartPoint.Text = ""
txtStartPoint.SetFocus
Exit Sub
End If
If Val(txtStartPoint.Text) > 5000 Or Val(txtStartPoint.Text) < -100 Then
MsgBox "输入的高程有误!"
txtStartPoint.Text = ""
txtStartPoint.SetFocus
Exit Sub
End If
startPoint = Val(txtStartPoint.Text)
End Sub
MsgBox "输入的高程含有非数字字符!"
txtEndPoint.Text = ""
txtEndPoint.SetFocus
Exit Sub
End If
If Val(txtEndPoint.Text) > 5000 Or Val(txtEndPoint.Text) < -100 Then
MsgBox "输入的高程有误!"
txtEndPoint.Text = ""
txtEndPoint.SetFocus
Exit Sub
End If
endPoint = Val(txtEndPoint.Text)
End Sub
Private Sub txtBMNum_LostFocus()
If Not IsNumeric(txtBMNum.Text) Then
MsgBox "输入的测站数含有非数字字符或尚未输入!"
txtBMNum.Text = ""
txtBMNum.SetFocus
Exit Sub
End If
nMarks = Val(txtBMNum.Text)
If txtBMNum.Text <> "" And (nMarks > 20 Or nMarks < 2) Then
MsgBox "输入的测站数有误!"
txtBMNum.Text = ""
txtBMNum.SetFocus
Exit Sub
End If
ReDim dis(nMarks) As Single, detH(nMarks) As Single
End Sub
Xx2 = (k2 + 1) * (x2 * Cos(e2) + y2 * Sin(e2)) + dX2
Yy2 = (k2 + 1) * (y2 * Cos(e2) - x2 * Sin(e2)) + dY2
txtXx2.Text = Format(Xx2, "0.0000")
txtYy2.Text = Format(Yy2, "0.0000")
End Sub
反算代码
x2 = ((Xx2 - dX2) * Cos(e2) - (Yy2 - dY2) * Sin(e2)) / (k2 + 1)
y2 = ((Yy2 - dY2) * Cos(e2) + (Xx2 - dX2) * Sin(e2)) / (k2 + 1)
txtX2.Text = Format(x2, "0.0000")
txtY2.Text = Format(y2, "0.0000")
End Sub
3 导线计算代码
If Check1.Value = 0 And Check2.Value = 0 Then
MsgBox "请选择标尺", "1"
End If
Text7.Text = Val(Text5.Text) - Val(Text6.Text) '前距
If Text7.Text > 500 Or Text7.Text < -500 Then
MsgBox "后尺读数错误"
End If
Text3.Text = Val(Text1.Text) - Val(Text2.Text) '后距
If Text3.Text > 500 Or Text3.Text < -500 Then
MsgBox "前尺读数错误"
End If
Text4.Text = (Val(Text3.Text) - Val(Text7.Text)) / 10 '视距差
If Text4.Text > 30 Or Text4.Text < -30 Then
MsgBox "数据超出误差"
End If
Text11.Text = Val(Text9.Text) - Val(Text10.Text)
Text15.Text = Val(Text13.Text) - Val(Text14.Text) '后-前
Text12.Text = Val(Text19.Text) + Val(Text9.Text) - Val(Text13.Text)
Text16.Text = Val(Text20.Text) + Val(Text10.Text) - Val(Text14.Text) 'K+黑-红
If Text12.Text > 3 Or Text12.Text < -3 Then
MsgBox "中丝超出误差"
End If
If Text16.Text > 3 Or Text16.Text < -3 Then
MsgBox "中丝超出误差"
End If
Text17.Text = Val(Text15.Text) + Val(Text21.Text) - Val(Text11.Text)
Text18.Text = (Val(Text11.Text) + Val(Text15.Text) + Val(Text21.Text)) / 2 '高差中数
End Sub
4 矩阵的相加 相减 相乘的编程
Option Explicit
Public R1%, R2%, C1%, C2% '两个输入矩阵的行数、列数
Public m%, n%, s% '进行运算的矩阵大小,相乘时两个矩阵为m×s和s×n,相加减、转置时矩阵大小为m×n
Public IsFirstMOperated As Boolean '是否当前操作是对第一个矩阵进行
Public a() As Double, b() As Double, c() As Double '存放两个被操作矩阵和结果矩阵
Public Sub GetMatrix()
Dim i%, j%, k%
If IsFirstMOperated Then
frmMain.txtResult.Text = frmMain.txtResult.Text & " 第一个矩阵的内容为:" & vbCrLf
For i = 1 To R1
For j = 1 To C1
a(i, j) = Val(frmInput.txt((i - 1) * C1 + j))
frmMain.txtResult.Text = frmMain.txtResult.Text & Str(a(i, j)) & " , "
Next j
frmMain.txtResult.Text = frmMain.txtResult.Text & vbCrLf
Next i
Else
frmMain.txtResult.Text = frmMain.txtResult.Text & " 第二个矩阵的内容为:" & vbCrLf
For i = 1 To R2
For j = 1 To C2
b(i, j) = Val(frmInput.txt((i - 1) * C2 + j))
frmMain.txtResult.Text = frmMain.txtResult.Text & Str(b(i, j)) & " , "
Next j
frmMain.txtResult.Text = frmMain.txtResult.Text & vbCrLf
Next i
End If
End Sub
Public Sub MatrixPlus()
MsgBox "第一个矩阵尚未输入!"
Exit Sub
End If
If R2 < 1 Or C2 < 1 Then
MsgBox "第二个矩阵尚未输入!"
Exit Sub
End If
If R1 <> R2 Or C1 <> C2 Then
MsgBox "输入的两个矩阵维数不等,不能相加!"
Exit Sub
End If
ReDim c(1 To m, 1 To n) As Double
frmMain.txtResult.Text = frmMain.txtResult.Text & " 两个矩阵相加的结果为:" & vbCrLf
For i = 1 To m
For j = 1 To n
c(i, j) = a(i, j) + b(i, j)
frmMain.txtResult.Text = frmMain.txtResult.Text & Str(c(i, j)) & " , "
Next j
frmMain.txtResult.Text = frmMain.txtResult.Text & vbCrLf
' On Error Resume Next
' C1 = UBound(a, 2) - LBound(a, 2) + 1
' If Err Then
' MsgBox "第一个矩阵维数不对!"
' Exit Sub
' End If
' On Error Resume Next
' C2 = UBound(b, 2) - LBound(b, 2) + 1
' If Err Then
' MsgBox "第二个矩阵维数不对!"
' Exit Sub
' End If
' R1 = UBound(a, 1) - LBound(a, 1) + 1
' R2 = UBound(b, 1) - LBound(b, 1) + 1
'
' If R1 <> R2 Or C1 <> C2 Then
' MsgBox "输入的两个矩阵维数不等,不能相加!"
'End Sub
If R1 < 1 Or C1 < 1 Then
MsgBox "第一个矩阵尚未输入!"
Exit Sub
End If
If R2 < 1 Or C2 < 1 Then
MsgBox "第二个矩阵尚未输入!"
Exit Sub
End If
If R1 <> R2 Or C1 <> C2 Then
MsgBox "输入的两个矩阵维数不等,不能相减!"
Exit Sub
End If
ReDim c(1 To m, 1 To n) As Double
frmMain.txtResult.Text = frmMain.txtResult.Text & " 两个矩阵相减的结果为:" & vbCrLf
For i = 1 To m
For j = 1 To n
c(i, j) = a(i, j) - b(i, j)
frmMain.txtResult.Text = frmMain.txtResult.Text & Str(c(i, j)) & " , "
Next j
frmMain.txtResult.Text = frmMain.txtResult.Text & vbCrLf
Next i
End Sub
''矩阵相减的通用过程
'Public Sub MatrixMinus(a, b, c)
' Dim i%, j%
' Dim R1%, C1%, R2%, C2%
' On Error Resume Next
' C1 = UBound(a, 2) - LBound(a, 2) + 1
' If Err Then
' MsgBox "第一个矩阵维数不对!"
' Exit Sub
' End If
' On Error Resume Next
' C2 = UBound(b, 2) - LBound(b, 2) + 1
' If Err Then
' MsgBox "第二个矩阵维数不对!"
' Exit Sub
' End If
' R1 = UBound(a, 1) - LBound(a, 1) + 1
' R2 = UBound(b, 1) - LBound(b, 1) + 1
'
' If R1 <> R2 Or C1 <> C2 Then
' MsgBox "输入的两个矩阵维数不等,不能相减!"
' Exit Sub
'
Public Sub MatrixMulti()
Dim i%, j%, k%
If R1 < 1 Or C1 < 1 Then
MsgBox "第一个矩阵尚未输入!"
Exit Sub
End If
If R2 < 1 Or C2 < 1 Then
MsgBox "第二个矩阵尚未输入!"
Exit Sub
End If
If C1 <> R2 Then
MsgBox "输入的两个矩阵大小不对,不能相乘!"
Exit Sub
End If
m = R1: s = C1: n = C2
ReDim c(1 To m, 1 To n) As Double
frmMain.txtResult.Text = frmMain.txtResult.Text & " 两个矩阵相乘的结果为:" & vbCrLf
c(i, j) = c(i, j) + a(i, k) * b(k, j)
Next k
frmMain.txtResult.Text = frmMain.txtResult.Text & Str(c(i, j)) & " , "
Next j
frmMain.txtResult.Text = frmMain.txtResult.Text & vbCrLf
Next i
End Sub
''矩阵相乘的通用过程
'Public Sub MatrixMulti(a, b, c)
' ' ' On Error Resume Next
' C1 = UBound(a, 2) - LBound(a, 2) + 1
' If Err Then
' MsgBox "第一个矩阵维数不对!"
' Exit Sub
' End If
' On Error Resume Next
' C2 = UBound(b, 2) - LBound(b, 2) + 1
' If Err Then
' MsgBox "第二个矩阵维数不对!"
' Exit Sub
' End If
' R1 = UBound(a, 1) - LBound(a, 1) + 1
' R2 = UBound(b, 1) - LBound(b, 1) + 1
'
' If C1 <> R2 Then
' MsgBox "输入的两个矩阵大小不对,不能相乘!"
' Exit Sub
' End If
'
' m = R1: s = C1: n = C2
'
' c(i, j) = c(i, j) + a(i, k) * b(k, j)
'
Public Sub MatrixTrans()
If R1 < 1 Or C1 < 1 Then
MsgBox "第一个矩阵尚未输入!"
Else
ReDim c(1 To C1, 1 To R1)
For i = 1 To R1
For j = 1 To C1
c(j, i) = a(i, j)
Next j
Next i
frmMain.txtResult.Text = frmMain.txtResult.Text & " 第一个矩阵转置的结果为:" & vbCrLf
For i = 1 To C1
For j = 1 To R1
frmMain.txtResult.Text = frmMain.txtResult.Text & Str(c(i, j)) & " , "
Next j
frmMain.txtResult.Text = frmMain.txtResult.Text & vbCrLf
Next i
End If
If R2 < 1 Or C2 < 1 Then
MsgBox "第二个矩阵尚未输入!"
Else
ReDim c(1 To C2, 1 To R2)
For i = 1 To R2
For j = 1 To C2
c(j, i) = b(i, j)
Next j
Next i
frmMain.txtResult.Text = frmMain.txtResult.Text & " 第二个矩阵转置的结果为:" & vbCrLf
For i = 1 To C2
For j = 1 To R2
frmMain.txtResult.Text = frmMain.txtResult.Text & Str(c(i, j)) & " , "
Next j
frmMain.txtResult.Text = frmMain.txtResult.Text & vbCrLf
Next i
End If
End Sub
''矩阵转置的通用过程
'Public Sub MatrixTrans(a, c)
'
'
' On Error Resume Next
' C1 = UBound(a, 2) - LBound(a, 2) + 1
' If Err Then
' MsgBox "输入的矩阵维数不对!"
' Exit Sub
' End If
' R1 = UBound(a, 1) - LBound(a, 1) + 1
' ReDim c(1 To C1, 1 To R1)
' For i = 1 To R1
' For j = 1 To C1
' c(j, i) = a(i, j)
'
单导线编程
'求AB的坐标方位角,输入是两点坐标,输出的是弧度值
Public Function DirectAB(Xa#, Ya#, Xb#, Yb#) As Double
Dim detX#, detY#, tana#
detX = Xb - Xa
detY = Yb - Ya
If Abs(detX) < 0.000001 Then
If detY > 0 Then
DirectAB = PI / 2
Else
DirectAB = PI * 3 / 2
End If
Else
tana = detY / detX
DirectAB = Atn(tana)
If detX < 0 Then
DirectAB = PI + DirectAB
ElseIf detX > 0 And detY < 0 Then
DirectAB = PI * 2 + DirectAB
End If
End If
End Function
'弧度化为度.分秒的形式:输入弧度值,输出度.分秒(各占两位)
Public Function HuToDo(ByVal Hu As Double) As Single
Dim du%, fen%, miao%
Hu = Hu * 180 / PI
du = Fix(Hu)
Hu = (Hu - du) * 60
fen = Fix(Hu)
Hu = (Hu - fen) * 60
miao = Fix(Hu + 0.5)
If miao = 60 Then
fen = fen + 1
miao = 0
HuToDo = du + fen / 100 + miao / 10000
End Function
'将度.分秒形式化为弧度:输入为度.分秒形式,输出为弧度
Public Function DoToHu(ByVal DoFenMiao As Double) As Single
Dim du%, fen%, miao%, angle#
du = Fix(DoFenMiao)
DoFenMiao = (DoFenMiao - du) * 100
fen = Fix(DoFenMiao)
miao = (DoFenMiao - fen) * 100
angle = du + fen / 60 + miao / 3600
DoToHu = angle * PI / 180
End Function
'矩阵转置的通用过程
Public Sub MatrixTrans(A, c)
On Error Resume Next
C1 = UBound(A, 2) - LBound(A, 2) + 1
If Err Then
MsgBox "输入的矩阵维数不对!"
Exit Sub
End If
R1 = UBound(A, 1) - LBound(A, 1) + 1
ReDim c(1 To C1, 1 To R1)
For i = 1 To R1
For j = 1 To C1
c(j, i) = A(i, j)
Next j
Next i
End Sub
'矩阵相加的通用过程
Public Sub MatrixPlus(A, b, c)
Dim i%, j%
Dim R1%, C1%, R2%, C2%
On Error Resume Next
C1 = UBound(A, 2) - LBound(A, 2) + 1
If Err Then
MsgBox "第一个矩阵维数不对!"
Exit Sub
End If
On Error Resume Next
C2 = UBound(b, 2) - LBound(b, 2) + 1
If Err Then
MsgBox "第二个矩阵维数不对!"
Exit Sub
End If
R1 = UBound(A, 1) - LBound(A, 1) + 1
R2 = UBound(b, 1) - LBound(b, 1) + 1
If R1 <> R2 Or C1 <> C2 Then
MsgBox "输入的两个矩阵维数不等,不能相加!"
Exit Sub
End If
ReDim c(1 To m, 1 To n) As Double
For i = 1 To m
For j = 1 To n
c(i, j) = A(i, j) + b(i, j)
Next j
Next i
End Sub
'矩阵相减的通用过程
Public Sub MatrixMinus(A, b, c)
C1 = UBound(A, 2) - LBound(A, 2) + 1
If Err Then
MsgBox "第一个矩阵维数不对!"
Exit Sub
End If
On Error Resume Next
C2 = UBound(b, 2) - LBound(b, 2) + 1
If Err Then
MsgBox "第二个矩阵维数不对!"
Exit Sub
End If
R1 = UBound(A, 1) - LBound(A, 1) + 1
R2 = UBound(b, 1) - LBound(b, 1) + 1
If R1 <> R2 Or C1 <> C2 Then
MsgBox "输入的两个矩阵维数不等,不能相减!"
Exit Sub
End If
ReDim c(1 To m, 1 To n) As Double
For i = 1 To m
For j = 1 To n
c(i, j) = A(i, j) - b(i, j)
Next j
Next i
End Sub
'矩阵相乘:输入矩阵或数Qa、Qb,自动识别它们的维数,并输出它们的乘积Qn
Public Sub Matrix_Multy(Qn, Qa, Qb)
Dim ia%, ib%, ic%
Dim ai%, bi%, ci%
Dim e1 As Boolean, e2 As Boolean, e3 As Boolean, e4 As Boolean, e5 As Boolean, e6 As Boolean, e7 As Boolean
On Error Resume Next '看Qa是不是一维数组
ic = UBound(Qa, 2) - LBound(Qa, 2)
If Err Then e1 = True
On Error Resume Next '看Qa是不是一维数组
ib = UBound(Qb, 2) - LBound(Qb, 2)
If Err Then e2 = True
If e1 = False And e2 = False Then '二维矩阵相乘
For ai = LBound(Qa, 1) To UBound(Qa, 1)
For bi = LBound(Qb, 2) To UBound(Qb, 2)
For ci = LBound(Qa, 2) To UBound(Qa, 2)
Qn(ai, bi) = Qn(ai, bi) + Qa(ai, ci) * Qb(ci, bi)
Next ci
Next bi
Next ai
ElseIf e1 = True And e2 = False Then
On Error Resume Next
ia = UBound(Qa) - LBound(Qa)
If Err Then e6 = True
If e6 Then '数乘以二维矩阵
For ai = LBound(Qb, 1) To UBound(Qb, 1)
For bi = LBound(Qb, 2) To UBound(Qb, 2)
Qn(ai, bi) = Qa * Qb(ai, bi)
Next bi
Next ai
Else '一维矩阵乘以二维矩阵
For ci = LBound(Qb, 2) To UBound(Qb, 2)
For ai = LBound(Qa, 1) To UBound(Qa, 1)
Qn(ci) = Qn(ci) + Qa(ai) * Qb(ai, ci)
Next ai
Next ci
End If
ElseIf e1 = False And e2 = True Then
On Error Resume Next
ic = UBound(Qb) - LBound(Qb)
If Err Then e7 = True
If e7 Then '二维矩阵乘以数
For ai = LBound(Qa, 1) To UBound(Qa, 1)
For bi = LBound(Qa, 2) To UBound(Qa, 2)
Qn(ai, bi) = Qa(ai, bi) * Qb
Next bi
Next ai
Else '二维矩阵乘以一维矩阵
For ai = LBound(Qa, 1) To UBound(Qa, 1)
For bi = LBound(Qa, 2) To UBound(Qa, 2)
Qn(ai) = Qn(ai) + Qa(ai, bi) * Qb(bi)
Next bi
Next ai
End If
Else
Dim errT As Integer
On Error Resume Next '结果是否是一个数
errT = UBound(Qn)
If Err Then e3 = True
If e3 Then '一维矩阵乘以一维矩阵得一个数
For ai = LBound(Qa, 1) To UBound(Qa, 1)
For bi = LBound(Qa, 2) To UBound(Qa, 2)
Qn = Qn + Qa(ai) * Qb(bi)
Next bi
Next ai
Exit Sub
End If
On Error Resume Next '是否是数乘一维矩阵
ia = UBound(Qa) - LBound(Qa)
If Err Then e4 = True
If e4 Then
For bi = LBound(Qa, 2) To UBound(Qa, 2)
Qn(bi) = Qa * Qb(bi)
Next bi
Exit Sub
End If
On Error Resume Next '是否是一维矩阵乘数
ib = UBound(Qb) - LBound(Qb)
If Err Then e5 = True
If e5 Then
For ai = LBound(Qa, 1) To UBound(Qa, 1)
Qn(ai) = Qa(ai) * Qb
'一维矩阵相乘结果是二维矩阵
For ai = LBound(Qa, 1) To UBound(Qa, 1)
For bi = LBound(Qa, 2) To UBound(Qa, 2)
Qn(ai, bi) = Qa(ai) * Qb(bi)
Next bi
'矩阵相乘的通用过程
Public Sub MatrixMulti(A, b, c)
On Error Resume Next
C1 = UBound(A, 2) - LBound(A, 2) + 1
If Err Then
MsgBox "第一个矩阵维数不对!"
Exit Sub
End If
On Error Resume Next
C2 = UBound(b, 2) - LBound(b, 2) + 1
If Err Then
MsgBox "第二个矩阵维数不对!"
Exit Sub
End If
R1 = UBound(A, 1) - LBound(A, 1) + 1
R2 = UBound(b, 1) - LBound(b, 1) + 1
If C1 <> R2 Then
MsgBox "输入的两个矩阵大小不对,不能相乘!"
Exit Sub
End If
m = R1: s = C1: n = C2
ReDim c(1 To m, 1 To n) As Double
c(i, j) = c(i, j) + A(i, K) * b(K, j)
Next K
Next j
Next i
End Sub
'列选主元法Guass约化求解线性方程组
Public Sub MajorInColGuass(A, b, X)
'计算并检查矩阵的大小
Row = UBound(A, 1) - LBound(A, 1) + 1
Col = UBound(A, 2) - LBound(A, 2) + 1
If Row <> Col Then
MsgBox "方程组的系数矩阵有误!"
Exit Sub
End If
'准备约化过程的变量和数组
n = UBound(b) - LBound(b) + 1
If n <> Row Then
MsgBox "方程组的系数矩阵与常数项大小不符!"
Exit Sub
End If
ReDim L(2 To Row) As Double
Dim sumAX As Double, iPos%, temp#
'约化过程
For iStep = 1 To n - 1
'列选主元
iPos = 0
For iRow = iStep + 1 To n
If Abs(A(iRow, iStep)) > Abs(A(iStep, iStep)) Then
iPos = iRow
End If
Next iRow
If iPos > iStep Then '需要换主元
For iCol = iStep To n
temp = A(iStep, iCol)
A(iStep, iCol) = A(iPos, iCol)
A(iPos, iCol) = temp
Next iCol
temp = b(iStep)
b(iStep) = b(iPos)
b(iPos) = temp
End If
'约化过程
For iRow = iStep + 1 To n
L(iRow) = A(iRow, iStep) / A(iStep, iStep)
For iCol = iStep To n
A(iRow, iCol) = A(iRow, iCol) - L(iRow) * A(iStep, iCol)
Next iCol
b(iRow) = b(iRow) - L(iRow) * b(iStep)
Next iRow
ShowMatrix A
Next iStep
'回代过程
X(n) = b(n) / A(n, n)
For iRow = n - 1 To 1 Step -1
sumAX = 0
For iCol = n To iRow + 1 Step -1
sumAX = sumAX + A(iRow, iCol) * X(iCol)
Next iCol
X(iRow) = (b(iRow) - sumAX) / A(iRow, iRow)
Next iRow
End Sub
'Guass-Seidel迭代法求解线性方程组
Private Function Seidel(A, b, X, eps#) As Boolean
Dim i%, j%
Dim P#, Q#, s#, t#
Dim Row%, Col%, n%
Row = UBound(A, 1) - LBound(A, 1) + 1
Col = UBound(A, 2) - LBound(A, 2) + 1
n = UBound(b) - LBound(b) + 1
If n <> Row Then
MsgBox "方程组的系数矩阵与常数项大小不符!"
Exit Function
End If
For i = 1 To n
P = 0#
X(i) = 0#
For j = 1 To n
If i <> j Then P = P + Abs(A(i, j))
Next j
If P >= Abs(A(i, i)) Then
Seidel = False
Exit Function
End If
Next i
P = eps + 1#
While P >= eps
P = 0#
For i = 1 To n
t = X(i)
s = 0#
For j = 1 To n
If j <> i Then s = s + A(i, j) * X(j)
Next j
X(i) = (b(i) - s) / (A(i, i))
Q = Abs(X(i) - t) '/ (1# + Abs(x(i)))
If Q > P Then P = Q
Next i
Wend
Seidel = True
End Function
Public Sub ShowMatrix(tt)
Dim i%, j%, n%, m%
m = UBound(tt, 1) - LBound(tt, 1) + 1
n = UBound(tt, 2) - LBound(tt, 2) + 1
For i = 1 To m
For j = 1 To n
Debug.Print tt(i, j),
Next j
Debug.Print
Next i
End Sub
'通用的间接平差解算过程:输入系数矩阵A、权矩阵P、常数向量L和解向量X,求出X,并通过参数传出去
Public Sub InAdjust(A, P, L, X)
Dim a1%, a2%, p1%, p2%, L1%, x1% '输入矩阵或向量的大小
Dim At() As Double, AtP() As Double, Naa#(), W() As Double '几个中间矩阵
'计算并检查输入矩阵或向量的大小
On Error Resume Next
a1 = UBound(A, 1) - LBound(A, 1) + 1
If Err Then
MsgBox "系数矩阵A大小错误!"
Exit Sub
End If
On Error Resume Next
a2 = UBound(A, 2) - LBound(A, 2) + 1
If Err Then
MsgBox "系数矩阵A大小错误!"
Exit Sub
End If
On Error Resume Next
L1 = UBound(L) - LBound(L) + 1
If Err Then
MsgBox "常数向量L大小错误!"
Exit Sub
End If
On Error Resume Next
x1 = UBound(X) - LBound(X) + 1
If Err Then
MsgBox "解向量X大小错误!"
Exit Sub
End If
On Error Resume Next
p1 = UBound(P, 1) - LBound(P, 1) + 1
If Err Then
MsgBox "权矩阵P大小错误!"
Exit Sub
End If
On Error Resume Next
p2 = UBound(P, 2) - LBound(P, 2) + 1
If Err Then
MsgBox "权矩阵P大小错误!"
Exit Sub
End If
If p1 <> p2 Then
MsgBox "权矩阵P不是方阵!"
Exit Sub
End If
If p1 <> a1 Or p2 <> a1 Then
MsgBox "权矩阵P与系数矩阵A大小不符!"
Exit Sub
End If
If a2 <> x1 Then
MsgBox "系数矩阵A大小与解向量X大小不符!"
Exit Sub
End If
If a1 <> L1 Then
MsgBox "系数矩阵A大小与常数向量L大小不符!"
Exit Sub
End If
'定义中间矩阵的大小
ReDim At(1 To a2, 1 To a1), AtP(1 To a2, 1 To a1)
ReDim Naa(1 To a2, 1 To a2), W(1 To a2)
'组成法方程并计算
Debug.Print "The A matrix is:"
ShowMatrix A
MatrixTrans A, At '求A的转置矩阵
Debug.Print "The At matrix is:"
ShowMatrix At
Debug.Print "The P matrix is:"
ShowMatrix P
Matrix_Multy AtP, At, P '求AtP
Debug.Print "and The AtP matrix is:"
ShowMatrix AtP
Matrix_Multy Naa, AtP, A '法方程系数矩阵
Debug.Print "the Naa matrix is:"
ShowMatrix Naa
Debug.Print "the L matrix is:"
For x1 = LBound(L) To UBound(L)
Debug.Print L(x1)
Next x1
Matrix_Multy W, AtP, L '法方程常数向量
Debug.Print "the W matrix is:"
For x1 = LBound(W) To UBound(W)
Debug.Print W(x1)
Next x1
MajorInColGuass Naa, W, X
Debug.Print "the X matrix is:"
For x1 = LBound(X) To UBound(X)
Debug.Print X(x1)
Next x1
'Seidel Naa, W, x, 0.000001
End Sub
'通用的条件平差解算过程:输入系数矩阵A、权矩阵P、常数向量L和解向量X,求出X,并通过参数传出去
Public Sub CondiAdjust(b, P, W, V)
Dim b1%, b2%, p1%, p2%, w1%, v1% '输入矩阵或向量的大小
Dim Q#(), Bt#(), QBt#(), Nbb#(), K#(), i% '几个中间矩阵
'计算并检查输入矩阵或向量的大小
On Error Resume Next
b1 = UBound(b, 1) - LBound(b, 1) + 1
If Err Then
MsgBox "系数矩阵B大小错误!"
Exit Sub
End If
On Error Resume Next
b2 = UBound(b, 2) - LBound(b, 2) + 1
If Err Then
MsgBox "系数矩阵B大小错误!"
Exit Sub
End If
On Error Resume Next
w1 = UBound(W) - LBound(W) + 1
If Err Then
MsgBox "常数向量W大小错误!"
Exit Sub
End If
On Error Resume Next
v1 = UBound(V) - LBound(V) + 1
If Err Then
MsgBox "改正数向量V大小错误!"
Exit Sub
End If
On Error Resume Next
p1 = UBound(P, 1) - LBound(P, 1) + 1
If Err Then
MsgBox "权矩阵P大小错误!"
Exit Sub
End If
On Error Resume Next
p2 = UBound(P, 2) - LBound(P, 2) + 1
If Err Then
MsgBox "权矩阵P大小错误!"
Exit Sub
End If
If p1 <> p2 Then
MsgBox "权矩阵P不是方阵!"
Exit Sub
End If
If p1 <> b2 Then
MsgBox "权矩阵P与系数矩阵A大小不符!"
Exit Sub
End If
If b2 <> v1 Then
MsgBox "系数矩阵B大小与解向量V大小不符!"
Exit Sub
End If
If b1 <> w1 Then
MsgBox "系数矩阵B大小与常数向量W大小不符!"
Exit Sub
End If
'定义中间矩阵的大小
ReDim Bt(1 To b2, 1 To b1), QBt(1 To b2, 1 To b1)
ReDim Nbb(1 To b1, 1 To b1), K(1 To b1), Q(1 To p1, 1 To p2)
'组成法方程并计算
For i = 1 To p1 '求Q矩阵
Q(i, i) = 1 / P(i, i)
5 坐标转换的编程
Option Explicit
Dim k2#, e2#, dX2#, dY2# '尺度参数、旋转参数、两个平移参数
Dim x2#, Xx2#, y2#, Yy2# '二维坐标变换的正反数值
Dim k3#, Ex#, Ey#, Ez#, dX3#, dY3#, dZ3# '尺度参数、三个旋转参数、三个平移参数
Dim X3#, Y3#, Z3#, Xx3#, Yy3#, Zz3# '三维坐标转换的正算数值
Const PI = 3.14159265358979
Private Sub Check1_Click()
If Check1.Value = 1 Then
frmCoorTrans.Height = 5175
ElseIf Check1.Value = 0 Then
frmCoorTrans.Height = 4440
End If
End Sub
Open txtFileName.Text For Input As #1
Line Input #1, s
n = Val(s)
ReDim x1#(n), y1#(n), x2#(n), y2#(n)
For i = 1 To n
Line Input #1, s
iPos = InStr(s, ",")
x1(i) = Val(Left(s, iPos - 1))
s = Mid(s, iPos + 1)
iPos = InStr(s, ",")
y1(i) = Val(Left(s, iPos - 1))
s = Mid(s, iPos + 1)
iPos = InStr(s, ",")
x2(i) = Val(Left(s, iPos - 1))
s = Mid(s, iPos + 1)
y2(i) = Val(s)
Next i
Close #1
'计算转换参数
ReDim A(1 To 2 * n, 1 To 4) As Double, L(1 To 2 * n) As Double
ReDim At(1 To 4, 1 To 2 * n), Naa(1 To 4, 1 To 4), W(1 To 4)
Debug.Print "系数矩阵A:"
For i = 1 To n '组成系数矩阵和常数向量
A(2 * i - 1, 1) = 1: A(2 * i - 1, 2) = 0: A(2 * i - 1, 3) = x1(i): A(2 * i - 1, 4) = y1(i)
Debug.Print A(2 * i - 1, 1), A(2 * i - 1, 2), A(2 * i - 1, 3), A(2 * i - 1, 4)
A(2 * i, 1) = 0: A(2 * i, 2) = 1: A(2 * i, 3) = y1(i): A(2 * i, 4) = -x1(i)
Debug.Print A(2 * i, 1), A(2 * i, 2), A(2 * i, 3), A(2 * i, 4)
L(2 * i - 1) = x2(i): L(2 * i) = y2(i)
Next i
Debug.Print "常数向量L:"
For i = 1 To 2 * n
Debug.Print L(i)
Next i
MatrixTrans A, At '求系数阵的转置矩阵
Debug.Print "A的转置矩阵:"
ShowMatrix At
Matrix_Multy Naa, At, A '求AtA
Debug.Print "Naa:"
ShowMatrix Naa
Matrix_Multy W, At, L '求AtL
Debug.Print "W:"
For i = 1 To 4
Debug.Print W(i)
Next i
MajorInColGuass Naa, W, x 'Guass约化法解线性方程组
Debug.Print "X"
For i = 1 To 4
Debug.Print x(i)
Next i
'分离旋转和尺度参数
If Abs(x(3)) < 0.00000001 Then
If x(4) > 0 Then
e2 = PI / 2
Else
e2 = PI * 3 / 2
End If