《VB坐标转换程序设计.doc》由会员分享，可在线阅读，更多相关《VB坐标转换程序设计.doc（20页珍藏版）》请在三一办公上搜索。
1、Option ExplicitDim k2#, e2#, dX2#, dY2# Dim x2#, Xx2#, y2#, Yy2# Dim k3#, Ex#, Ey#, Ez#, dX3#, dY3#, dZ3# Dim X3#, Y3#, Z3#, Xx3#, Yy3#, Zz3# Const PI = 3.14159265358979Private Sub Check1_Click() If Check1.Value = 1 Then frmCoorTrans.Height = 5175 ElseIf Check1.Value = 0 Then frmCoorTrans.Height = 4
2、440 End IfEnd SubPrivate Sub cmdBrowFile_Click() CDg1.Filter = 控制点文件 (*.gcp)|*.gcp|所有文件 (*.*)|*.* CDg1.Action = 1 txtFileName.Text = CDg1.FileNameEnd SubPrivate Sub cmdCalc_Click() Dim s As String, iPos%, i%, iCent! Dim n%, x1#(), y1#(), x2#(), y2#() Dim A() As Double, L() As Double, x(1 To 4) As Do
3、uble Dim At#(), Naa#(), W#() Open txtFileName.Text For Input As #1 Line Input #1, s n = Val(s) ReDim x1#(n), y1#(n), x2#(n), y2#(n) For i = 1 To n Line Input #1, s iPos = InStr(s, ,) x1(i) = Val(Left(s, iPos - 1) s = Mid(s, iPos + 1) iPos = InStr(s, ,) y1(i) = Val(Left(s, iPos - 1) s = Mid(s, iPos +
4、 1) iPos = InStr(s, ,) x2(i) = Val(Left(s, iPos - 1) s = Mid(s, iPos + 1) y2(i) = Val(s) Next i Close #1 计算转换参数 ReDim A(1 To 2 * n, 1 To 4) As Double, L(1 To 2 * n) As Double ReDim At(1 To 4, 1 To 2 * n), Naa(1 To 4, 1 To 4), W(1 To 4) Debug.Print 系数矩阵A：For i = 1 To n A(2 * i - 1, 1) = 1: A(2 * i -
5、1, 2) = 0: A(2 * i - 1, 3) = x1(i): A(2 * i - 1, 4) = y1(i) Debug.Print A(2 * i - 1, 1), A(2 * i - 1, 2), A(2 * i - 1, 3), A(2 * i - 1, 4) A(2 * i, 1) = 0: A(2 * i, 2) = 1: A(2 * i, 3) = y1(i): A(2 * i, 4) = -x1(i) Debug.Print A(2 * i, 1), A(2 * i, 2), A(2 * i, 3), A(2 * i, 4) L(2 * i - 1) = x2(i):
6、L(2 * i) = y2(i) Next i Debug.Print 常数向量L： For i = 1 To 2 * n Debug.Print L(i) Next i MatrixTrans A, At Debug.Print A的转置矩阵： ShowMatrix At Matrix_Multy Naa, At, A Debug.Print Naa： ShowMatrix Naa Matrix_Multy W, At, L Debug.Print W： For i = 1 To 4 Debug.Print W(i) Next i MajorInColGuass Naa, W, x Debu
7、g.Print X For i = 1 To 4 Debug.Print x(i) Next i 分离旋转和尺度参数 If Abs(x(3) 0 Then e2 = PI / 2 Else e2 = PI * 3 / 2 End If Else e2 = Atn(x(4) / x(3) 得到的是弧度 If x(3) 0 Then e2 = PI - e2 ElseIf x(3) 0 And x(4) 0 And x(4) 0 Then e2 = PI * 2 + e2 End If End If k2 = x(3) / Cos(e2) 将转换参数写入相应文本框 txtK2 = Str(k2 -
8、 1) e2 = e2 * 180 / PI Dim du%, fen% du = Int(e2): e2 = (e2 - du) * 60 fen = Int(e2): e2 = (e2 - fen) * 60 e2 = Val(Format(e2, 0.00) e2 = du + fen / 100# + e2 / 10000 txtE2 = Str(e2) txtdX2.Text = Str(x(1) txtdY2.Text = Str(x(2)End SubPrivate Sub cmdCalc2_Click() k2 = Val(txtK2.Text) e2 = Val(txtE2.
9、Text) e2 = DoToHu(e2) dX2 = Val(txtdX2.Text) dY2 = Val(txtdY2.Text) x2 = Val(txtX2.Text) y2 = Val(txtY2.Text) Xx2 = (k2 + 1) * (x2 * Cos(e2) + y2 * Sin(e2) + dX2 Yy2 = (k2 + 1) * (y2 * Cos(e2) - x2 * Sin(e2) + dY2 txtXx2.Text = Format(Xx2, 0.0000) txtYy2.Text = Format(Yy2, 0.0000)End SubPrivate Sub
10、cmdCalc3_Click() k3 = Val(txtK3.Text) Ex = Val(txtEx.Text) Ex = DoToHu(Ex) Ey = Val(txtEy.Text) Ey = DoToHu(Ey) Ez = Val(txtEz.Text) Ez = DoToHu(Ez) dX3 = Val(txtdX3.Text) dY3 = Val(txtdY3.Text) dZ3 = Val(txtDz3.Text) X3 = Val(txtX3.Text) Y3 = Val(txtY3.Text) Z3 = Val(txtZ3.Text) Xx3 = (k3 + 1) * (X
11、3 * Cos(Ey) * Cos(Ez) + Y3 * Cos(Ey) * Sin(Ez) - Z3 * Sin(Ey) + dX3 Yy3 = (k3 + 1) * (X3 * (-Cos(Ex) * Sin(Ez) + Sin(Ex) * Sin(Ey) * Cos(Ez) + Y3 * (Cos(Ex) * Cos(Ez) + Sin(Ex) * Sin(Ey) * Sin(Ez) + Z3 * (Sin(Ex) * Cos(Ey) + dY3 Zz3 = (k3 + 1) * (X3 * (Sin(Ex) * Sin(Ez) + Cos(Ex) * Sin(Ey) * Cos(Ez)
12、 + Y3 * (-Sin(Ex) * Cos(Ez) + Cos(Ex) * Sin(Ey) * Sin(Ez) + Z3 * (Cos(Ex) * Cos(Ey) + dZ3 txtXx3.Text = Format(Xx3, 0.0000) txtYy3.Text = Format(Yy3, 0.0000) txtZz3.Text = Format(Zz3, 0.0000)End SubPrivate Sub cmdClear2_Click() txtX2.Text = txtY2.Text = txtXx2.Text = txtYy2.Text = End SubPrivate Sub
13、 cmdClear3_Click() txtX3.Text = txtY3.Text = txtZ3.Text = txtXx3.Text = txtYy3.Text = txtZz3.Text = End SubPrivate Sub cmdconCalc2_Click() k2 = Val(txtK2.Text) e2 = Val(txtE2.Text) e2 = DoToHu(e2) dX2 = Val(txtdX2.Text) dY2 = Val(txtdY2.Text) Xx2 = Val(txtXx2.Text) Yy2 = Val(txtYy2.Text) x2 = (Xx2 -
14、 dX2) * Cos(e2) - (Yy2 - dY2) * Sin(e2) / (k2 + 1) y2 = (Yy2 - dY2) * Cos(e2) + (Xx2 - dX2) * Sin(e2) / (k2 + 1) txtX2.Text = Format(x2, 0.0000) txtY2.Text = Format(y2, 0.0000)End SubPrivate Sub cmdconCalc3_Click() k3 = Val(txtK3.Text) Ex = Val(txtEx.Text) Ex = DoToHu(Ex) Ey = Val(txtEy.Text) Ey = D
15、oToHu(Ey) Ez = Val(txtEz.Text) Ez = DoToHu(Ez) dX3 = Val(txtdX3.Text) dY3 = Val(txtdY3.Text) dZ3 = Val(txtDz3.Text) Xx3 = Val(txtXx3.Text) Yy3 = Val(txtYy3.Text) Zz3 = Val(txtZz3.Text) X3 = (Xx3 - dX3) * Cos(Ey) * Cos(Ez) + (Yy3 - dY3) * (-Cos(Ex) * Sin(Ez) + Sin(Ex) * Sin(Ey) * Cos(Ez) + (Zz3 - dZ3
16、) * (Sin(Ex) * Sin(Ez) + Cos(Ex) * Sin(Ey) * Cos(Ez) / (k3 + 1) Y3 = (Xx3 - dX3) * Cos(Ey) * Sin(Ez) + (Yy3 - dY3) * (Sin(Ex) * Sin(Ey) * Sin(Ez) + Cos(Ex) * Cos(Ez) + (Zz3 - dZ3) * (-Sin(Ex) * Cos(Ez) + Cos(Ex) * Sin(Ey) * Sin(Ez) / (k3 + 1) Z3 = (Xx3 - dX3) * (-Sin(Ey) + (Yy3 - dY3) * Sin(Ex) * Co
17、s(Ey) + (Zz3 - dZ3) * (Cos(Ex) * Cos(Ey) / (k3 + 1) txtX3.Text = Format(X3, 0.0000) txtY3.Text = Format(Y3, 0.0000) txtZ3.Text = Format(Z3, 0.0000)End SubPrivate Sub cmdExit_Click() EndEnd SubPrivate Sub Form_Load() frmCoorTrans.Height = 4440End Sub弧度化为度.分秒的形式：输入弧度值，输出度.分秒（各占两位）Public Function HuToD
18、o(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 / 10000End Function将度.分秒形式化为弧度：输入为度.分秒形式，输出为弧度Public Functio
19、n 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 / 180End Function矩阵转置的通用过程Public Sub MatrixTrans(A, At) Dim i%
20、, j% Dim R1%, C1% On Error Resume Next C1 = UBound(A, 2) - LBound(A, 2) + 1 If Err Then MsgBox 输入的矩阵维数不对！ Exit Sub End If R1 = UBound(A, 1) - LBound(A, 1) + 1 ReDim c(1 To C1, 1 To R1) For i = 1 To R1 For j = 1 To C1 At(j, i) = A(i, j) Next j Next iEnd Sub矩阵相乘：输入矩阵或数Qa、Qb，自动识别它们的维数，并输出它们的乘积QnPublic
21、Sub Matrix_Multy(Qn, Qa, Qb) Dim ia%, ib%, ic% Dim ai%, bi%, ci% Dim e1 As Boolean, e2 As Boolean, e3 As Boolean, e4 As Boolean, e5 As Boolean, e6 As Boolean, e7 As Boolean On Error Resume Next 看Qa是不是一维数组 ic = UBound(Qa, 2) - LBound(Qa, 2) If Err Then e1 = True On Error Resume Next 看Qa是不是一维数组 ib = U
22、Bound(Qb, 2) - LBound(Qb, 2) If Err Then e2 = True If e1 = False And e2 = False Then 二维矩阵相乘 For ai = LBound(Qa, 1) To UBound(Qa, 1) For bi = LBound(Qb, 2) To UBound(Qb, 2) For ci = LBound(Qa, 2) To UBound(Qa, 2) Qn(ai, bi) = Qn(ai, bi) + Qa(ai, ci) * Qb(ci, bi) Next ci Next bi Next ai ElseIf e1 = Tr
23、ue And e2 = False Then On Error Resume Next ia = UBound(Qa) - LBound(Qa) If Err Then e6 = True If e6 Then 数乘以二维矩阵 For ai = LBound(Qb, 1) To UBound(Qb, 1) For bi = LBound(Qb, 2) To UBound(Qb, 2) Qn(ai, bi) = Qa * Qb(ai, bi) Next bi Next ai Else 一维矩阵乘以二维矩阵 For ci = LBound(Qb, 2) To UBound(Qb, 2) For a
24、i = LBound(Qa, 1) To UBound(Qa, 1) Qn(ci) = Qn(ci) + Qa(ai) * Qb(ai, ci) Next ai Next ci End If ElseIf e1 = False And e2 = True Then On Error Resume Next ic = UBound(Qb) - LBound(Qb) If Err Then e7 = True If e7 Then 二维矩阵乘以数 For ai = LBound(Qa, 1) To UBound(Qa, 1) For bi = LBound(Qa, 2) To UBound(Qa,
25、 2) Qn(ai, bi) = Qa(ai, bi) * Qb Next bi Next ai Else 二维矩阵乘以一维矩阵 For ai = LBound(Qa, 1) To UBound(Qa, 1) For bi = LBound(Qa, 2) To UBound(Qa, 2) Qn(ai) = Qn(ai) + Qa(ai, bi) * Qb(bi) Next bi Next ai End If Else Dim errT As Integer On Error Resume Next 结果是否是一个数 errT = UBound(Qn) If Err Then e3 = True
26、 If e3 Then 一维矩阵乘以一维矩阵得一个数 For ai = LBound(Qa, 1) To UBound(Qa, 1) For bi = LBound(Qa, 2) To UBound(Qa, 2) Qn = Qn + Qa(ai) * Qb(bi) Next bi Next ai Exit Sub End If On Error Resume Next 是否是数乘一维矩阵 ia = UBound(Qa) - LBound(Qa) If Err Then e4 = True If e4 Then For bi = LBound(Qa, 2) To UBound(Qa, 2) Qn
27、(bi) = Qa * Qb(bi) Next bi Exit Sub End If On Error Resume Next 是否是一维矩阵乘数 ib = UBound(Qb) - LBound(Qb) If Err Then e5 = True If e5 Then For ai = LBound(Qa, 1) To UBound(Qa, 1) Qn(ai) = Qa(ai) * Qb Next ai Exit Sub End If 一维矩阵相乘结果是二维矩阵 For ai = LBound(Qa, 1) To UBound(Qa, 1) For bi = LBound(Qa, 2) To
28、 UBound(Qa, 2) Qn(ai, bi) = Qa(ai) * Qb(bi) Next bi Next ai End IfEnd SubPublic Sub ShowMatrix(tt) Dim i%, j%, n%, m% m = UBound(tt, 1) - LBound(tt, 1) + 1 n = UBound(tt, 2) - LBound(tt, 2) + 1 For i = 1 To m For j = 1 To n Debug.Print tt(i, j), Next j Debug.Print Next iEnd Sub列选主元法Guass约化求解线性方程组Pub
29、lic Sub MajorInColGuass(A, b, x) Dim Row%, Col%, n% 矩阵大小 Dim iStep%, iRow%, iCol% 循环变量 Dim L() As Double 各行的约化系数 计算并检查矩阵的大小 Row = UBound(A, 1) - LBound(A, 1) + 1 Col = UBound(A, 2) - LBound(A, 2) + 1 If Row Col Then MsgBox 方程组的系数矩阵有误！ Exit Sub End If 准备约化过程的变量和数组 n = UBound(b) - LBound(b) + 1 If n R
30、ow Then MsgBox 方程组的系数矩阵与常数项大小不符！ Exit Sub End If ReDim L(2 To Row) As Double Dim sumAX As Double, iPos%, temp# 约化过程 For iStep = 1 To n - 1 列选主元 iPos = 0 For iRow = iStep + 1 To n If Abs(A(iRow, iStep) Abs(A(iStep, iStep) Then iPos = iRow End If Next iRow If iPos iStep Then 需要换主元 For iCol = iStep To
31、n temp = A(iStep, iCol) A(iStep, iCol) = A(iPos, iCol) A(iPos, iCol) = temp Next iCol temp = b(iStep) b(iStep) = b(iPos) b(iPos) = temp End If 约化过程 For iRow = iStep + 1 To n L(iRow) = A(iRow, iStep) / A(iStep, iStep) For iCol = iStep To n A(iRow, iCol) = A(iRow, iCol) - L(iRow) * A(iStep, iCol) Next
32、 iCol b(iRow) = b(iRow) - L(iRow) * b(iStep) Next iRow Next iStep 回代过程 x(n) = b(n) / A(n, n) For iRow = n - 1 To 1 Step -1 sumAX = 0 For iCol = n To iRow + 1 Step -1 sumAX = sumAX + A(iRow, iCol) * x(iCol) Next iCol x(iRow) = (b(iRow) - sumAX) / A(iRow, iRow) Next iRowEnd SubOption ExplicitDim iMark
33、% 测站计数器Dim dist!, dH!Private Sub cmdCancel_Click() 清除已经传给主窗体的数据 Dim i% For i = 1 To iMark dis(i) = 0 detH(i) = 0 Next i 清除主窗体的显示 frmMain.txtShowResult.Text = 水准计算结果: 卸载输入窗体 Unload MeEnd SubPrivate Sub cmdOK_Click() dist = Val(txtDist.Text) dH = Val(txtDetH.Text) Call AddData(iMark, dist, dH) 在主窗体显示本
34、站数据 frmMain.txtShowResult = frmMain.txtShowResult & 第 & Str(iMark) & 站： & vbCrLf frmMain.txtShowResult = frmMain.txtShowResult & 距离： & dis(iMark) & 高差中数： & detH(iMark) & vbCrLf If iMark = nMarks Then 如果已经输入完所有的测站观测值 frmInput.Hide Else 若还没有输完，初始化输入界面输入下一个测站 txtDist.Text = txtDetH.Text = txtDist.SetFo
35、cus End If frmInput.Caption = 观测数据输入：第 & Trim(Str(iMark) & 站 iMark = iMark + 1 测站数加1End SubPrivate Sub Form_Load() iMark = 1End SubOption ExplicitDim iMark% 测站计数器Dim dist!, dH!Private Sub cmdCancel_Click() 清除已经传给主窗体的数据 Dim i% For i = 1 To iMark dis(i) = 0 detH(i) = 0 Next i 清除主窗体的显示 frmMain.txtShowR
36、esult.Text = 水准计算结果: 卸载输入窗体 Unload MeEnd SubPrivate Sub cmdOK_Click() dist = Val(txtDist.Text) dH = Val(txtDetH.Text) Call AddData(iMark, dist, dH) 在主窗体显示本站数据 frmMain.txtShowResult = frmMain.txtShowResult & 第 & Str(iMark) & 站： & vbCrLf frmMain.txtShowResult = frmMain.txtShowResult & 距离： & dis(iMark) & 高差中数： & detH(iMark) & vbCrLf If iMark = nMarks Then 如果已经输入完所有的测站观测值 frmInput.Hide Else 若还没有输
