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

1、公用模块：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 Double vx = xb - xa: vy = yb - ya 如果A、B两点坐标相同，出现提示对话框 If vx = 0 And vy = 0 Then Msg

2、Box 您选择的是同一个点！, 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 与x轴正半轴平行 JSFWJ = RadianToAngle(0) ElseIf vy = 0 And vx 0 And vy 0 Then 第一象限 JSFWJ = RadianToAngle(Atn(vy / vx) ElseIf vx 0 Then

3、 第二象限 JSFWJ = RadianToAngle(Atn(vy / vx) + PI) ElseIf vx 0 And vy 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 Double Dim vx As Double, vy As Double v

4、x = 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

5、 = 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 + alfa1End Function窗体模块：Option Explicit/简单计算/Private Sub Form_Load() Me.txt_Xa = : Me.txt_Ya = Me.txt_Xb = : Me.txt_Yb = Me.t

6、xt_方位角 = Me.txt_距离= Me.txt_Xa.SetFocusEnd SubPrivate Sub cmd_数据清空_Click() Me.txt_Xa = : Me.txt_Ya = Me.txt_Xb = : Me.txt_Yb = Me.txt_方位角= Me.txt_距离= Me.txt_Xa.SetFocusEnd SubPrivate Sub cmd_退出程序_Click() Dim A As Integer A = MsgBox(确定要退出程序吗？, vbYesNo + vbQuestion, 温馨提示) If A = vbNo Then Exit Sub Else

7、 DoCmd.Close End IfEnd SubPrivate 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.t

8、xt_方位角 = 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_方位角

9、= Format(FWJ, 0.00000000) End If End IfEnd 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 D

10、ouble, 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.t

11、xt_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.M

12、oveFirst打开计算后方位角及距离数据表，把计算后数据保存到表中 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 利用宏，把数据导出到E