公用模块：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 Doublevx = xb - xa: vy = yb - ya'如果A、B两点坐标相同，出现提示对话框If vx = 0 And vy = 0 ThenMsgBox "您选择的是同一个点！", 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 IfEnd Function'已知A、B两点坐标计算距离，JSJLS的中文意思是计算距离SPublic Function JSJLS(xa As Double, ya As Double, xb As Double, yb As Double) As DoubleDim vx As Double, vy As Doublevx = xb - xa: vy = yb - ya'如果A、B两点坐标相同，出现提示对话框If vx = 0 And vy = 0 ThenMsgBox "您选择的是同一个点！", vbOKOnly + vbExclamation, "提示信息"JSJLS = 99999999#End If'计算距离JSJLS = Sqr(vx * vx + vy * vy)End Function'弧度化角度Public Function RadianToAngle(ByVal alfa As Double) As DoubleDim alfa1 As Double, alfa2 As Doublealfa = alfa * 180# / PIalfa = alfa + 0.000000000000001alfa1 = Fix(alfa) + Fix((alfa - Fix(alfa)) * 60#) / 100#alfa2 = (alfa * 60# - Fix(alfa * 60#)) * 0.006RadianToAngle = alfa2 + alfa1End Function窗体模块：Option Explicit'//////////////////////////////////////////////////////简单计算/////////////////////////////////////////////////// Private Sub Form_Load()Me.txt_Xa = "": Me.txt_Ya = ""Me.txt_Xb = "": Me.txt_Yb = ""Me.txt_方位角= ""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 IntegerA = MsgBox("确定要退出程序吗？", vbYesNo + vbQuestion, "温馨提示")If A = vbNo ThenExit SubElseDoCmd.CloseEnd IfEnd SubPrivate Sub cmd_计算_Click()Dim xa As Double, ya As Double, xb As Double, yb As Double, FWJ As Double, S As DoubleIf IsNull(Me.txt_Xa) Or IsNull(Me.txt_Ya) Or IsNull(Me.txt_Xb) Or IsNull(Me.txt_Yb) ThenMsgBox "请输入完整数据！！！", vbOKCancel + vbInformation, "提示"Me.txt_Xa.SetFocusMe.txt_方位角= ""Me.txt_距离= ""Elsexa = Me.txt_Xa: ya = Me.txt_Yaxb = Me.txt_Xb: yb = Me.txt_YbIf (xb - xa) = 0 And (yb - ya) = 0 ThenMsgBox "您选择的是同一个点！", vbOKOnly + vbExclamation, "提示信息"Me.txt_方位角= ""Me.txt_距离= ""ElseFWJ = JSFWJ(xa, ya, xb, yb)S = JSJLS(xa, ya, xb, yb)Me.txt_距离= Format(S, "0.0000")Me.txt_方位角= Format(FWJ, "0.00000000")End IfEnd IfEnd Sub'//////////////////////////////////////////////////////批量计算/////////////////////////////////////////////////// '打开要进行批量计算的数据表《计算前坐标数据》表Private Sub cmd_导入计算数据_Click()DoCmd.RunMacro "导入导出数据.导入计算数据"End SubPrivate 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 DoubleDim Conn As ADODB.ConnectionDim rs1 As ADODB.RecordsetDim rs2 As ADODB.RecordsetDim rs3 As ADODB.RecordsetSet Conn = CurrentProject.ConnectionSet rs1 = New ADODB.RecordsetSet rs2 = New ADODB.RecordsetSet rs3 = New ADODB.Recordset'清空简单计算内容Me.txt_Xa = "": Me.txt_Ya = ""Me.txt_Xb = "": Me.txt_Yb = ""'清空《计算后方位角及距离数据》表，为计算后添加数据做准备rs3.Open "select * from 计算后方位角及距离数据", Conn, adOpenDynamic, adLockOptimisticrs3.MoveFirstDo While Not rs3.EOFrs3.Deleters3.Updaters3.MoveNextLooprs3.Close'打开《计算前坐标数据》表并指向第一条记录rs1.Open "计算前坐标数据", Conn, adOpenDynamic, adLockOptimisticrs1.MoveFirst'打开《计算后方位角及距离数据》表，把计算后数据保存到表中rs2.Open "计算后方位角及距离数据", Conn, adOpenDynamic, adLockOptimistic'读取表中数据，开始计算Do While Not rs1.EOFJSXH = 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 ThenMsgBox QDname & "和" & ZDname & "是同一个点", vbOKOnly + vbExclamation, "提示信息"Exit SubElsers2.AddNewrs2!序号= JSXHrs2!名称= QDname & "—" & ZDnamers2!方位角= JSFWJ(QDx, QDy, ZDx, ZDy)rs2!距离= JSJLS(QDx, QDy, ZDx, ZDy)rs2.Updaters1.MoveNextEnd IfLooprs1.Closers2.Close'利用宏，把数据导出到Excel表中DoCmd.RunMacro "导入导出数据.导出计算后方位角及距离数据"End SubPrivate Sub Cmd_退出程序2_Click()Dim A As IntegerA = MsgBox("确定要退出程序吗？", vbYesNo + vbQuestion, "温馨提示")If A = vbNo ThenExit SubElseDoCmd.CloseEnd IfEnd Sub。