《坐标方位角及距离计算小程序》代码——Access实现

公用模块：
Option Explicit
Public 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 Double
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 '与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 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
vx = xb - xa: vy = yb - ya
'如果A、B两点坐标相同，出现提示对话框
If vx = 0 And vy = 0 Then
MsgBox "您选择的是同一个点！", vbOKOnly + vbExclamation, "提示信息"
JSJLS = 99999999#
End If
'计算距离
JSJLS = Sqr(vx * vx + vy * vy)
End Function
'弧度化角度
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
窗体模块：
Option Explicit
'//////////////////////////////////////////////////////简单计算/////////////////////////////////////////////////// Private Sub Form_Load()
Me.txt_方位角= ""
Me.txt_距离= ""
Me.txt_Xa.SetFocus
End Sub
Private Sub cmd_数据清空_Click()
Me.txt_Xa =Null: Me.txt_Ya = Null
Me.txt_Xb =Null: Me.txt_Yb = Null
Me.txt_方位角= ""
Me.txt_距离= ""
Me.txt_Xa.SetFocus
End Sub
Private Sub cmd_退出程序_Click()
Dim A As Integer
A = MsgBox("确定要退出程序吗？", vbYesNo + vbQuestion, "温馨提示")
If A = vbNo Then
Exit Sub
Else
DoCmd.Close
End If
End Sub
Private Sub cmd_计算_Click()
Dim xa As Double, ya As Double, xb As Double, yb As Double, FWJ 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
Me.txt_方位角= ""
Me.txt_距离= ""
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_方位角= ""
Me.txt_距离= ""
Else
FWJ = JSFWJ(xa, ya, xb, yb)
S = JSJLS(xa, ya, xb, yb)
Me.txt_距离= Format(S, "0.0000")
Me.txt_方位角= Format(FWJ, "0.00000000")
End If
End If
End Sub
'//////////////////////////////////////////////////////批量计算/////////////////////////////////////////////////// '打开要进行批量计算的数据表《计算前坐标数据》表
Private Sub cmd_导入计算数据_Click()
DoCmd.RunMacro "导入导出数据.导入计算数据"
End Sub
Private 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 Double
Dim Conn As ADODB.Connection
Dim rs1 As ADODB.Recordset
Dim rs2 As ADODB.Recordset
Dim rs3 As ADODB.Recordset
Set Conn = CurrentProject.Connection
Set rs1 = New ADODB.Recordset
Set rs2 = New ADODB.Recordset
Set rs3 = New ADODB.Recordset
'清空简单计算内容
Me.txt_Xa = "": Me.txt_Ya = ""
Me.txt_Xb = "": Me.txt_Yb = ""
'清空《计算后方位角及距离数据》表，为计算后添加数据做准备
rs3.Open "select * from 计算后方位角及距离数据", Conn, adOpenDynamic, adLockOptimistic
rs3.MoveFirst
Do While Not rs3.EOF
rs3.Delete
rs3.Update
rs3.MoveNext
Loop
rs3.Close
'打开《计算前坐标数据》表并指向第一条记录
rs1.Open "计算前坐标数据", Conn, adOpenDynamic, adLockOptimistic
rs1.MoveFirst
'打开《计算后方位角及距离数据》表，把计算后数据保存到表中
rs2.Open "计算后方位角及距离数据", Conn, adOpenDynamic, adLockOptimistic
'读取表中数据，开始计算
Do While Not rs1.EOF
JSXH = 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 Then
MsgBox QDname & "和" & ZDname & "是同一个点", vbOKOnly + vbExclamation, "提示信息"
Exit Sub
Else
rs2.AddNew
rs2!序号= JSXH
rs2!名称= QDname & "—" & ZDname
rs2!方位角= JSFWJ(QDx, QDy, ZDx, ZDy)
rs2!距离= JSJLS(QDx, QDy, ZDx, ZDy)
rs2.Update
rs1.MoveNext
End If
Loop
rs1.Close
rs2.Close
'利用宏，把数据导出到Excel表中
DoCmd.RunMacro "导入导出数据.导出计算后方位角及距离数据"
End Sub
Private Sub Cmd_退出程序2_Click()
Dim A As Integer
A = MsgBox("确定要退出程序吗？", vbYesNo + vbQuestion, "温馨提示")
If A = vbNo Then
Exit Sub
Else
DoCmd.Close
End If
End Sub。