保存
Private Sub BC_Click()
Dim txt
CommonDialog1.Filter = "文本文档(*.txt)|*.txt|所有文件(*.*)|*.*"
CommonDialog1.FilterIndex = 1
CommonDialog1.ShowSave
Open CommonDialog1.FileName For Output As #1
Print #1, Text3.Text
Close #1End Sub
打开
Private Sub DK_Click()
Dim MyStr As String
Dim LStr As String
MyStr = ""
CommonDialog1.ShowOpen
Open CommonDialog1.FileName For Input As #1
Do While Not EOF(1)
Line Input #1, LStr
MyStr = MyStr & LStr & vbCrLf
Text1.Text = MyStr
Loop
Close #1
End Sub

Private Sub mnuCalc_Click()
'计算坐标方位角
Dim aAB#, aDC#
Dim i%
aAB = DirectAB(Xa, Ya, Xb, Yb)
text2.Text = text2.Text & vbCrLf & "起始坐标方位角 " & Format(HuToDo(aAB), "0.0000")
If iType = 1 Then
aDC = DirectAB(Xc, Yc, Xd, Yd)
text2.Text = text2.Text & vbCrLf & "终止坐标方位角 " & Format(HuToDo(aDC), "0.0000")
End If
'推算坐标方位角，把推算得到的方位角初值给sdAngle数组
sdAngle(1) = aAB
text2.Text = text2.Text & vbCrLf & "方位角初值：" & vbCrLf
For i = 1 To iStation
sdAngle(i + 1) = sdAngle(i) + (PI - sAngle(i)) * (-1) ^ iAngleType 'iAngleType=1是左角，=2是右角
If sdAngle(i + 1) > 2 * PI Then sdAngle(i + 1) = sdAngle(i + 1) - 2 * PI
If sdAngle(i + 1) < 0 Then sdAngle(i + 1) = sdAngle(i + 1) + 2 * PI
text2.Text = text2.Text & Format(HuToDo(sdAngle(i)), "0.0000") & " , "
Next i
text2.Text = text2.Text & Format(HuToDo(sdAngle(i)), "0.0000") & vbCrLf
'计算角度闭合差
If iType = 1 Then
detA = sdAngle(i) - aDC
Else
detA = sdAngle(i) - sdAngle(2)
End If
text2.Text = text2.Text & Format(HuToDo(detA), "0.0000") & vbCrLf
'判断是否附合限差要求
Dim fAccept As Double
If iType = 1 Then
fAccept = Int(40 * Sqr(iStation)) / 206265
Else
fAccept = Int(40 * Sqr(iStation - 1)) / 206265
End If
If detA > fAccept Then
MsgBox "角度闭合差超限！", , "计算终止"
text2.Text = text2.Text & vbCrLf & "角度闭合差超限，计算终止！"
Exit Sub
End If
'若没有超限，则分配角度闭合差，重新计算角度值和推算坐标方位角
If iType = 1 Then
detA = detA / iStation '简单地平均分配角度值了，后面对秒进行四舍五入处理
text2.Text = text2.Text & "改正后的角度：" & vbCrLf
For i = 1 To iStation
sAngle(i) = sAngle(i) + detA
text2.Text = text2.Text & Format(HuToDo(sAngle(i)), "0.0000") & " , "
'sdAngle(i) = sdAngle(i) + detA * (i - 2)
sdAngle(i + 1) = sdAngle(i) + (PI - sAngle(i)) * (-1) ^ iAngleType 'iAngleType=1是左角，=2是右角
If sdAngle(i + 1) > 2 * PI Then sdAngle(i + 1) = sdAngle(i + 1) - 2 * PI
If sdAngle(i + 1) < 0 Then sdAngle(i + 1) = sdAngle(i + 1) + 2 * PI
Next i
Else
detA = detA / (iStation - 1) '简单地平均分配角度值了，后面对秒进行四舍五入处理
text2.Text = text2.Text & "改正后的角度：" & vbCrLf
For i = 2 To iStation
sAngle(i) = sAngle(i) + detA
text2.Text = text2.Text & Format(HuToDo(sAngle(i)), "0.0000") & " , "
'sdAngle(i) = sdAngle(i) + detA * (i - 1)
sdAngle(i + 1) = sdAngle(i) + (PI - sAngle(i)) * (-1) ^ iAngleType 'iAngleType=1是左角，=2是右角
If sdAngle(i + 1) > 2 * PI Then sdAngle(i + 1) = sdAngle(i + 1) - 2 * PI
If sdAngle(i + 1) < 0 Then sdAngle(i + 1) = sdAngle(i + 1) + 2 * PI
Next i
End If
'显示改正后的坐标方位角
text2.Text = text2.Text & vbCrLf & "改正后的方位角：" & vbCrLf
For i = 1 To iStation
text2.Text = text2.Text & Format(HuToDo(sdAngle(i)), "0.0000") & " , "
Next i
text2.Text = text2.Text & vbCrLf
'计算初始坐标增量
text2.Text = text2.Text & "坐标增量初值：" & vbCrLf
For i = 2 To iStation
detX(i - 1) = sEdge(i - 1) * Cos(sdAngle(i))
text2.Text = text2.Text & Format(detX(i - 1), "0.000") & " , "
detY(i - 1) = sEdge(i - 1) * Sin(sdAngle(i))
text2.Text = text2.Text & Format(detY(i - 1), "0.000") & " ; "
Next i
text2.Text = text2.Text & vbCrLf

'计算坐标闭合差
reX(1) = Xb: reY(1) = Yb: Tedge = 0
For i = 2 To iStation
reX(i) = reX(i - 1) + detX(i - 1)
reY(i) = reY(i - 1) + detY(i - 1)
Tedge = Tedge + sEdge(i - 1)
Next i
If iType = 1 Then
detTX = reX(iStation) - Xc
detTY = reY(iStation) - Yc
Else
detTX = reX(iStation) - Xb
detTY = reY(iStation) - Yb
End If
detTT = Sqr(detTX * detTX + detTY * detTY)
text2.Text = text2.Text & "坐标闭合差：detX " & Format(detTX, "0.000") & " , detY " & Format(detTY, "0.000")
text2.Text = text2.Text & " , ddetTotal " & Format(detTT, "0.000") & vbCrLf
If Abs(detTT / Tedge) > 1 / 2000 Then
MsgBox "坐标闭合差超限！", , "计算终止"
text2.Text = text2.Text & "边长精度为1/" & Str(Fix(Tedge / detTT)) & "超过限差，计算终止！"
Exit Sub
End If
text2.Text = text2.Text & "边长精度为1/" & Str(Fix(Tedge / detTT)) & "附合要求。"
'改正坐标增量：以边长为权
text2.Text = text2.Text & "改正后的坐标增量：" & vbCrLf
For i = 1 To iStation - 1
detX(i) = detX(i) - sEdge(i) * detTX / Tedge
text2.Text = text2.Text & Format(detX(i), "0.000") & " , "
detY(i) = detY(i) - sEdge(i) * detTY / Tedge
text2.Text = text2.Text & Format(detY(i), "0.000") & " ; "
Next i
text2.Text = text2.Text & vbCrLf
'计算最后的坐标
text2.Text = text2.Text & "坐标计算结果：" & vbCrLf
For i = 2 To iStation
reX(i) = reX(i - 1) + detX(i - 1)
text2.Text = text2.Text & Format(reX(i - 1), "0.000") & " , "
reY(i) = reY(i - 1) + detY(i - 1)
text2.Text = text2.Text & Format(reY(i - 1), "0.000") & " ; "
Next i
text2.Text = text2.Text & Format(reX(i - 1), "0.000") & " , " & Format(reY(i - 1), "0.000") & vbCrLf & "计算结束！" & vbCrLf
End Sub
Private Sub mnuExit_Click()
End
End Sub
Private Sub mnuOpen_Click()
Dim i As Integer '循环变量
CDg1.Filter = "文本文件（*.txt）|*.txt|所有文件（*.*）|*.*"
CDg1.ShowOpen '打开对话框
strFileName = CDg1.FileName '获得选中的文件名和路径
Open strFileName For Input As #1 '打开文件
Input #1, iType, Xa, Ya, Xb, Yb '读入路线类型和前两个起算点坐标
Select Case iType
Case 0
text2.Text = text2.Text & " 这是一个闭合导线，已知点坐标为：" & vbCrLf
Case 1
text2.Text = text2.Text & " 这是一个附和导线，已知点坐标为：" & vbCrLf
Case 2
text2.Text = text2.Text & " 这是一个支导线，已知点坐标为：" & vbCrLf
End Select
text2.Text = text2.Text & Format(Xa, "0.000") & " , " & Format(Ya, "0.000") & " , " & Format(Xb, "0.000") & " , " & Format(Yb, "0.000") & vbCrLf
If iType = 1 Then '是否继续读起算坐标，要根据路线类型来判断
Input #1, Xc, Yc, Xd, Yd
text2.Text = text2.Text & Format(Xc, "0.000") & " , " & Format(Yc, "0.000") & " , " & Format(Xd, "0.000") & " , " & Format(Yd, "0.000") & vbCrLf
End If
Input #1, iStation '读入测站数，并用测站数定义数组大小
text2.Text = text2.Text & " 测站数为：" & Str(iStation) & "。因此，待定点个数为" & Str(iStation - 2) & "个。" & vbCrLf
ReDim sAngle(iStation) As Double, sdAngle(iStation + 1) As Double, sEdge(iStation - 1) As Double
ReDim detX(iStation - 1) As Double, detY(iStation - 1) As Double, reX(iStation) As Double, reY(iStation) As Double
Input #1, iAngleType
If iAngleType = 1 Then
text2.Text = text2.Text & " 观测的角度为左角，共" & Str(iStation) & "个：" & vbCrLf
Else
text2.Text = text2.Text & " 观测的角度为右角，共" & Str(iStation) & "个：" & vbCrLf
End If
For i = 1 To iStation '读入角度观测值
Input #1, sAngle(i)
text2.Text = text2.Text & Format(sAngle(i), "0.0000") & " , "
sAngle(i) = DoToHu(sAngle(i))
Next i
text2.Text = text2.Text & vbCrLf & Str(iStation - 1) & "个边长观测值为：" & vbCrLf
For i = 1 To iStation - 1 '读入边长观测值
Input #1, sEdge(i)
text2.Text = text2.Text & Format(sEdge(i), "0.000") & " , "
Next i
text2.Text = text2.Text & vbCrLf
Close #1 '不要忘记关闭文件
End Sub
Private Sub mnuSave_Click()
CDg1.Filter = "文本文件（*.txt）|*.txt|所有文件（*.*）|*.*"
CDg1.ShowSave
strFileName = CDg1.FileName
Open strFileName For Output As #1
Print #1, " ＝＝＝＝附合导线解算结果＝＝＝＝"
detA = detA * iStation
Print #1, "角度闭合差："; Format(HuToDo(detA), "0.0000"); "，角度限差："; Str(Int(40 * Sqr(iStation))); "''，符合要求。"
Print #1, "坐标闭合差：X方向"; Format(detTX, "0.000"); "，Y方向"; Format(detTY, "+0.000"); "，精度1/"; Trim(Fix(Tedge / detTT)); "，符合要求。"
Dim ts As String, i%
For i = 1 To iStation
ts = ts & Format(sAngle(i), "0.0000") & "，"
Next i
Print #1, "改正后的角度观测值："; ts
ts = ""
For i = 1 To iStation + 1
ts = ts & Format(sdAngle(i), "0.0000") & "，"
Next i
Print #1, "坐标方位角："; ts
ts = ""
For i = 1 To iStation - 1
ts = ts & Format(sEdge(i), "0.000") & "，"
Next i
Print #1, "边长观测值:"; ts
ts = ""
For i = 1 To iStation - 1
ts = ts & Format(detX(i), "0.000") & "，"
Next i
Print #1, "改正后X增量值："; ts
ts = ""
For i = 1 To iStation - 1
ts = ts & Format(detY(i), "0.000") & "，"
Next i
Print #1, "改正后Y增量值："; ts
ts = ""
For i = 1 To iStation
ts = ts & Format(reX(i), "0.000") & "，"
Next i
Print #1, "结果X坐标："; ts
ts = ""
For i = 1 To iStation
ts = ts & Format(reY(i), "0.000") & "，"
Next i
Print #1, "结果Y坐标："; ts
Print #1, " ――计算者：×××"
Print #1, " ——检核者：×××"
Print #1, " ――――――――附合导线解算结果输出完毕"
Close #1
End Sub
'求AB的坐标方位角，输出的是弧度值
Public Function DirectAB(Xa#, Ya#, Xb#, Yb#) As Double
Dim detX#, detY#, tana#
detX = Xb - Xa
detY = Yb - Ya
If Abs(detX) < 0.000001 Then
If detY > 0 Then
DirectAB = PI / 2
Else
DirectAB = PI * 3 / 2
End If
Else
tana = detY / detX
DirectAB = Atn(tana)
If detX < 0 Then
DirectAB = PI + DirectAB
ElseIf detX > 0 And detY < 0 Then
DirectAB = PI * 2 + DirectAB
End If
End If
End Function
'弧度化为度.分秒的形式：输入弧度值，输出度.分秒（各占两位）
Public Function HuToDo(ByVal Hu As Double) As Single
Dim du%, fen%, miao%
Hu = Hu * 180 / PI
du = Fix(Hu)
Hu = (Hu - du) * 60
fen = Fix(Hu)
Hu = (Hu - fen) * 60
miao = Fix(Hu + 0.5)
If miao = 60 Then
fen = fen + 1
miao = 0
End If
HuToDo = du + fen / 100 + miao / 10000
End Function
'将度.分秒形式化为弧度：输入为度.分秒形式，输出为弧度
Public Function DoToHu(ByVal DoFenMiao As Double) As Single
Dim du%, fen%, miao%, angle#
du = Fix(DoFenMiao)
DoFenMiao = (DoFenMiao - du) * 100
fen = Fix(DoFenMiao)
miao = (DoFenMiao - fen) * 100
angle = du + fen / 60 + miao / 3600
DoToHu = angle * PI / 180
End Function