📄 平面控制网间接平差.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain
BackColor = &H00004080&
Caption = "平面控制网间接平差"
ClientHeight = 3225
ClientLeft = 165
ClientTop = 855
ClientWidth = 7905
LinkTopic = "Form1"
ScaleHeight = 3225
ScaleWidth = 7905
StartUpPosition = 3 '窗口缺省
Begin MSComDlg.CommonDialog CDg1
Left = 5160
Top = 1680
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.TextBox txtShow
BackColor = &H00FFC0C0&
Height = 3015
Left = 120
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 0
Top = 120
Width = 7695
End
Begin VB.Menu mnuFile
Caption = "文件(&File)"
NegotiatePosition= 1 'Left
Begin VB.Menu mnuInput
Caption = "输入数据"
Shortcut = ^I
End
Begin VB.Menu mnuSave
Caption = "保存结果"
Shortcut = ^A
End
Begin VB.Menu mnuaa
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "关闭程序"
Shortcut = ^E
End
End
Begin VB.Menu mnuCalc
Caption = "平差计算(&Calc)"
Begin VB.Menu mnuCalcCoor
Caption = "近似坐标"
Shortcut = ^C
End
Begin VB.Menu mnuAdjust
Caption = "平差"
Shortcut = ^P
End
Begin VB.Menu mnuPointElli
Caption = "点位误差椭圆"
Shortcut = ^W
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const PI = 3.14159265358979
Const RU = 206264.8
Dim Net%, nn%, un%, tn% '网的类型，已知点个数，未知点个数，总点数
Dim Pname() As String '点名数组，大小为tn
Dim X0#(), Y0#() '已知点坐标及未知点近似坐标，大小为tn
Dim X#(), Y#() '已知点坐标及未知点平差坐标，大小为tn
Dim N500% '记录Y坐标的带号，读入数据时减该常数，输出数据时加
Dim Ne%, Nd% '边长观测值个数，方向观测值个数
Dim mM#, pP# '边长观测值的固定误差和比例误差，单位为mm和ppm
Dim bE%(), eE%(), s#() '边长观测值的起点、终点、边长
Dim mD#, Dir0#(), Dir#() '方向中误差，原始方向数组和排序后的方向数组
Dim bD0%(), eD0%(), bD%(), eD%() '方向起终点原始数组和排序后的数组
Dim Si%(), Ni%() '统计总的方向数和每个测站的方向数
Dim aa%(), bb%(), cc%() '近似坐标的计算路线，个数与未知点个数相同
Dim Pa#(700, 9), Pa3#(200, 40), W#(400) '误差方程系数（压缩方式存放）和常数向量
Dim qL#(700), qLS#(200) '误差方程权和虚拟误差方程的权
Dim Q(100, 100) As Double '协方差阵，Q=N^(-1)
Dim uW0# '单位权中误差
Dim strFileName As String
'检查数据并将点名转换为序号
'第一个参数是要检查的点名，第二个参数是得到的序号；返回值是错误号
Public Function ChkData(strP As String, Order%) As Integer
Dim i%, bFound As Boolean
Order = 0
bFound = False
For i = 1 To tn
If strP = Pname(i) Then
bFound = True
Order = i
ChkData = 0
Exit For
End If
Next i
If Not bFound Then
Open App.Path & "\err.log" For Output As #1
Print #1, "未找到的点号：" & strP & vbCrLf
Close #1
ChkData = 1
MsgBox "有未找到的点号", 1, "输入错误"
End If
End Function
'文本框大小随窗口大小的改变而改变
Private Sub Form_Resize()
txtShow.Width = frmMain.Width - 330
If frmMain.Height > 1030 Then txtShow.Height = frmMain.Height - 1030
txtShow.Left = 120
txtShow.Top = 120
End Sub
'退出程序
Private Sub mnuExit_Click()
End
End Sub
'计算近似坐标
Private Sub mnuCalcCoor_Click()
Screen.MousePointer = 13
Dim i%, j%, k% '循环变量
If Net = 1 Then '按边长计算近似坐标：使用前方交会方法
Dim Sa#, Sb#, Sc#, al#, bl#, cl# '三角形边长和三个内角
For i = 1 To un
Sc = DistAB(X0(aa(i)), Y0(aa(i)), X0(bb(i)), Y0(bb(i)))
For j = 1 To Ne
If (bE(j) = bb(i) And eE(j) = cc(i)) Or (bE(j) = cc(i) And eE(j) = bb(i)) Then Sa = s(j)
If (bE(j) = aa(i) And eE(j) = cc(i)) Or (bE(j) = cc(i) And eE(j) = aa(i)) Then Sb = s(j)
Next j
Call GetInnerAngleS(Sa, Sb, Sc, al, bl, cl) '求三角形三个内角
'调用前方交会程序计算待定点坐标
ForIntersec X0(aa(i)), Y0(aa(i)), X0(bb(i)), Y0(bb(i)), al, bl, X0(cc(i)), Y0(cc(i))
Next i
'显示计算结果
Open App.Path & "\按边长计算近似坐标.txt" For Output As #1
Print #1, "按边长计算近似坐标："
txtShow.Text = txtShow.Text & " 按边长计算近似坐标：" & vbCrLf
For i = nn + 1 To tn
Print #1, Pname(i), Format(X0(i), "0.0000"), Format(Y0(i), "0.0000")
txtShow.Text = txtShow.Text & Pname(i) & ", " & Format(X0(i), "0.0000") & ", " & Format(Y0(i), "0.0000") & vbCrLf
Next i
Close #1
End If
If Net = 2 Then '根据方向观测值计算近似坐标：使用前方交会方法
Dim Ta#, Tb# '用于交会的两个角
For i = 1 To un
Ta = GetBeta(bb(i), aa(i), cc(i), j) '求角A
Tb = GetBeta(aa(i), bb(i), cc(i), j) '求角B
'调用前方交会程序计算待定点坐标
ForIntersec X0(aa(i)), Y0(aa(i)), X0(bb(i)), Y0(bb(i)), Ta, Tb, X0(cc(i)), Y0(cc(i))
Next i
Open App.Path & "\按方向计算近似坐标.txt" For Output As #1
Print #1, "按方向计算近似坐标："
txtShow.Text = txtShow.Text & " 按方向计算近似坐标：" & vbCrLf
For i = nn + 1 To tn
Print #1, Pname(i), Format(X0(i), "0.0000"), Format(Y0(i), "0.0000")
txtShow.Text = txtShow.Text & Pname(i) & ", " & Format(X0(i), "0.0000") & ", " & Format(Y0(i), "0.0000") & vbCrLf
Next i
Close #1
End If
If Net > 2 Then '根据边角条件计算近似坐标：使用极坐标方法
Dim dblS#, dblA#, dblD# '极坐标方法中的边长、夹角、方位角
Dim dir1#, dir2#, bF As Boolean '两个临时的方向，一个逻辑开关
For i = nn + 1 To tn
For j = Si(i) To Si(i) + Ni(i) - 1
If eD(j) < i Then
'如果搜索要用到的边长和方向值，则根据极坐标法计算待丁点坐标
If FoundSid(eD(j), i, dblS) And FoundDir1(eD(j), i, dir1) Then
bF = False
For k = Si(eD(j)) To Si(eD(j)) + Ni(eD(j)) - 1
If eD(k) < i Then
dir2 = Dir(k): bF = True
dblA = dir1 - dir2: If dblA < 0 Then dblA = dblA + 2 * PI
'调用极坐标方法求点的坐标
PolarPositioning X0(eD(k)), Y0(eD(k)), X0(eD(j)), Y0(eD(j)), dblS, dblA, X0(i), Y0(i)
Exit For
End If
Next k
If bF Then Exit For
End If
End If
Next j
Next i
txtShow.Text = txtShow.Text & " 按全边角网计算近似坐标(m):" & vbCrLf
Open App.Path & "\按全边角网计算近似坐标.txt" For Output As #1
Print #1, " 按全边角网计算近似坐标(m)："
For i = nn + 1 To tn
Print #1, Pname(i), Format(X0(i), "0.0000"), Format(Y0(i), "0.0000")
txtShow.Text = txtShow.Text & Str(Pname(i)) & " " & Format(X0(i), "0.0000") & " , " & Format(Y0(i), "0.0000") & vbCrLf
Next i
Close #1
End If
Screen.MousePointer = 0
End Sub
'搜索已知起点和终点的边
Public Function FoundSid(beNode%, enNode%, dblS#) As Boolean
Dim k% '循环变量
FoundSid = False
For k = 1 To Ne
If (bE(k) = beNode And eE(k) = enNode) Or (bE(k) = enNode And eE(k) = beNode) Then
dblS = s(k)
FoundSid = True
Exit Function
End If
Next k
End Function
'搜索已知起点和终点的起始方向值
Public Function FoundDir1(beNode%, enNode%, dblDir#) As Boolean
Dim k% '循环变量
FoundDir1 = False
For k = Si(beNode) To Si(beNode) + Ni(beNode) - 1
If eD(k) = enNode Then
dblDir = Dir(k)
FoundDir1 = True
Exit Function
End If
Next k
End Function
'搜索已知起点和终点的终止方向值
Public Function FoundDir2(beNode%, enNode%, dblDir#) As Boolean
Dim k% '循环变量
FoundDir2 = False
For k = Si(beNode) To Si(beNode) + Ni(beNode) - 1
If eD(k) < enNode Then
dblDir = Dir(k)
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -