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

1、公用模块: 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 The

2、n 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与x车由正半轴平行 JSFWJ = RadianToAngle(O) ElseIf vy = 0 And vx 0 And vy 0 Then第一象限 JSFWJ = RadianToAngle(Atn(vy / vx) ElseIf vx 0 T

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

4、ble 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 alfal As Double, alfa2 As Dou

5、ble alfa = alfa * 180# / PI alfa = alfa + 0.000000000000001 alfal = Fix(alfa) + Fix(alfa - Fix(alfa) * 60#) / 100# alfa2 = (alfa * 60# - Fix(alfa * 60#) * 0.006 RadianToAngle = alfa2 + alfal End Function 窗体模块： Option Explicit 7/简单计算 / Private Sub Form_Load() Me.txt_Xa = : Me.txt_Ya = Me.txt_Xb = : M

6、e.txt_Yb = Me.txt_ 方位角= Me.txt_ 距离= Me.txt_Xa.SetFocus 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 cmd_退出程序 _Click() Dim A As Integer A = MsgBox(确定要退出程序吗？, vbYesNo + vbQuestion,温馨提示) If A =

7、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 lsNull(Me.txt_Xa) Or lsNull(Me.txt_Ya) Or lsNull(Me.txt_Xb) Or lsNull(Me.txt_Yb) Then MsgBox 请输入完整数据！ ！ ！ , vbOKCancel + vbInforma

8、tion,提示 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_

9、距离=Format(S, 0.0000) Me.txt_ 方位角 =Format(FWJ, 0.00000000) End If End If End Sub 7/批量计算 / 打开要进行批量计算的数据表计算前坐标数据表 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

10、)和终点坐标(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

11、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 打开计算前坐标数据表并指向第一条记录 rsl.Open 计算前坐标数据,

12、 Conn, adOpenDynamic, adLockOptimistic rsl.MoveFirst 打开计算后方位角及距离数据表，把计算后数据保存到表中 rs2.Open 计算后方位角及距离数据 , Conn, adOpenDynamic, adLockOptimistic 读取表中数据，开始计算 Do While Not rsl.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