VB平差程序设计复习资料.doc

测边交会Option Compare DatabasePublic DDD_X As Double, DDD_Y As Double 待定点X，Y 已知A、B两点坐标及观测的边长计算待定点坐标,BCJSDDDZB的中文意思是由观测边长计算待定点坐标Public Sub BCJSDDDZB(xa As Double, ya As Double, xb As Double, yb As Double, L1 As Double, L2 As Double) Dim SAB As Double, L As Double, H As Double, cosAB As Double, sinAB As Double SAB = Sqr(xb - xa) * (xb - xa) + (yb - ya) * (yb - ya) L = (L1 * L1 + SAB * SAB - L2 * L2) / (2 * SAB) H = Sqr(L1 * L1 - L * L) cosAB = (xb - xa) / SAB sinAB = (yb - ya) / SAB DDD_X = xa + L * cosAB + H * sinAB DDD_Y = ya + L * sinAB - H * cosABEnd SubPrivate Sub cmd_返回选题界面_Click() DoCmd.OpenForm 选题界面, acNormal, , , , acNormal DoCmd.Close acForm, 测边交会End SubPrivate Sub cmd_计算_Click() Dim xa As Double, ya As Double, xb As Double, yb As Double, L1 As Double, L2 As Double If IsNull(Me.txt_Xa) Or IsNull(Me.txt_Ya) Or IsNull(Me.txt_Xb) Or IsNull(Me.txt_Yb) Then MsgBox 请输入完整的坐标数据！, vbOKCancel + vbInformation, 提示 End If If IsNull(Me.txt_L1) Or IsNull(Me.txt_L2) Then MsgBox 请输入完整的观测边长数据！, vbOKCancel + vbInformation, 提示 End If xa = Me.txt_Xa: ya = Me.txt_Ya xb = Me.txt_Xb: yb = Me.txt_Yb L1 = Me.txt_L1: L2 = Me.txt_L2 If (xb - xa) = 0 And (yb - ya) = 0 Then MsgBox 您选择的是同一个点！, vbOKOnly + vbExclamation, 提示信息 Else Call BCJSDDDZB(xa, ya, xb, yb, L1, L2) Me.txt_DX = Format(DDD_X, 0.000) Me.txt_DY = Format(DDD_Y, 0.000) End IfEnd SubPrivate Sub cmd_数据清空_Click() Me.txt_Xa = : Me.txt_Ya = Me.txt_Xb = : Me.txt_Yb = Me.txt_L1 = : Me.txt_L2 = Me.txt_DX = : Me.txt_DY = Me.txt_Xa.SetFocusEnd SubPrivate Sub Form_Load() Me.txt_Xa = : Me.txt_Ya = Me.txt_Xb = : Me.txt_Yb = Me.txt_L1 = : Me.txt_L2 = Me.txt_DX = : Me.txt_DY = Me.txt_Xa.SetFocusEnd Sub测角交会Option Compare DatabaseConst PI = 3.14159265358979Public DDD_X As Double, DDD_Y As Double 待定点X，Y角度化弧度Public Function AngleToRadian(ByVal alfa As Double) As Double alfa = alfa + 0.00000000000001 Dim alfa1 As Double, alfa2 As Double alfa1 = Fix(alfa) + Fix(alfa - Fix(alfa) * 100#) / 60# alfa2 = (alfa * 100# - Fix(alfa * 100#) / 36# AngleToRadian = (alfa2 + alfa1) * PI / 180#End Function已知A、B两点坐标及观测的角度计算待定点坐标,JDJSDDDZB的中文意思是由观测角度计算待定点坐标Public Sub JDJSDDDZB(xa As Double, ya As Double, xb As Double, yb As Double, JDA As Double, JDB As Double) Dim tanA As Double, tanB As Double JDA = AngleToRadian(JDA) JDB = AngleToRadian(JDB) tanA = Tan(JDA) tanB = Tan(JDB) DDD_X = (xa * tanA + xb * tanB + (yb - ya) * tanA * tanB) / (tanA + tanB) DDD_Y = (ya * tanA + yb * tanB + (xa - xb) * tanA * tanB) / (tanA + tanB)End SubPrivate Sub cmd_返回选题界面_Click() DoCmd.OpenForm 选题界面, acNormal, , , , acNormal DoCmd.Close acForm, 测角交会End SubPrivate Sub cmd_计算_Click() Dim xa As Double, ya As Double, xb As Double, yb As Double, JDA As Double, JDB As Double If IsNull(Me.txt_Xa) Or IsNull(Me.txt_Ya) Or IsNull(Me.txt_Xb) Or IsNull(Me.txt_Yb) Then MsgBox 请输入完整的坐标数据！, vbOKCancel + vbInformation, 提示 End If If IsNull(Me.txt_JDA) Or IsNull(Me.txt_JDB) Then MsgBox 请输入完整的观测角度数据！, vbOKCancel + vbInformation, 提示 End If xa = Me.txt_Xa: ya = Me.txt_Ya xb = Me.txt_Xb: yb = Me.txt_Yb JDA = Me.txt_JDA: JDB = Me.txt_JDB If (xb - xa) = 0 And (yb - ya) = 0 Then MsgBox 您选择的是同一个点！, vbOKOnly + vbExclamation, 提示信息 Else Call JDJSDDDZB(xa, ya, xb, yb, JDA, JDB) Me.txt_DX = Format(DDD_X, 0.000) Me.txt_DY = Format(DDD_Y, 0.000) End IfEnd SubPrivate Sub cmd_数据清空_Click() Me.txt_Xa = : Me.txt_Ya = Me.txt_Xb = : Me.txt_Yb = Me.txt_JDA = : Me.txt_JDB = Me.txt_DX = : Me.txt_DY = Me.txt_Xa.SetFocusEnd SubPrivate Sub Form_Load() Me.txt_Xa = : Me.txt_Ya = Me.txt_Xb = : Me.txt_Yb = Me.txt_JDA = : Me.txt_JDB = Me.txt_DX = : Me.txt_DY = Me.txt_Xa.SetFocusEnd Sub后方交会Option Compare DatabaseOption ExplicitPublic XP As Double, YP As Double 后方交会时计算待定点XP、YPConst PI = 3.14159265358979角度化弧度Public Function AngleToRadian(ByVal alfa As Double) As Double alfa = alfa + 0.00000000000001 Dim alfa1 As Double, alfa2 As Double alfa1 = Fix(alfa) + Fix(alfa - Fix(alfa) * 100#) / 60# alfa2 = (alfa * 100# - Fix(alfa * 100#) / 36# AngleToRadian = (alfa2 + alfa1) * PI / 180#End Function 已知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 Double Dim N0 As Integer N0 = Fix(ya / 1000000): ya = ya - N0 * 1000000 N0 = Fix(yb / 1000000): yb = yb - N0 * 1000000 vx = xb - xa: vy = yb - ya 如果A、B两点坐标相同，出现提示对话框 If vx = 0 And vy = 0 Then MsgBox 您选择的是同一个点！, vbOKOnly + vbExclamation, 提示信息 JSFWJ = 999999999# End If 计算方位角的值 If vx = 0 And vy 0 Then JSFWJ = PI / 2# ElseIf vx = 0 And vy 0 Then JSFWJ = 0 ElseIf vy = 0 And vx 0 And vy 0 Then JSFWJ = Atn(vy / vx) ElseIf vx 0 Then JSFWJ = Atn(vy / vx) + PI ElseIf vx 0 And vy 0 And vy 0 Then JSFWJ = PI / 2# ElseIf vx = 0 And vy 0 Then JSFWJ = 0 ElseIf vy = 0 And vx 0 And vy 0 Then JSFWJ = Atn(vy / vx) ElseIf vx 0 Then JSFWJ = Atn(vy / vx) + PI ElseIf vx 0 And vy 0 And vy 0 Then JSFWJ = Atn(vy / vx) + 2 * PI End IfEnd Function 已知A、B两点坐标计算距离,JSJLS的中文意思是计算距离S _ 提示此函数处理的坐标是包括带号的Public Function JSJLS(xa As Double, ya As Double, xb As Double, yb As Double) As Double Dim vx As Double, vy As Double Dim N0 As Integer N0 = Fix(ya / 1000000): ya = ya - N0 * 1000000 N0 = Fix(yb / 1000000): yb = yb - N0 * 1000000 vx = xb - xa: vy = yb - ya 如果A、B两点坐标相同，出现提示对话框 If vx = 0 And vy = 0 Then MsgBox 您选择的是同一个点！, vbOKOnly + vbExclamation, 提示信息 JSJLS = 999999999# End If JSJLS = Sqr(vx * vx + vy * vy) 计算距离End FunctionPrivate Sub cmd_返回选题界面_Click() DoCmd.OpenForm 选题界面, acNormal, , , , acNormal DoCmd.Close acForm, 坐标方位角及距离计算程序End SubPrivate Sub cmd_计算方位角_Click() Dim xa As Double, ya As Double, xb As Double, yb As Double, ZJ As Double, S As Double If IsNull(Me.txt_Xa) Or IsNull(Me.txt_Ya) Or IsNull(Me.txt_Xb) Or IsNull(Me.txt_Yb) Then MsgBox 请输入完整数据！, vbOKCancel + vbInformatio