测量方位角计算公式VB源代码
坐标反算(VB编程代码)
计算△X，△Y 的值
若△X，△Y 有为零 的，则直接判断方位 角。
若△X，△Y 不为零， 则计算象限角 R。
由象限角判断方 位角
输出方位角α
坐标反Sub Command3_Click() Dim Xa, Ya, Xb, Yb, M, N, Rab, R, F, R1, R2, R3 As Single pi = 3.1415926 Xa = Text1.Text Ya = Text4.Text Xb = Text2.Text Yb = Text5.Text M = Xb - Xa '求纵坐标增量 N = Yb - Ya '求横坐标增量 Rab = Math.Atn(Abs(N / M)) * 180 / pi '计算象限角 If M > 0 And N > 0 Then F = Rab '由象限角判断方位角 If M < 0 And N > 0 Then F = 180 - Rab If M < 0 And N < 0 Then F = 180 + Rab If M > 0 And N < 0 Then F = 360 - Rab If M = 0 And N > 0 Then F = 90 If M = 0 And N < 0 Then F = 270 If N = 0 And M > 0 Then F = 0 If N = 0 And M < 0 Then F = 180 R1 = Fix(F) '把弧度化为度 R2 = Fix((F - R1) * 60) R3 = Fix((((F - R1) * 60) - R2) * 60) Text3.Text = R1 & "°" & R2 & "′" & R3 & "″" Text6 = Sqr(M ^ 2 + N ^ 2) End Sub Private Sub Command2_Click() Text1 = "" Text2 = "" Text3 = "" Text4 = "" Text5 = "" Text6 = "" End Sub
方位角的计算方法
方位角的计算方法有多种，根据公式与工具有不同，现有四种计算方法：一、测量教材上的计算方法，需要判断象限，对了解原理有一定帮助，但在实际工作中不太实用，在此不予介绍，使用此方法计算的VB或VBA代码如下：Public Const PI = 3.14159265359Function Pol（x1 As Double， y1 As Double， x2 As Double， y2 As Double） As Double '计算直线的方位角Dim Sub_y As DoubleSub_y = Abs（y2 - y1）If Sub_y = 0 ThenSub_y = 0.0000000001End IfPol = Atn（（Abs（x2 - x1）） / Sub_y）If x2 > x1 And y2 >= y1 Then '0-90ElseIf x2 < x1 And y2 <= y1 Then '180-270Pol = PI + PolElseIf x2 < x1 And y2 >= y1 Then '270-360Pol = 2 * PI - PolElseIf x2 >= x1 And y2 <= y1 Then '90-180Pol = PI - PolEnd IfEnd Function二、计算器上的pol（）函数，用pol（dx，dy）计算，返回两点间距离与方位角，如角度值为负+360即可，具体使用方法参照说明书上的pol（）函数介绍；三、方位角通用万能公式：此万能公式的VB或VBA代码如下：Public Const PI = 3.14159265359Function Pol（x1 As Double， y1 As Double， x2 As Double， y2 As Double） As Double '计算直线的方位角Dim Sub_x As DoubleSub_x = x2 - x1 + 0.0000000001Pol = PI - Sgn（Sub_x） * PI / 2 - Atn（（y2 - y1） / Sub_x）End Functionsgn（）函数为符号函数：sgn（x）的值只有三个：当x小于0时sgn（x）的值为-1当x大于0时sgn（x）的值为1当x等于0时sgn（x）的值为0计算器上没有此函数，在编程时可用下列代码实现此函数功能：if x<0 thensgn（x）=-1elseif x>0 thensgn（x）=1eslesgn（x）=0end if四、另一个通用公式：S12=sqr（（x2-x1）2+（y2-y1）2）= sqr（△x2+△y2）A12=arcsin（（y2-y1）/S12）S12为测站点1至放样点2的距离；A12为测站点1至放样点2的坐标方位角。
用（VB）实现测量坐标转换系统
⽤（VB）实现测量坐标转换系统坐标转换系统（VB）东华理⼯⼤学Theory 北京54⾼斯坐标转换西安80⾼斯坐标转换系统1.0版多点处理结果核⼼源代码：'⾼斯坐标转换成⼤地坐标过程Public Sub GausReverse(a As Double, f As Double, x() As Double, y() As Double, RB() As Double, RL() As Double, k As Integer)Dim i As Integer, fxb As Double, fxbl As Double, fybl As Doublee = Sqr(2 *f - f ^ 2)C = a / Sqr(1 - e ^ 2)e2 = e / Sqr(1 - e ^ 2)beita0 = 1 - (3 / 4) * e2 ^ 2 + (45 / 64) * e2 ^ 4 - (175 / 256) * e2 ^ 6 + (11025 / 16384) * e2 ^ 8 beita2 = beita0 - 1beita4 = (15 / 32) * e2 ^ 4 - (175 / 384) * e2 ^ 6 + (3675 / 8192) * e2 ^ 8beita6 = (-35 / 96) * e2 ^ 6 + (735 / 2048) * e2 ^ 8beita8 = (315 / 1024) * e2 ^ 8For i = 1 To kB0 = x(i) / (C * beita0)Dofxb = 0fxbl = 0fybl = 0t = Tan(B0)yita = e2 * Cos(B0)n = a / Sqr(1 - e ^ 2 * (Sin(B0)) ^ 2)a2 = (1 / 2) * n * Sin(B0) * Cos(B0)a3 = (1 / 6) * n * (Cos(B0)) ^ 3 * (1 - t ^ 2 + yita ^ 2)a4 = (1 / 24) * n * Sin(B0) * (Cos(B0)) ^ 3 * (5 - t ^ 2 + 9 * yita ^ 2 + 4 * yita ^ 4)a5 = (1 / 120) * n * (Cos(B0)) ^ 5 * (5 - 18 * t ^ 2 + t ^ 4 + 14 * yita ^ 2 - 58 * yita ^ 2 * t ^ 2) a6 = (1 / 720) * n * Sin(B0) * (Cos(B0)) ^ 5 * (61 - 58 * t ^ 2 + t ^ 4)fxb = fxb + (C * beita6 + C * beita8 * (Cos(B0)) ^ 2) * (Cos(B0)) ^ 2fxb = (fxb + C * beita4) * (Cos(B0)) ^ 2fxb = (fxb + C * beita2) * Sin(B0) * Cos(B0)fxbl = a2 * l0 ^ 2 + a4 * l0 ^ 4 + a6 * l0 ^ 6fybl = a3 * l0 ^ 3 + a5 * l0 ^ 5RB(i) = (x(i) - fxb - fxbl) / (C * beita0)a1 = (a * Cos(RB(i))) / Sqr(1 - e ^ 2 * (Sin(RB(i)) ^ 2))RL(i) = (y(i) - fybl) / a1If Abs(RB(i) - B0) <= 0.0000000001 And Abs(RL(i) - l0) <= 0.0000000001 ThenRL(i) = zrl + l0Exit DoElseB0 = RB(i)l0 = RL(i)End IfLoopNext iEnd Sub'⼤地坐标B，L转换为⾼斯坐标x,y的过程Public Sub BLHGaus(RB() As Double, RL() As Double, GX() As Double, GY() As Double, a As Double, f As Double, k As Integer)Dim l0 As Double, fxb As Double, gxbl As Double, fybl As Doublebeita0 = 1 - (3 / 4) * e2 ^ 2 + (45 / 64) * e2 ^ 4 - (175 / 256) * e2 ^ 6 + (11025 / 16384) * e2 ^ 8 beita2 = beita0 - 1beita4 = (15 / 32) * e2 ^ 4 - (175 / 384) * e2 ^ 6 + (3675 / 8192) * e2 ^ 8beita6 = (-35 / 96) * e2 ^ 6 + (735 / 2048) * e2 ^ 8beita8 = (315 / 1024) * e2 ^ 8For i = 1 To kl0 = RL(i) - zrln = a / Sqr(1 - e ^ 2 * (Sin(RB(i))) ^ 2)t = Tan(RB(i))yita = e2 * Cos(RB(i))a1 = (a * Cos(RB(i))) / Sqr(1 - e ^ 2 * (Sin(RB(i)) ^ 2))a2 = (1 / 2) * n * Sin(RB(i)) * Cos(RB(i))a3 = (1 / 6) * n * (Cos(RB(i))) ^ 3 * (1 - t ^ 2 + yita ^ 2)a4 = (1 / 24) * n * Sin(RB(i)) * (Cos(RB(i))) ^ 3 * (5 - t ^ 2 + 9 * yita ^ 2 + 4 * yita ^ 4) a5 = (1 / 120) * n * (Cos(RB(i))) ^ 5 * (5 - 18 * t ^ 2 + t ^ 4 + 14 * yita ^ 2 - 58 * yita ^ 2 * t ^ 2)a6 = (1 / 720) * n * Sin(RB(i)) * (Cos(RB(i))) ^ 5 * (61 - 58 * t ^ 2 + t ^ 4)fxb = 0fxbl = 0fybl = 0fxb = fxb + (C * beita6 + C * beita8 * (Cos(RB(i))) ^ 2) * (Cos(RB(i))) ^ 2fxb = (fxb + C * beita4) * (Cos(RB(i))) ^ 2fxb = (fxb + C * beita2) * Sin(RB(i)) * Cos(RB(i))fxbl = a2 * l0 ^ 2 + a4 * l0 ^ 4 + a6 * l0 ^ 6fybl = a3 * l0 ^ 3 + a5 * l0 ^ 5GX(i) = C * beita0 * RB(i) + fxb + fxblGY(i) = a1 * l0 + fyblNext iEnd Sub'三维直⾓坐标XYZ转换成⼤地坐标BLH过程Public Sub BLHXYZ1(SX() As Double, SY() As Double, SZ() As Double, RB() As Double, RL() As Double, RH() As Double, k As Integer, a As Double, f As Double)Dim i As IntegerDim N0 As Double, H0 As Double, B0 As Double, sb As Double, Ni As Doublesb = a * Sqr(1 - e ^ 2)pi = 4 * Atn(1)For i = 1 To kRL(i) = Atn(Abs(SY(i) / SX(i)))If SY(i) > 0 And SX(i) < 0 ThenRL(i) = pi - RL(i)End IfN0 = aH0 = Sqr(SX(i) ^ 2 + SY(i) ^ 2 + SZ(i) ^ 2) - Sqr(a * sb)B0 = Atn(SZ(i) / ((Sqr(SX(i) ^ 2 + SY(i) ^ 2)) * (1 - e ^ 2 * N0 / (N0 + H0))))DoNi = a / Sqr(1 - e ^ 2 * (Sin(B0)) ^ 2)RH(i) = Sqr(SX(i) ^ 2 + SY(i) ^ 2) / Cos(B0) - NiRB(i) = Atn(SZ(i) / ((Sqr(SX(i) ^ 2 + SY(i) ^ 2)) * (1 - e ^ 2 * Ni / (Ni + RH(i)))))If Abs(RB(i) - B0) < 0.0000000001 And Abs(RH(i) - H0) < 0.0000000001 ThenExit DoElseB0 = RB(i)H0 = RH(i)End IfLoopNext iEnd Sub'最⼩⼆乘法求解七参数布尔萨模型Public Sub SloveBuersa(XD() As Double, XG() As Double, R() As Double, k As Integer) Dim a0 As Double, a1 As Double, a2 As DoubleFor i = 1 To ka0 = XG(i, 1)a1 = XG(i, 2)a2 = XG(i, 3)Call Cjuzhen(a0, a1, a2, G())For j = 1 To 3Next sNext jNext iFor i = 1 To kFor j = 1 To 3LC(3 * (i - 1) + j) = XD(i, j) - XG(i, j) Next jNext iFor i = 1 To 3 * kFor j = 1 To 7ET(j, i) = EC(i, j)Next jNext iFor i = 1 To 7For j = 1 To 7CTC(i, j) = 0For s = 1 To 3 * kCTC(i, j) = CTC(i, j) + ET(i, s) * EC(s, j) Next sNext jNext iFor i = 1 To 7For j = 1 To 7CTC1(i, j) = CTC(i, j)Next jNext iCall Comm.Reverse(CTC(), 7)For i = 1 To 7CTL(i) = 0For j = 1 To 3 * kCTL(i) = CTL(i) + ET(i, j) * LC(j)Next jNext iFor j = 1 To 7R(i) = R(i) + CTC(i, j) * CTL(j)Next jNext iEnd Sub'布尔萨模型系数矩阵⼀部分Public Sub Cjuzhen(x As Double, y As Double, z As Double, D() As Double) For i = 1 To 3D(i, i) = 1Next iD(1, 4) = xD(1, 5) = 0D(1, 6) = -zD(1, 7) = yD(2, 4) = yD(2, 5) = zD(2, 6) = 0D(2, 7) = -xD(3, 4) = zD(3, 5) = -yD(3, 6) = xD(3, 7) = 0End Sub'使⽤七参数求解新坐标系下的坐标Public Sub UseBuersa(XD() As Double, XG() As Double, EC() As Double, R() As Double, k As Integer) Dim a1 As Double, a2 As Double, a3 As Double, CR(1000) As DoubleFor i = 1 To ka1 = XG(i, 1)a2 = XG(i, 2)a3 = XG(i, 3)Call Cjuzhen(a1, a2, a3, G())For j = 1 To 3For s = 1 To 7EC(3 * (i - 1) + j, s) = G(j, s)Next iFor i = 1 To 3 * kCR(i) = 0For j = 1 To 7CR(i) = CR(i) + EC(i, j) * R(j)Next jNext iFor i = 1 To kFor j = 1 To 3XD(i, j) = XG(i, j) + CR(3 * (i - 1) + j)Next jNext iEnd Sub'弧度化为度分秒'弧度化成⾓度Public Sub RuJiao(ByVal rudu As Double, jiaodu As Double) Dim ja As Integer, jb As Integer, jc As Double pi = 4 * Atn(1)jiaodu = rudu * 180 / pija = Fix(jiaodu)jb = Fix((jiaodu - ja) * 60)jc = ((jiaodu - ja) * 60 - jb) * 60jiaodu = ja + jb / 100 + jc / 10000End Sub'矩阵求逆Public Sub Reverse(Ba, n%)Dim k%, K1%, j%, i%Dim C As Double, Aa(100, 200)For i = 1 To nFor j = 1 To nAa(i, j) = Ba(i, j)Next jNext iFor i = 1 To nAa(i, j + n) = 0End IfNext jNext iFor k = 1 To nFor j = k To nIf Aa(j, k) <> 0 Then GoTo 200Next jMsgBox "逆矩阵不存在": Exit Sub 200: For i = 1 To 2 * n C = Aa(k, i)Aa(k, i) = Aa(j, i)Aa(j, i) = CNext iC = 1 / Aa(k, k)For j = 1 To 2 * nAa(k, j) = C * Aa(k, j)Next jFor K1 = 1 To nIf K1 <> k ThenC = -Aa(K1, k)For j = 1 To 2 * nAa(K1, j) = Aa(K1, j) + C * Aa(k, j)Next jEnd IfNext K1Next kFor i = 1 To nFor j = n + 1 To 2 * nAa(i, j - n) = Aa(i, j)Next jNext iNext iEnd Sub'⾓度化成弧度Public Sub JiaoHu(ByVal jiaodu As Double, hudu As Double) Dim ja As Double, jb As Double, jc As Double pi = 4 * Atn(1)ja = Fix(jiaodu)jb = Fix((jiaodu - ja) * 100)jc = ((jiaodu - ja) * 100 - jb) * 100jiaodu = ja + jb / 60 + jc / 3600hudu = jiaodu * pi / 180End Sub。
VB测量程序设计
实验报告课程名称：测量程序设计任课老师：段伟姓名：王森学号：1476210082016年12月24日综合实验设计：窗体及代码如下7Part1：封面代码：Private Sub Timer1_Timer()Label1.Left = Label1.Left + 100If Label1.Left + Label1.Width > frmCover.Width ThenTimer2.Enabled = True: Timer1.Enabled = FalseEnd IfEnd SubPrivate Sub Timer2_Timer()Label1.Left = Label1.Left - 100If Label1.Left < 0 ThenTimer1.Enabled = True: Timer2.Enabled = FalseEnd IfEnd SubPrivate Sub Timer3_Timer()Label7.Caption = NowEnd SubPrivate Sub cmdEnter_Click()If i > 2 ThenMsgBox "您已输错密码超过三次，程序将关闭!", , "输入次数超限"EndEnd IfIf txtUserName.Text = "admire" And txtPassWord.Text = "1111" ThenFormMain.Show: Unload MeElseMsgBox "密码错误,请从新输入!" & vbCrLf & "还有" & Str(4 - i) & "次机会!", , "密码错误"txtPassWord.Text = "": txtPassWord.SetFocus: i = i + 1End IfEnd SubPrivate Sub cmdExit_Click() EndEnd SubPart2：主函数代码：Private Sub cmdExit_Click() EndEnd SubPrivate Sub cmdH_Click() FormMain.Hide: frmH.Show End SubPrivate Sub cmdqh_Click() FormMain.Hide: frmqh.Show End SubPrivate Sub cmdS_Click() FormMain.Hide: frmMain.Show End SubPart3：方位角计算Dim iRound%, dblAngle() As Double, n%Const PI = 3.14159265Private Sub Command1_Click()Dim duLA%, fenLA%, miaoLA%, duLB%, fenLB%, miaoLB%, duRA%, fenRA%, miaoRA%, duRB%, fenRB%, miaoRB%Dim duHAL%, fenHAL%, miaoHAL%, duHAR%, fenHAR%, miaoHAR%, duWH%, fenWH%, miaoWH%Dim halfL As Double, halfR As Double, angle As DoubleduLA = Val(Text1.Text)fenLA = Val(Text2.Text)miaoLA = Val(Text3.Text)duLB = Val(Text4.Text)fenLB = Val(Text5.Text)miaoLB = Val(Text6.Text)duRA = Val(Text7.Text)fenRA = Val(Text8.Text)miaoRA = Val(Text9.Text)duRB = Val(Text10.Text)fenRB = Val(Text11.Text)miaoRB = Val(Text12.Text)halfL = (duLB - duLA) + (fenLB - fenLA) / 60 + (miaoLB - miaoLA) / 3600halfR = (duRB - duRA) + (fenRB - fenRA) / 60 + (miaoRB - miaoRA) / 3600If Abs(halfL - halfR) * 3600 > 40 ThenMsgBox "半测回差超限，请检查观测和输入是否正确！", , "角差超限"Exit SubEnd Ifangle = (halfL + halfR) / 2duHAL = Int(halfL)halfL = (halfL - duHAL) * 60fenHAL = Int(halfL)halfL = (halfL - fenHAL) * 60miaoHAL = Int(halfL + 0.5)duHAR = Int(halfR)halfR = (halfR - duHAR) * 60fenHAR = Int(halfR)halfR = (halfR - fenHAR) * 60miaoHAR = Int(halfR + 0.5)duWH = Int(angle)angle = (angle - duWH) * 60fenWH = Int(angle)angle = (angle - fenWH) * 60miaoWH = Int(angle + 0.5)Text13.Text = Str(duHAL)Text14.Text = Str(fenHAL) Text15.Text = Str(miaoHAL) Text16.Text = Str(duHAR)Text17.Text = Str(fenHAR) Text18.Text = Str(miaoHAR) Text19.Text = Str(duWH)Text20.Text = Str(fenWH)Text21.Text = Str(miaoWH) End SubPrivate Sub Command2_Click() Text1.Text = ""Text2.Text = ""Text3.Text = ""Text4.Text = ""Text5.Text = ""Text6.Text = ""Text7.Text = ""Text8.Text = ""Text9.Text = ""Text10.Text = ""Text11.Text = ""Text12.Text = ""Text13.Text = ""Text14.Text = ""Text15.Text = ""Text16.Text = ""Text17.Text = ""Text18.Text = ""Text19.Text = ""Text20.Text = ""Text21.Text = ""Text1.SetFocusEnd SubPrivate Sub Command3_Click() EndEnd SubPrivate Sub Command4_Click() n = Val(Text22.Text)ReDim dblAngle(1 To n) As DoubleCommand2_ClickiRound = iRound + 1Label28.Visible = TrueLabel28.Caption = "正在输入第1个测回，共" & Trim(Str(n)) & "个。
VB报告(坐标正反算使用说明)
一、输入界面1.单击VB中的“运行”快捷键，弹出图1所示的运行界面图12.在图1中选择按钮，进入坐标正算模式，如图2图2在图2中输入已知点坐标、已知点至未知点的边长和坐标方位角、保留的小数位数，点名可不输入，输入完后，选择“计算”按钮。
如要计算多个点坐标，则计算完一个点后用鼠标单击“刷新”按钮，重复以上操作即可。
若想退出坐标正算功能，用鼠标左键单击“退出”按钮，在弹出的提示框中选择“是”，如图3图33. 在图1中选择按钮，进入坐标反算模式，如图4图4在图4中输入两个已知点坐标、保留的小数位数，点名可不输入，输入完后，选择“计算”按钮。
如要计算多个点坐标，则计算完一个点后用鼠标单击“刷新”按钮，重复以上操作即可。
若想退出坐标反算功能，用鼠标左键单击“退出”按钮，在弹出的提示框中选择“是”，如图3二、输入，输出数据表格中的方位角以小数的形式输入，例如“321°18′56″“的输入格式为321.1856，若度数为321°18′56.5″的输入格式为321.18565，坐标的保留位数保留三位，别的以此类推方位角以小数的形式输入，例如“164°02′02″”的输入格式为164.0202，若度数为164°02′02.5″的输入格式为164.02025，表格中的方位角的小数保留位数为0位三、源代码Private Sub Command1_Click()If Option1.Value = True And Option2.Value = False Thenzhengsuan '当选择坐标正算按钮时调用坐标正算程序End IfIf Option1.Value = False And Option2.Value = True Thenfansuan '当选择坐标反算按钮时调用坐标反算程序End IfEnd Sub'坐标正算程序Private Sub zhengsuan()Dim s As DoubleDim a As DoubleDim x As DoubleDim y As DoubleDim m As DoubleDim n As DoubleDim degree As DoubleDim minute As DoubleDim second As DoubleDim rad As DoubleDim bbt As IntegerDim result As DoubleDim p As Doubles = Val(Text5.Text)a = Val(Text6.Text)Rad_do a, degree, minute, second, rad '调用将度分秒转化为弧度的程序x = Val(Text2.Text) + s * Cos(rad)y = Val(Text3.Text) + s * Sin(rad)p = Fix(x)x = x - pbbt = Val(Text4.Text)Sheru m, n, bbt, x, result '调用奇进偶舍程序Label12.Caption = result + pp = Fix(y)y = y - pSheru m, n, bbt, y, result '调用奇进偶舍程序Label13.Caption = result + pEnd Sub'坐标反算程序Private Sub fansuan()Dim s As DoubleDim x As DoubleDim y As DoubleDim sing As DoubleDim m As DoubleDim n As DoubleDim f As DoubleDim result As DoubleDim bbt As IntegerDim degree As DoubleDim minute As DoubleDim second As DoubleDim rad As DoubleDim p As Doublex = Val(Text5.Text)y = Val(Text6.Text)m = y - Val(Text3.Text)n = x - Val(Text2.Text)If n <> 0 Thenm = m / nrad = Atn(m)sing = Sgn(rad)End Ifdegree_m_s degree, minute, second, rad '调用将弧度转化为度分秒的程序bbt = Val(Text8.Text)m = second * 10 ^ bbtp = Fix(second)second = second - pSheru m, n, bbt, second, result '调用奇进偶舍程序second = result + pfangweijiao degree, minute, second, (x - Val(Text2.Text)), (y - Val(Text3.Text)), sing '调用计算坐标方位角的程序zhuanhua minute, second, degreesecond = second * 10 ^ bbtLabel13.Caption = degree & "." & minute & secondIf minute < 10 ThenLabel13.Caption = degree & "." & "0" & minute & secondEnd IfIf second < 10 ^ (bbt + 1) ThenLabel13.Caption = degree & "." & minute & "0" & secondEnd IfIf minute < 10 And second < 10 ^ (bbt + 1) ThenLabel13.Caption = degree & "." & "0" & minute & "0" & secondEnd If'计算边长Ss = (y - Val(Text3.Text)) ^ 2 + (x - Val(Text2.Text)) ^ 2s = Sqr(s)bbt = Val(Text4.Text)p = Fix(s)s = s - pSheru m, n, bbt, s, result '调用奇进偶舍程序Label12.Caption = result + pEnd Sub'将度分秒化为弧度Private Sub Rad_do(ByVal a As Double, ByVal degree As Double, ByVal minute As Double, ByVal second As Double, ByRef rad As Double)degree = a \ 1a = a - Fix(a)minute = Fix(a * 100)second = (a * 100 - minute) * 100rad = (3600 * degree + 60 * minute + second) / 206264.8063End Sub'将弧度转化为度分秒的程序Private Sub degree_m_s(ByRef degree As Double, ByRef minute As Double, ByRef second As Double, ByRef rad As Double)rad = rad * 180 / 3.1415926535degree = rad \ 1rad = (rad - degree) * 60minute = rad \ 1second = (rad - minute) * 60End Sub'奇进偶舍程序Private Sub Sheru(ByVal m As Double, ByVal n As Double, ByVal bbt As Double, ByVal x As Double, ByRef result As Double)m = x * 10 ^ bbtn = m - m \ 1If n < 0.5 Thenresult = (m \ 1) / 10 ^ bbtElseIf n > 0.5 Thenresult = (m \ 1 + 1) / 10 ^ bbtElseIf (m \ 1) Mod 2 Thenresult = (m \ 1 + 1) / 10 ^ bbtElseresult = (m \ 1) / 10 ^ bbtEnd IfEnd IfEnd Sub'计算坐标方位角的程序Private Sub fangweijiao(ByRef degree As Double, ByRef minute As Double, ByRef second As Double, ByVal m, ByVal n As Double, ByVal sing As Integer)Dim i As IntegerIf sing = 1 ThenIf n < 0 And m < 0 Thendegree = degree + 180End IfElseIf sing = -1 ThenIf n > 0 And m < 0 Thendegree = degree + 179minute = minute + 59second = second + 60ElseIf n < 0 And m > 0 Thendegree = degree + 359minute = minute + 59second = second + 60End IfEnd Ifi = Sgn(n)If m <> 0 ThenIf m < 0 And n = 0 Thendegree = "180"ElseIf m > 0 And n = 0 Thendegree = "0"End IfElseIf i = 1 Thendegree = "90"ElseIf i = -1 Thendegree = "270"ElseMsgBox "您输入了两个相同的点，请重新输入！"End IfEnd IfEnd Sub'当分秒超过60时须向上一级进位及方位角度数超过360°须减360°的程序Private Sub zhuanhua(ByRef minute As Double, ByRef second As Double, ByRef degree As Double)If second >= 60 Thenminute = minute + 1second = second - 60ElseIf second < 0 Thenminute = minute - 1second = second + 60End IfIf minute >= 60 Thendegree = degree + 1minute = minute - 60ElseIf minute < 0 Thendegree = degree - 1minute = minute + 60End IfIf degree >= 360 Thendegree = degree - 360End IfEnd Sub'退出程序Private Sub Command3_Click()If MsgBox("是否退出？", vbYesNo, "提示") = vbYes ThenUnload MeEnd IfEnd Sub'刷新程序Private Sub Command4_Click()Text2.Text = ""Text3.Text = ""Text4.Text = 3Text5.Text = ""Text6.Text = ""Text8.Text = 1Label12.Caption = ""Label13.Caption = ""End Sub'设置窗体的大小，使窗体充满整个屏幕并对label6和label7赋值Private Sub Form_Load()Me.Height = Screen.HeightMe.Width = Screen.WidthMe.Left = 0Me.Top = 0Label6.Caption = "边长（S）"Label7.Caption = "方位角（a）"Label17.Caption = "陈亮编程"Label18.Caption = " 2011.09.05"End Sub'设置坐标正算时Label6.Caption和Label7.Caption的值及设计小数点位数Private Sub Option1_Click()If Option1.Value = True And Option2.Value = False ThenLabel14.Caption = Text1.Text & "—>未知点" & Text7.TextLabel6.Caption = "边长（S）"Label7.Caption = "方位角（a）"Label10.Caption = "X"Label11.Caption = "Y"Text4.Text = 3Text8.Text = 1End IfEnd Sub''设置坐标反算时Label0.Caption和Label1.Caption的值及设计小数点位数Private Sub Option2_Click()If Option1.Value = False And Option2.Value = True ThenLabel6.Caption = "X"Label7.Caption = "Y"Label14.Caption = ""Label10.Caption = "边长（S）"Label11.Caption = "方位角（a）"Text4.Text = 3Text8.Text = 1End IfEnd Sub。
教你如何通过ExcelVBA编写测量坐标计算程序
教你如何通过ExcelVBA编写测量坐标计算程序（入门篇）摘要：认识VBA、理解VBA，并利用Office Excel VBA编写测量坐标计算程序。
关键词：Excel VBA 程序坐标编写了解：VBA是什么？简单的说就是一种自动化语言，它可以使常用的程序自动化,可以创建自定义的解决方案。
可以用E xcel的宏语言来使E xcel自动化运行等……Microsoft让它开发出来的应用程序共享一种通用的自动化语言——Visual Basic For Application(VBA)，可以认为VBA是非常流行的应用程序开发语言Visual Basic的子集，事实上VBA是VB应用程序的版本，尽管存在有些不同VBA和VB在结构上仍然十分相似。
如果你已经了解VB会发现学习VBA非常快。
相应的学完VBA会给学习VB打下坚实的基础。
理由：选择Excel VBA编程的理由是因为它的计算功能非常强大，是现今任何编程计算器无法逾越的。
它运用范围广，计算速度快，计算精度高，合理化显示等。
或许很多测量人员对Excel VBA还有些陌生，主要是大家寄托于计算器、电脑、手机PDA等系列软件使用。
Excel VBA对于大多数测量人员而没有系统学过计算机语言程序设计的人群来讲有一定含糊，不过只要有基本数学知识、测量常识和逻辑理解的人，都能通过Excel VBA编写设计出称心如意的测量程序。
目标：基于Excel VBA的测量坐标计算程序的设计目标是将繁琐计算过程转入到计算机中，利用程序语言的重复性原理，在计算机中可将坐标计算得出更精确的结果，使坐标计算更加可靠。
最终目标是让用户可以通过Excel VBA自行完成坐标计算程序设计。
认识：学习VBA到底需要什么基础和了解些什么？学习VBA需要认识英文字母、一般的单词（如：函数所用的过程）、数学基础知识、测量常识、逻辑性思维即可。
在VBA中需要了解VBA的过程、变量、属性、方法、事件、语句等。
方位角计算程序范文
方位角计算程序范文方位角是指物体相对于参考方向的角度。
在地球上，常用的参考方向是北。
在计算方位角时，需要知道物体的经纬度以及参考方向的经纬度。
以下是一个计算方位角的程序示例，使用Python语言编写：```pythonimport math#计算两个经纬度之间的距离def calculate_distance(lat1, lon1, lat2, lon2):R=6371#地球半径，单位为公里lat1_rad = math.radians(lat1)lon1_rad = math.radians(lon1)lat2_rad = math.radians(lat2)lon2_rad = math.radians(lon2)dlon = lon2_rad - lon1_raddlat = lat2_rad - lat1_rada = math.sin(dlat/2)**2 + math.cos(lat1_rad) *math.cos(lat2_rad) * math.sin(dlon/2)**2c = 2 * math.atan2(math.sqrt(a), math.sqrt(1-a))distance = R * creturn distance#计算方位角def calculate_bearing(lat1, lon1, lat2, lon2):lat1_rad = math.radians(lat1)lon1_rad = math.radians(lon1)lat2_rad = math.radians(lat2)lon2_rad = math.radians(lon2)dlon = lon2_rad - lon1_rady = math.sin(dlon) * math.cos(lat2_rad)x = math.cos(lat1_rad) * math.sin(lat2_rad) - math.sin(lat1_rad) * math.cos(lat2_rad) * math.cos(dlon) bearing = math.degrees(math.atan2(y, x))return bearing#示例使用lat1 = 39.9075lon1 = 116.3972lat2 = 31.2304lon2 = 121.4737distance = calculate_distance(lat1, lon1, lat2, lon2)bearing = calculate_bearing(lat1, lon1, lat2, lon2)print("距离：", distance, "公里")print("方位角：", bearing, "度")```在这个示例中，我们使用了Haversine公式计算两个经纬度之间的距离，并使用反三角函数计算方位角。
坐标正算、反算计算方法及在Excel中的VBA编程
坐标正算、反算计算方法及在Excel 中的VBA 编程测量中经常需要将某点相对坐标系坐标转换成线路的里程、偏距，或根据线路某一里程偏距计算出对应的相对坐标系坐标，为寻求一种快速简单高效的计算方法，本文对线路正算反算的原理进行了阐述，并结合Excel VBA 编程，将编程和Excel 的拖拽的功能相结合，编制出实用计算表，特别适用于需要大量计算边桩、围护桩的情况。
关键词：坐标方位角坐标正算坐标反算 V AB 编程循环迭代直接算法一、坐标方位角的反算1.坐标方位角反算如图1所示，已知点A 、B 的坐标，求直线AB坐标方位角α。
图1坐标方位角反算直线AB 之间的坐标增量：AB B AAB B Ax x x y y y ∆=−∆=−当0,0AB AB x y ∆>∆>时，角α位于第一象限角：arctan ABABy x α∆=∆当0,0AB AB x y ∆<∆>时，角α位于第二象限角：arctan 180AB ABy x α∆=+°∆当0,0AB AB x y ∆<∆<时，角α位于第三象限角：arctan 180AB ABy x α∆=+°∆当0,0AB AB x y ∆>∆<时，角α位于第二象限角：arctan360AB AB y x α∆=+°∆2.坐标方位角反算的VBA 编程可用VBA 将上述过程定义为一个名为angel()的函数，代码如下：Function angel(x0As Double, y0 As Double, x1 As Double, y1 As Double) As Double dx = x1- x0dy = y1- y0If dx > 0 And dy > 0 Thenangel = Atn(dy / dx)End IfIf dx < 0 And dy > 0 Thenangel = Atn(dy / dx) + 3.14159265358979End IfIf dx < 0 And dy < 0 Thenangel = Atn(dy / dx) + 3.14159265358979End IfIf dx > 0 And dy < 0 Thenangel = Atn(dy / dx) + 3.14159265358979 * 2End IfEnd Function二、直线段坐标正算与反算1.直线段正算图2直线段计算已知HZ 点坐标（x1,y1）、里程N HZ ，ZH 点坐标（x2,y2），正算时已知P 点对应的中桩里程Np 和偏距e （规定沿着线路前进方向，左边偏距为负，右边偏距为正），Np>N HZ ，求P 点对应的坐标。
公路测量计算程序VB源代码(好用,我花了5天编的)用了七年
Dim fso As New FileSystemObject, ts As TextStream, Fl As File, fname As StringDim jd(100, 5) As Double, jdy(100, 2) As Double, zjd As Integer, ld(100000, 3) As Double, zld As LongConst pi = 3.1415926Dim ls As Double, r As DoubleDim gll As Double, gx As Double, gy As Double, gzx As Double, gzy As Double, gyx As Double, gyy As DoubleDim th As Double, lh As Double, ly As Double, eh As Double, b0 As Double, p As Double, q As DoubleDim jdl As Double, zhl As Double, hyl As Double, yhl As Double, hzl As Double, qzl As DoubleDim xx() As Double, Y() As Double, zx() As Double, zy() As Double, yx() As Double, yy() As DoublePrivate Sub cd1_Click(Index As Integer)Dim tr() As String, m(10) As Integer '定义过程级变量Dim i As Integer, j As Integer, k As Integer, h As IntegerCommonDialog1.ShowOpenfname = CommonDialog1.FileName '将用户在"打开"对话框中选择的文件名对变量fname赋值If fname <> "" Then '若无此判断当对话框中选择取消时、下面赋值语句将出错Set ts = fso.OpenTextFile(fname) '将fname作为文本文件打开,并设置句柄j = 0: k = 0: p = 0: h = 0'j是测站数累计变量,k是已知点累计变量,l（j）、ns（j）分别是方向值、边长累积计数Do While ts.AtEndOfLine <> True '前测型循环，进入循环的条件是没有读到文件结束尾b = ts.ReadLine '读一行，置入bb = Trim(b): i = 1: '删除B可能有的前导和尾随空格，i是工作变量， m(i) = InStr(b, ",") '查行中第一个逗号的左数位置,并保存在整形数组变量m(i)中ReDim tr(10)Do While m(i) <> 0 '前测型Do... Loop循环，成立条件是该行字符串中有逗号tr(i) = Mid(b, m(i - 1) + 1, m(i) - m(i - 1) - 1) '提取指定位置开始的指定数目字符。
vb坐标方位角算法流程
vb坐标方位角算法流程
计算两个地点之间的方位角（或方向角）可以使用以下算法流程：
1. 获取两个地点的经纬度坐标。
假设地点A的经纬度坐标为（lonA，latA），地点B的经纬度坐标为（lonB，latB）。
2. 将经纬度坐标转换为弧度表示。
使用以下公式：
radLonA = lonA * (PI / 180)
radLatA = latA * (PI / 180)
radLonB = lonB * (PI / 180)
radLatB = latB * (PI / 180)
3. 计算方位角。
使用以下公式：
dLon = radLonB - radLonA
y = sin(dLon) * cos(radLatB)
x = cos(radLatA) * sin(radLatB) - sin(radLatA) * cos(radLatB) * cos(dLon)
angle = atan2(y, x)
4. 将方位角转换为度数表示。
使用以下公式：
angleDegrees = angle * (180 / PI) + 360 (取模 360)
注意：以上算法中，PI代表圆周率，atan2函数返回的角度范围是[-PI, PI]，需转换为[0, 360]的度数表示。
这个算法可以计算地球上两个地点之间的方位角。
请注意，这只是一个简单的算法，不考虑地球的形状和其他因素，可能在极端情况下存在一定的误差。
对于更精确的计算，需要考虑使用更复杂的模型和算法。
两点经纬度计算方位角（VBA代码）
两点经纬度计算⽅位⾓（VBA代码）⽰例Excel⽂件下载链接地址如下：由两点经纬度计算⽅位⾓是⽆线⽹络优化中经常遇到的情况，下⾯给出Point2Azimuth()函数的VBA代码实现。
Sub Sample_Point2Azimuth()Dim lon_A As Double, lat_A As Double, lon_B As Double, lat_B As DoubleFinalRow_B = Sheets("程序⽰例").Cells(Rows.Count, 2).End(xlUp).RowSheets("程序⽰例").Range("D2", "D" & FinalRow_B).ClearContentsFor i = 2To FinalRow_Blon_A = Sheets("程序⽰例").Cells(1, "G").Valuelat_A = Sheets("程序⽰例").Cells(1, "H").Valuelon_B = Sheets("程序⽰例").Cells(i, "B").Valuelat_B = Sheets("程序⽰例").Cells(i, "C").ValueSheets("程序⽰例").Cells(i, "D").Value = Point2Azimuth(lon_A, lat_A, lon_B, lat_B)Next iEnd SubFunction Point2Azimuth(lon_A As Double, lat_A As Double, lon_B As Double, lat_B As Double)'其中A为原始点，B为⽬标点。
太阳高度角方位角计算的代码
太阳高度角方位角计算的代码太阳高度角和方位角是计算太阳位置的两个重要参数。
在地球上，太阳的高度角是指太阳光线与地面之间的夹角，而方位角是指太阳光线在水平面上投影与正北方向的夹角。
下面是一个用Python编写的简单程序，用于计算给定时间和地点的太阳高度角和方位角。
pythonimport mathimport datetime# 获取当前时间now = datetime.datetime.now()# 定义经纬度latitude = 39.9042 # 北纬39.9042度longitude = 116.4074 # 东经116.4074度# 计算太阳赤纬角def solar_declination(date):month = date.monthday = date.dayif month in [1, 2, 3]:declination = 23.45 * math.sin((284 + day) * math.pi / 365)elif month in [4, 5, 6]:declination = 23.45 * math.sin((281 + day) * math.pi / 365)elif month in [7, 8, 9]:declination = 23.45 * math.sin((287 + day) * math.pi / 365)elif month in [10, 11, 12]:declination = 23.45 * math.sin((278 + day) * math.pi / 365)return declination# 计算时角def hour_angle(hour):return hour * (math.pi / 12) - (11 * math.pi / 360)# 计算太阳高度角和方位角def solar_azimuth_and_elevation(latitude, longitude, declination, hour): time_angle = hour_angle(hour) + longitude * (math.pi / 180) / 15elevation = math.degrees(math.asin(math.sin(math.radians(latitude)) * math.sin(math.radians(declination)) + math.cos(math.radians(latitude)) * math.cos(math.radians(declination)) * math.cos(time_angle)))azimuth = math.degrees(math.acos(((math.sin(math.radians(latitude)) * math.sin(time_angle)) - math.sin(math.radians(declination)) / (math.cos(math.radians(latitude)) * math.cos(time_angle))))if time_angle > 0:azimuth = 360 - azimuthreturn azimuth, elevation# 日期和时间格式化date_str = now.strftime("%Y-%m-%d")time_str = now.strftime("%H:%M:%S")date = datetime.datetime.strptime(date_str, "%Y-%m-%d")time = datetime.datetime.strptime(time_str, "%H:%M:%S")hour = time.hour + time.minute / 60 + time.second / 3600solar_declination_angle = solar_declination(date)azimuth, elevation = solar_azimuth_and_elevation(latitude, longitude, solar_declination_angle, hour)print("日期：", date_str)print("时间：", time_str)print("太阳方位角：", azimuth)print("太阳高度角：", elevation)。
测量方位角计算公式VB源代码
测量方位角计算公式VB源代码角度化弧度Public Function Radian(a As Double) As DoubleDim Ra As DoubleDim c As DoubleDim FS As DoubleDim Ib As IntegerDim Ic As IntegerRa = pi / 180#Ib = Int(a)c = (a - Ib) * 100#Ic = Int(c)FS = (c - Ic) * 100#Radian = (Ib + Ic / 60# + FS / 3600#) * RaEnd Function'弧度化角度Public Function Degree(a As Double) As DoubleDim B As DoubleDim Fs1 As DoubleDim Im1 As IntegerDim Id1 As IntegerB = aCall DMS(B, Id1, Im1, Fs1)Degree = Id1 + Im1 / 100# + Fs1 / 10000#End FunctionPublic Sub DMS(a As Double, ID As Integer, IM As Integer, FS As Double) Dim B As DoubleDim c As Doublec = ac = 180# / pi * cID = Int(c + 0.0000005)B = (c - ID) * 60 + 0.0005IM = Int(B)FS = (B - IM) * 60End Sub'计算两点间的方位角Public Function azimuth(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As SingleDim dx As DoubleDim dy As DoubleDim fwj As Doubledx = x2 - x1dy = y2 - y1If dy <> 0 Thenfwj = pi * (1 - Sgn(dy) / 2) - Atn(dx / dy) azimuth = Degree(fwj)ElseIf dx > 0 Thenazimuth = 0Elseazimuth = 180End IfEnd IfEnd Function5.2程序字母代表含义La—起点里程，R—圆曲线半径，l0—两端缓和曲线长，α—曲线转向角，T—切线长，L—曲线长，E0—外矢距，q—切曲差，cc—线路转向（cc=1时，线路向右转；cc=-1时，线路向左转）,d―桩距，m―边桩距，Li―i点的里程，ZH―直缓点，HY―缓圆点，JD―交点，QZ―曲中点，YZ―圆直点，YH―圆缓点，HZ―缓直点，LJD—交点里程，LZH―直缓点里程，LHY―缓圆点里程，LQZ―曲中点里程，LYH―圆缓点里程，LHZ―缓直点里程。
VB编程在坐标计算中的应用
VB编程在坐标计算中的应用摘要：在实际的测量工作中，经常遇到要计算坐标和方位角，这些计算公式比较复杂，过程繁琐，如果靠手工计算，计算效率低下，容易出错，而且费时间，如果利用VB编程进行计算，将大大提高计算速度、计算效率和准确性，本文通过一个用来计算测点坐标和高程的VB程序实例，工程技术人员从繁重的手工计算中解脱出来。
关键词：VB，测量，坐标，方位角一、引言1991年，Visual Basic(简称VB)面世，它是第三代BASIC语言，它不但秉承了BASIC语言的易学易用的优点，而且增加了图形界面设计工具。
它简化了复杂的窗口程序编写过程，让编程者将更多的精力致力于问题的求解过程。
本文通过一个用来计算测点坐标和高程的VB程序实例，使工程技术人员从繁重的手工计算中解脱出来，提高了计算的准确性和快速性。
二、与坐标计算相关的公式1、坐标正算：根据已知点坐标、已知点边长和坐标方位角计算未知点坐标。
2、坐标反算：有两个已知点的坐标反算坐标方位角和边长。
边的坐标方位角可根据两端点的已知坐标反算出，这种方法称为坐标反算。
设A、B为两个已知点，其坐标分别为（,）和（,）则可得：式中，=-；=-。
边长可以用下式计算：DAB=求得的可在四个象限之内，它由和的正负符号确定，计算时应注意按下列关系区分：（1）当＞0且≥0时（2）当＝0且＞0时（3）当＝0且＜0（4）当＜0时（5）当＞0时且＜0时：三、工程实例下面例举一个在VB6.0中开发的碎部点计算程序。
1、界面及界面参数设计：在工程时间运用中，一般遇到两种情况，一是仅计算结果，不保存数据，二是不但计算结果，而且要保存数据。
所以在程序运行的时候应该提供这两种选择。
界面设计如下图（1）所示，另外就根据实际工作中的已知数据，设计界面参数，文件格式设计为一般格式和南方Cass格式，当然用户可以根据实际需要设置其它格式。
高程的输入方式可以是直接输入高程数据或者根据高差来计算高差。
《坐标方位角及距离计算小程序》代码——Access实现
公用模块：Option ExplicitPublic Const PI = 3.14159265358979'已知A、B两点坐标计算方位角，JSFWJ的中文意思是计算方位角Public Function JSFWJ(xa As Double, ya As Double, xb As Double, yb As Double) As Double '已知A、B两点坐标计算方位角函数过程Dim vx As Double, vy As Doublevx = xb - xa: vy = yb - ya'如果A、B两点坐标相同，出现提示对话框If vx = 0 And vy = 0 ThenMsgBox "您选择的是同一个点！", vbOKOnly + vbExclamation, "提示信息"JSFWJ = 999999999#End If'计算方位角的值If vx = 0 And vy > 0 Then '与y轴正半轴平行JSFWJ = RadianToAngle(PI / 2#)ElseIf vx = 0 And vy < 0 Then '与y轴负半轴平行JSFWJ = RadianToAngle(PI * 3# / 2#)ElseIf vy = 0 And vx > 0 Then '与x轴正半轴平行JSFWJ = RadianToAngle(0)ElseIf vy = 0 And vx < 0 Then '与x轴负半轴平行JSFWJ = RadianToAngle(PI)ElseIf vx > 0 And vy > 0 Then '第一象限JSFWJ = RadianToAngle(Atn(vy / vx))ElseIf vx < 0 And vy > 0 Then '第二象限JSFWJ = RadianToAngle(Atn(vy / vx) + PI)ElseIf vx < 0 And vy < 0 Then '第三象限JSFWJ = RadianToAngle(Atn(vy / vx) + PI)ElseIf vx > 0 And vy < 0 Then '第四象限JSFWJ = RadianToAngle(Atn(vy / vx) + 2 * PI)End IfEnd Function'已知A、B两点坐标计算距离，JSJLS的中文意思是计算距离SPublic Function JSJLS(xa As Double, ya As Double, xb As Double, yb As Double) As DoubleDim vx As Double, vy As Doublevx = xb - xa: vy = yb - ya'如果A、B两点坐标相同，出现提示对话框If vx = 0 And vy = 0 ThenMsgBox "您选择的是同一个点！", vbOKOnly + vbExclamation, "提示信息"JSJLS = 99999999#End If'计算距离JSJLS = Sqr(vx * vx + vy * vy)End Function'弧度化角度Public Function RadianToAngle(ByVal alfa As Double) As DoubleDim alfa1 As Double, alfa2 As Doublealfa = alfa * 180# / PIalfa = alfa + 0.000000000000001alfa1 = Fix(alfa) + Fix((alfa - Fix(alfa)) * 60#) / 100#alfa2 = (alfa * 60# - Fix(alfa * 60#)) * 0.006RadianToAngle = alfa2 + alfa1End Function窗体模块：Option Explicit'//////////////////////////////////////////////////////简单计算/////////////////////////////////////////////////// Private Sub Form_Load()Me.txt_方位角= ""Me.txt_距离= ""Me.txt_Xa.SetFocusEnd SubPrivate Sub cmd_数据清空_Click()Me.txt_Xa =Null: Me.txt_Ya = NullMe.txt_Xb =Null: Me.txt_Yb = NullMe.txt_方位角= ""Me.txt_距离= ""Me.txt_Xa.SetFocusEnd SubPrivate Sub cmd_退出程序_Click()Dim A As IntegerA = MsgBox("确定要退出程序吗？", vbYesNo + vbQuestion, "温馨提示")If A = vbNo ThenExit SubElseDoCmd.CloseEnd IfEnd SubPrivate Sub cmd_计算_Click()Dim xa As Double, ya As Double, xb As Double, yb As Double, FWJ As Double, S As DoubleIf IsNull(Me.txt_Xa) Or IsNull(Me.txt_Ya) Or IsNull(Me.txt_Xb) Or IsNull(Me.txt_Yb) ThenMsgBox "请输入完整数据！！！", vbOKCancel + vbInformation, "提示"Me.txt_Xa.SetFocusMe.txt_方位角= ""Me.txt_距离= ""Elsexa = Me.txt_Xa: ya = Me.txt_Yaxb = Me.txt_Xb: yb = Me.txt_YbIf (xb - xa) = 0 And (yb - ya) = 0 ThenMsgBox "您选择的是同一个点！", vbOKOnly + vbExclamation, "提示信息"Me.txt_方位角= ""Me.txt_距离= ""ElseFWJ = JSFWJ(xa, ya, xb, yb)S = JSJLS(xa, ya, xb, yb)Me.txt_距离= Format(S, "0.0000")Me.txt_方位角= Format(FWJ, "0.00000000")End IfEnd IfEnd Sub'//////////////////////////////////////////////////////批量计算/////////////////////////////////////////////////// '打开要进行批量计算的数据表《计算前坐标数据》表Private Sub cmd_导入计算数据_Click()DoCmd.RunMacro "导入导出数据.导入计算数据"End SubPrivate Sub cmd_批量计算_Click()Dim JSXH As Integer '定义计算序号Dim QDname As String, ZDname As String '第一起点和终点点号'定义起点坐标（QDx和QDy）和终点坐标（ZDx和ZDy）Dim QDx As Double, QDy As Double, ZDx As Double, ZDy As DoubleDim Conn As ADODB.ConnectionDim rs1 As ADODB.RecordsetDim rs2 As ADODB.RecordsetDim rs3 As ADODB.RecordsetSet Conn = CurrentProject.ConnectionSet rs1 = New ADODB.RecordsetSet rs2 = New ADODB.RecordsetSet rs3 = New ADODB.Recordset'清空简单计算内容Me.txt_Xa = "": Me.txt_Ya = ""Me.txt_Xb = "": Me.txt_Yb = ""'清空《计算后方位角及距离数据》表，为计算后添加数据做准备rs3.Open "select * from 计算后方位角及距离数据", Conn, adOpenDynamic, adLockOptimisticrs3.MoveFirstDo While Not rs3.EOFrs3.Deleters3.Updaters3.MoveNextLooprs3.Close'打开《计算前坐标数据》表并指向第一条记录rs1.Open "计算前坐标数据", Conn, adOpenDynamic, adLockOptimisticrs1.MoveFirst'打开《计算后方位角及距离数据》表，把计算后数据保存到表中rs2.Open "计算后方位角及距离数据", Conn, adOpenDynamic, adLockOptimistic'读取表中数据，开始计算Do While Not rs1.EOFJSXH = rs1!序号QDname = rs1!起点点号QDx = rs1!起点x坐标QDy = rs1!起点y坐标ZDname = rs1!终点点号ZDx = rs1!终点x坐标ZDy = rs1!终点y坐标If (ZDx - QDx) = 0 And (ZDy - QDy) = 0 ThenMsgBox QDname & "和" & ZDname & "是同一个点", vbOKOnly + vbExclamation, "提示信息"Exit SubElsers2.AddNewrs2!序号= JSXHrs2!名称= QDname & "—" & ZDnamers2!方位角= JSFWJ(QDx, QDy, ZDx, ZDy)rs2!距离= JSJLS(QDx, QDy, ZDx, ZDy)rs2.Updaters1.MoveNextEnd IfLooprs1.Closers2.Close'利用宏，把数据导出到Excel表中DoCmd.RunMacro "导入导出数据.导出计算后方位角及距离数据"End SubPrivate Sub Cmd_退出程序2_Click()Dim A As IntegerA = MsgBox("确定要退出程序吗？", vbYesNo + vbQuestion, "温馨提示")If A = vbNo ThenExit SubElseDoCmd.CloseEnd IfEnd Sub。
常用的的测量程序vb代码
取一元、二元、五元的硬币共十枚，付给25元钱，有多少种不同的取法?方法一Private Sub Command1_Click()Print "一元", "两元", "五元"For a = 0 To 10For b = 0 To 10For c = 0 To 10If a + 2 * b + 5 * c = 25 And a + b + c = 10 ThenPrint a, b, cEnd IfNext cNext bNext aEnd Sub：方法二Private Sub Command1_Click()Print "一元", "两元", "五元"For a = 0 To 10For b = 0 To 10c = 10 - a - bIf a + 2 * b + 5 * c = 25 And c > 0 ThenPrint a, b, cEnd IfNext bNext aEnd Sub九九乘法表方法一Private Sub Command1_Click() Print Tab(12); "九九乘法表" For i = 1 To 9For j = 1 To iPrint i * j;Next jPrintNext iEnd Sub方法二Private Sub Command2_Click() ShowFontSize = 15Print Tab(12);FontSize = 12PrintFor k = 0 To 9Print Tab(k * 4); k;Next kjiuPrintFor j = 1 To 9Print j;For k = 1 To jPrint Tab(k * 4); j * k;Next kPrintNext jEnd Sub求T = 8! = 1×2×3×…×8 Private Sub Command1_Click()jc = 1n = Val(Text1.Text)For c = 1 To njc = jc * cNext cPrint "jc="; jcEnd Sub用100 元买100 只鸡，母鸡3元1只，小鸡1元3只，问各应买多少只?Private Sub Command1_Click()Dim x As Integer, y As IntegerFor x = 1 To 30y = 100 - xIf 3 * x + y / 3 = 100 ThenPrint "母鸡只数为:"; x,Print "小鸡只数为:"; yEnd IfNext xEnd Sub数组打印数组的上界和下界数值Private Sub Command1_Click() Dim a(1 To 10) As IntegerPrint "下界值", "上界值" Print LBound(a), UBound(a) End Sub数组解决1+2+3+4+5+6+7+8=？Private Sub Command1_Click() Dim a(1 To 10) As IntegerDim sum As IntegerFor b = 1 To 8a(b) = bsum = sum + a(b)Next bText1.Text = sumPrint "1+2+3+4+5+6+7+8=" & sum End Sub任意五个数字之和Private Sub Command1_Click()Dim Data(5) As IntegerDim Sum, I As IntegerFor I = 1 To 5Data(I) = InputBox("输入第" & I & "个数据") Next IFor I = 1 To 5Sum = Sum + Data(I)Next IText1.Text = SumPrint SumEnd Sub连续输入5个数字例如1，2，3，4，51+3+5+7+9=？奇数和Private Sub Command1_Click()Dim a(1 To 5) As IntegerDim sum As IntegerFor x = 1 To 5a(x) = x * 2 - 1sum = sum + a(x)Next xText1.Text = sumPrint sumEnd SubPrivate Function pf(x As Long, y As Long) As Long s = Sqr(x ^ 2 + y ^ 2)pf = sEnd FunctionPrivate Sub Command1_Click()Dim a As LongDim b As LongDim c As Longa = Val(Text1.Text)b = Val(Text2.Text)s = pf(a, b)Print sEnd SubSub过程和Function过程3. 编写过程，求两个数的最大公约数。
VB代码
CDg1.Filter = "Text Files(*.TXT)|*.txt|All Files(*.*)|*.*"
CDg1.DialogTitle = "读取已知数据"
CDg1.FileName = "": CDg1.Action = 1
'显示读入的控制点地面坐标
txtShow.Text = txtShow.Text & Xt(1) & " , " & Yt(1) & " , " & Zt(1) & vbCrLf
txtShow.Text = txtShow.Text & Xt(2) & " , " & Yt(2) & " , " & Zt(2) & vbCrLf
Dim fai_R#, omg_R#, kap_R#, XsR#, YsR#, ZsR# '左片外方位元素
Dim Bx#, By#, Bz# '基线分量
Dim R_L#(1 To 3, 1 To 3), R_R#(1 To 3, 1 To 3) '左右像片的旋转矩阵
If CDg1.FileName = "" Then Exit Sub
Open CDg1.FileName For Input As #1
Line Input #1, strTemp '读第一行题头信息
txtShow.Text = txtShow.Text & vbCrLf & strTemp & vbCrLf
推算坐标方位角程序
推算坐标方位角程序分类:土建参考资料2006.9.5 20:26 作者：小杨 | 评论：0 | 阅读：1922Option ExplicitRem **** GPHVB2.VBP ****Rem **** 奇进偶舍、度分秒与弧度互化、推算坐标方位角程序**** Rem **** 2005/03/23*****Private Sub Form_Load()Rem ***** 此为第一个窗体From1.frm ****Form1.Height = Screen.Height: '**** 设置窗体高占整个屏幕Form1.Width = Screen.Width: '***** 设置窗体宽占整个屏幕Form1.Left = 0: '**** 设置窗体位置距离屏幕左端的距离为值零Form1.Top = 0: '**** 设置窗体位置距离屏幕上端的距离值为零End SubPrivate Sub GPHT1_Click(index As Integer)Rem **** 奇进偶舍演示 ****Rem ——————————————————————————————Rem **** VB提倡使用显示变量，要显示声明变量，方法有二：Rem **** 1.可在类模块、窗体模块或标准模块的声明段加入如下语句：Rem **** Option ExplicitRem **** 2.在“工具”菜单中选取“选项”，单击“编辑器”选项卡，Rem **** 再复选“要求变量声明”选项，最后单击“确定”退出，这样Rem **** 就在任何新模块（类模块、窗体模块、标准模块）的声明段中Rem **** 自动插入Option Explicit语句，但不会在已经建立起来的Rem **** 模块中自动插入；所在工程内部，只能用手工方法向现有模Rem **** 块添加 Option explicit 语句。
Rem ——————————————————————————————Dim A As IntegerClsPrintPrint Spc(6); "奇进偶舍演示"PrintPrint Spc(6); "PI()"For A = 1 To 20Print Spc(6); LTrim$(A); " NNN="; NNN(PI(), A)'DO'Loop Until INKEY$<>""Next AEnd SubPrivate Function NNN(ByVal NM As Double, ByVal BB As Integer) As Double Rem **** 奇进偶舍函数 ****Rem **** NM为需要奇进偶舍的变量，BB为NM这个变量需要保留的小数点后面的位数 *****Rem **** 分别用NM=PI()、BB=1、2、……Rem **** NM=1.2225、BB=3Rem **** NM=1.2235、BM=3 来验证该FUNCTION过程的正确性 ****Dim BNM As DoubleDim C As IntegerDim J As IntegerDim K As IntegerDim I As DoubleC = Sgn(NM)BNM = Abs(NM)I = (BNM * 10 ^ (BB + 1) + 10 ^ (-11)) - 10 * Fix(BNM * 10 ^ BB + 10 ^ (-11))I = (Fix(I * 10 ^ 10)) / 10 ^ 10J = Fix(BNM * 10 ^ BB + 10 ^ (-11)) - 10 * Fix(BNM * 10 ^ (BB - 1) + 10 ^ (-110))If I > 5 ThenK = 1ElseIf I < 5 ThenK = 0ElseIf (I = 5 And J = 2 * Fix(J / 2)) ThenK = 0ElseK = 1End IfNNN = C * Fix(BNM * 10 ^ BB + K) / 10 ^ BBEnd FunctionPrivate Static Function PI() As DoubleRem ****** 计算PI *******PI = 4 * Atn(1)End FunctionPrivate Sub GPHT2_CLICK(index As Integer)Rem ****** DEG->RAD 演示******Dim D As StringCls'D="0 00 00"'D="0 12 55"'D="2 12 55"'D = "12 36 56"'D="233 12 45"'D="-233 12 45"PrintPrint Spc(6); "DEG->RAD 演示"PrintPrint Spc(6); "DEG$="; DPrint Spc(6); "RAD="; RAD(D)'*******当Ｄ$="12 36 56 " 时 , RAD=0.220182981***** End SubPrivate Function RAD(ByVal DEGREE As String) As Double Rem **** XXX°XX′XX"->rad *****Rem **** DEGREE$如"12 45 18"的形式****Rem **** 应加上如下功能：１.测试DEGREE$是否带有＋－号；Rem **** ２.测试度和分之间的空格之间有多少字符Dim DEG11 As DoubleDim DEG12 As DoubleDim DEG13 As DoubleDEG11 = Val(Left$(DEGREE, 3))DEG12 = Val(Mid$(DEGEE, 5, 2)) / 60DEG13 = Val(Right$(DEGEE, 2)) / 3600RAD = (DEG11 + DEG12 + DEG13) * PI() / 180End FunctionPrivate Sub GPHT3_CLICK(index As Integer)Rem **** RAD->DEG演示****Dim RADIAN As DoubleClsRADIAN = -2.1234PrintPrint Spc(6); "RAD->DEG演示"PrintPrint Spc(6); "RAD="; RADIANPrint Spc(6); "DEG$="; DEG(RADIAN)End SubPrivate Function DEG(ByVal RAD As Double) As StringRem ****RAD->#XXX°XX'XX″****Rem ****#号表示输出XXX°XX′XX″前应带有的符号，其若为"-"号，即取之；Rem **** 其若为“＋”号，使空格顶位。