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

测边交会
Option Compare Database
Public 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 * cosAB
End Sub
Private Sub cmd_返回选题界面_Click()
DoCmd.OpenForm "选题界面", acNormal, "", "", , acNormal
DoCmd.Close acForm, "测边交会"
End Sub
Private 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 If
End Sub
Private 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.SetFocus
End Sub
Private 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.SetFocus
End Sub

测角交会
Option Compare Database
Const PI = 3.14159265358979
Public 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 Sub
Private Sub cmd_返回选题界面_Click()
DoCmd.OpenForm "选题界面", acNormal, "", "", , acNormal
DoCmd.Close acForm, "测角交会"
End Sub
Private 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 If
End Sub
Private 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.SetFocus
End Sub
Private 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.SetFocus
End Sub

后方交会
Option Compare Database
Option Explicit
Public XP As Double, YP As Double '后方交会时计算待定点XP、YP
Const 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 = PI * 3# / 2#
ElseIf vy = 0 And vx > 0 Then
JSFWJ = 0
ElseIf vy = 0 And vx < 0 Then
JSFWJ = PI
ElseIf vx > 0 And vy > 0 Then
JSFWJ = Atn(vy / vx)
ElseIf vx < 0 And vy > 0 Then
JSFWJ = Atn(vy / vx) + PI
ElseIf vx < 0 And vy < 0 Then
JSFWJ = Atn(vy / vx) + PI
ElseIf vx > 0 And vy < 0 Then
JSFWJ = Atn(vy / vx) + 2 * PI
End If
End Function
'HFJHJS的中文意思是由后方交会计算
Public Sub HFJHJS(xa As Double, ya As Double, xb As Double, yb As Double, xc As Double, yc As Double, Ra As Double, Rb As Double, Rc As Double)
Dim FWJ_AB As Double, FWJ_BA As Double, FWJ_BC As Double, FWJ_CB As Double, FWJ_CA As Double, FWJ_AC As Double '方位角AB、BA、AC、CA、BC、CB
Dim JDA As Double, JDB As Double, JDC As Double '角度A、B、C
Dim PA As Double, PB As Double, PC As Double '权
Dim Ja As Double, Jb As Double, Jr As Double '三个水平角α、β、γ
FWJ_AB = JSFWJ(xa, ya, xb, yb): FWJ_BA = JSFWJ(xb, yb, xa, ya)
FWJ_BC = JSFWJ(xb, yb, xc, yc): FWJ_CB = JSFWJ(xc, yc, xb, yb)
FWJ_AC = JSFWJ(xa, ya, xc, yc): FWJ_CA = JSFWJ(xc, yc, xa, ya)
Ja = Rc - Rb: Jb = Ra - Rc: Jr = Rb - Ra '三个水平角α、β、γ
JDA = FWJ_AC - FWJ_AB: JDB = FWJ_BA - FWJ_BC: JDC = FWJ_CB - FWJ_CA
PA = (Tan(Ja) * Tan(JDA)) / (Tan(Ja) - Tan(JDA))
PB = (Tan(Jb) * Tan(JDB)) / (Tan(Jb) - Tan(JDB))
PC = (Tan(Jr) * Tan(JDC)) / (Tan(Jr) - Tan(JDC))
XP = (PA * xa + PB * xb + PC * xc) / (PA + PB + PC)
YP = (PA * ya + PB * yb + PC * yc) / (PA + PB + PC)
End Sub
Private Sub cmd_返回选题界面_Click()
DoCmd.OpenForm "选题界面", acNormal, "", "", , acNormal
DoCmd.Close acForm, "后方交会计算程序"
End Sub
Private Sub cmd_计算_Click()
Dim xa As Double, ya As Double, xb As Double, yb As Double, xc As Double, yc As Double
Dim Ra As Double, Rb As Double, Rc As Double
If IsNull(Me.txt_Xa) Or IsNull(Me.txt_Ya) Or IsNull(Me.txt_Xb) Or IsNull(Me.txt_Yb) Or IsNull(Me.txt_Xc) Or IsNull(Me.txt_Yc) Or IsNull(Me.txt_Ra) Or IsNull(txt_Rb) Or IsNull(txt_Rc) Then
MsgBox "请输入完整数据！！！", vbOKCancel + vbInformation, "提示"
Me.txt_Xa.SetFocus
Else
xa = Me.txt_Xa: ya = Me.txt_Ya
xb = Me.txt_Xb: yb = Me.txt_Yb
xc = Me.txt_Xc: yc = Me.txt_Yc
Ra = Me.txt_Ra: Rb = Me.txt_Rb: Rc = Me.txt_Rc
Ra = AngleToRadian(Ra): Rb = AngleToRadian(Rb): Rc = AngleToRadian(Rc) '将原始数据的角度化成弧度进行计算
Call HFJHJS(xa, ya, xb, yb, xc, yc, Ra, Rb, Rc)
Me.txt_XP = Format(XP, "0.0000")
Me.txt_YP = Format(YP, "0.0000")
End If
End Sub
Private Sub cmd_数据清空_Click()
Me.txt_Xa = "": Me.txt_Ya = ""
Me.txt_Xb = "": Me.txt_Yb = ""
Me.txt_Xc = "": Me.txt_Yc = ""
Me.txt_Ra = "": Me.txt_Rb = "": Me.txt_Rc = ""
Me.txt_XP = "": Me.txt_YP = ""
Me.txt_Xa.SetFocus
End Sub
Private Sub Form_Load()
Me.txt_Xa = "": Me.txt_Ya = ""
Me.txt_Xb = "": Me.txt_Yb = ""
Me.txt_Xc = "": Me.txt_Yc = ""
Me.txt_Ra = "": Me.txt_Rb = "": Me.txt_Rc = ""
Me.txt_XP = "": Me.txt_YP = ""
Me.txt_Xa.SetFocus
End Sub

极坐标方法计算点坐标
Option Compare Database
Option Explicit
Const 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
Private Sub cmd_返回选题界面_Click()
End Sub
Private Sub cmd_计算坐标_Click()
Dim xa As Double, ya As Double, S As Double, FWJ As Double, xb As Double, yb As Double
If IsNull(Me.txt_Xa) Or IsNull(Me.txt_Ya) Or IsNull(Me.txt_S) Or IsNull(Me.txt_FWJ) Then
MsgBox "请输入完整数据！！！", vbOKCancel + vbInformation, "提示"
Me.txt_Xa.SetFocus
Else
xa = Me.txt_Xa: ya = Me.txt_Ya
S = Me.txt_S: FWJ = Me.txt_FWJ
'角度换算成弧度
FWJ = AngleToRadian(FWJ)
'计算待定点坐标
xb = xa + S * Cos(FWJ): yb = ya + S * Sin(FWJ)
Me.txt_Xb = Format(xb, "0.0000")
Me.txt_Yb = Format(yb, "0.0000")
End If
End Sub
Private Sub cmd_数据清空_Click()
Me.txt_Xa = "": Me.txt_Ya = ""
Me.txt_S = "": Me.txt_FWJ = ""
Me.txt_Xb = ""
Me.txt_Yb = ""
Me.txt_Xa.SetFocus
End Sub
Private Sub Form_Load()
Me.txt_Xa.SetFocus
End Sub
中央子午线
Option Compare Database
Private Sub cmd_返回选题界面_Click()
DoCmd.OpenForm "选题界面", acNormal, "", "", , acNormal
DoCmd.Close acForm, "中央子午线计算程序"
End Sub
Private Sub cmd_计算_Click()
Dim DL As Double, N0 As Double, L0 As Double
If IsNull(Me.txt_DL) Then
MsgBox "请输入完整数据！！！", vbQuestion
Exit Sub
End If
DL = Val(txt_DL)
If Frm_分带选择 = 1 Then
N0 = Int((DL + 3) / 6# + 0.5)
L0 = N0 * 6 - 3
ElseIf Frm_分带选择 = 2 Then
N0 = Int(DL / 3# + 0.5)
L0 = 3 * N0
End If
txt_中央子午线 = L0
End Sub
Private Sub cmd_数据清空_Click()
txt_DL = ""
txt_中央子午线 = ""
txt_DL.SetFocus
End Sub
Private Sub Form_Load()
txt_DL = ""
txt_中央子午线 = ""
Frm_分带选择 = 2
txt_DL.SetFocus
End Sub

坐标方位角及距离
Option Compare Database
Option Explicit
Const PI = 3.14159265358979
'弧度化角度
Public Function RadianToAngle(ByVal alfa As Double) As Double
Dim alfa1 As Double, alfa2 As Double
alfa = alfa * 180# / PI
alfa = alfa + 0.000000000000001
alfa1 = Fix(alfa) + Fix((alfa - Fix(alfa)) * 60#) / 100#
alfa2 = (alfa * 60# - Fix(alfa * 60#)) * 0.006
RadianToAngle = alfa2 + alfa1
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 = PI * 3# / 2#
ElseIf vy = 0 And vx > 0 Then
JSFWJ = 0
ElseIf vy = 0 And vx < 0 Then
JSFWJ = PI
ElseIf vx > 0 And vy > 0 Then
JSFWJ = Atn(vy / vx)
ElseIf vx < 0 And vy > 0 Then
JSFWJ = Atn(vy / vx) + PI
ElseIf vx < 0 And vy < 0 Then
JSFWJ = Atn(vy / vx) + PI
ElseIf vx > 0 And vy < 0 Then
JSFWJ = Atn(vy / vx) + 2 * PI
End If
End 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 Function
Private Sub cmd_返回选题界面_Click()
DoCmd.OpenForm "选题界面", acNormal, "", "", , acNormal
DoCmd.Close acForm, "坐标方位角及距离计算程序"
End Sub
Private 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 + vbInformation, "提示"
Me.txt_Xa.SetFocus
Else
xa = Me.txt_Xa: ya = Me.txt_Ya
xb = Me.txt_Xb: yb = Me.txt_Yb
If (xb - xa) = 0 And (yb - ya) = 0 Then
MsgBox "您选择的是同一个点！", vbOKOnly + vbExclamation, "提示信息"
Me.txt_计算方位角结果 = ""
Else
ZJ = JSFWJ(xa, ya, xb, yb)
S = JSJLS(xa, ya, xb, yb)
Me.txt_XAB = Format(xb - xa, "0.0000")
Me.txt_YAB = Format(yb - ya, "0.0000")
Me.txt_距离 = Format(S, "0.0000")
Me.txt_计算方位角结果 = Format(RadianToAngle(ZJ), "0.00000000")
End If
End If
End Sub
Private Sub cmd_数据清空_Click()
Me.txt_Xa = "": Me.txt_Ya = ""
Me.txt_Xb = "": Me.txt_Yb = ""
Me.txt_计算方位角结果 = ""
Me.txt_距离 = ""
Me.txt_Xa.SetFocus
End Sub
Private Sub Form_Load()
Me.txt_计算方位角结果 = ""
Me.txt_Xa.SetFocus
End Sub