三维坐标转换 把文件导入之后总是显示超出文件尾
Dim k3#, Ex#, Ey#, Ez#, dX3#, dY3#, dZ3# '尺度参数,三个旋转参数,三个平移参数
Dim X3#, Y3#, Z3#, Xx3#, Yy3#, Zz3# '三维坐标转换的正算数值
'将度.分秒形式化为弧度:输入为度.分秒形式,输出为弧度
Public Function DoToHu(ByVal DoFenMiao As Double) As Single
Const pi As Double = 3.14159265358979
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
'弧度化为度.分秒的形式:输入弧度值,输出度.分秒(各占两位)
Public Function HuToDo(ByVal Hu As Double) As Single
Const pi As Double = 3.14159265358979
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 Sub MatrixTrans(A() As Double, At() As Double)
Dim i As Integer, j As Integer, rows As Integer, cols As Integer
rows = UBound(A, 1)
cols = UBound(A, 2)
ReDim At(1 To cols, 1 To rows)
For i = 1 To rows
For j = 1 To cols
At(j, i) = A(i, j)
Next j
Next i
End Sub
'矩阵相乘:输入矩阵或数Qa、Qb,自动识别它们的维数,并输出它们的乘积Qn
Public Sub Matrix_Multy(C() As Double, A() As Double, b() As Double)
Dim i As Integer, j As Integer, k As Integer, rowsA As Integer, colsA As Integer, rowsB As Integer, colsB As Integer
rowsA = UBound(A, 1)
colsA = UBound(A, 2)
rowsB = UBound(b, 1)
colsB = UBound(b, 2)
ReDim C(1 To rowsA, 1 To colsB)
For i = 1 To rowsA
For j = 1 To colsB
C(i, j) = 0
For k = 1 To colsA
C(i, j) = C(i, j) + A(i, k) * b(k, j)
Next k
Next j
Next i
End Sub
' 高斯消元法解线性方程组
Sub MajorInColGuass(A() As Double, b() As Double, x() As Double)
Dim n As Integer, i As Integer, j As Integer, k As Integer
Dim maxRow As Integer, temp As Double
n = UBound(A, 1)
ReDim x(1 To n)
' 高斯消元
For k = 1 To n - 1
maxRow = k
For i = k + 1 To n
If Abs(A(i, k)) > Abs(A(maxRow, k)) Then maxRow = i
Next i
If maxRow <> k Then
For j = k To n
temp = A(k, j)
A(k, j) = A(maxRow, j)
A(maxRow, j) = temp
Next j
temp = b(k)
b(k) = b(maxRow)
b(maxRow) = temp
End If
For i = k + 1 To n
temp = A(i, k) / A(k, k)
For j = k + 1 To n
A(i, j) = A(i, j) - temp * A(k, j)
Next j
b(i) = b(i) - temp * b(k)
Next i
Next k
' 回代求解
For i = n To 1 Step -1
x(i) = b(i)
For j = i + 1 To n
x(i) = x(i) - A(i, j) * x(j)
Next j
x(i) = x(i) / A(i, i)
Next i
End Sub
Private Sub Check1_Click()
If Check1.Value = 1 Then
Check1.Height = 5175
ElseIf Check1.Value = 0 Then
Check1.Height = 4440
End If
End Sub
Private Sub cmdBrowFile_Click()
CommonDialog1.Filter = "控制点文件 (*.gcp)|*.gcp|所有文件 (*.*)|*.*"
CommonDialog1.Action = 1
txtFileName.Text = CommonDialog1.FileName
End Sub
Private Sub cmdCalc_Click()
Dim s As String, n As Integer, i As Integer
Dim x1() As Double, y1() As Double, z1() As Double
Dim x2() As Double, y2() As Double, z2() As Double
Dim A() As Double, At() As Double, Naa() As Double, W() As Double, L() As Double
Dim x(1 To 4) As Double
Dim Ex As Double, k3 As Double
Dim du As Integer, fen As Integer
' 打开文件并读取数据
Open txtFileName.Text For Input As #1
Line Input #1, s
n = Val(s)
Debug.Print "Number of points: " & n
If n <= 0 Then
MsgBox "Invalid number of points."
Exit Sub
End If
ReDim x1(n), y1(n), z1(n), x2(n), y2(n), z2(n)
For i = 1 To n
If EOF(1) Then
MsgBox "File ended unexpectedly. Not enough data points."
Exit Sub
End If
Input #1, x1(i), y1(i), z1(i), x2(i), y2(i), z2(i)
Next i
Close #1
' 初始化矩阵
ReDim A(1 To 2 * n, 1 To 4)
ReDim L(1 To 2 * n)
ReDim At(1 To 4, 1 To 2 * n)
ReDim Naa(1 To 4, 1 To 4)
ReDim W(1 To 4)
' 填充矩阵 A 和 L
For i = 1 To n
If i > UBound(x1) Or i > UBound(y1) Or i > UBound(z1) Or i > UBound(x2) Or i > UBound(y2) Or i > UBound(z2) Then
MsgBox "Array index out of bounds."
Exit Sub
End If
A(2 * i - 1, 1) = 1: A(2 * i - 1, 2) = 0: A(2 * i - 1, 3) = x1(i): A(2 * i - 1, 4) = y1(i)
A(2 * i, 1) = 0: A(2 * i, 2) = 1: A(2 * i, 3) = -z1(i): A(2 * i, 4) = x1(i)
L(2 * i - 1) = x2(i): L(2 * i) = y2(i)
Next i
If UBound(A, 1) <> 2 * n Or UBound(A, 2) <> 4 Then
MsgBox "Matrix A dimensions are incorrect."
Exit Sub
End If
If UBound(At, 1) <> 4 Or UBound(At, 2) <> 2 * n Then
MsgBox "Matrix At dimensions are incorrect."
Exit Sub
End If
If UBound(Naa, 1) <> 4 Or UBound(Naa, 2) <> 4 Then
MsgBox "Matrix Naa dimensions are incorrect."
Exit Sub
End If
If UBound(W, 1) <> 4 Then
MsgBox "Matrix W dimensions are incorrect."
Exit Sub
End If
If UBound(L, 1) <> 2 * n Then
MsgBox "Matrix L dimensions are incorrect."
Exit Sub
End If
' 矩阵运算
MatrixTrans A, At
Matrix_Multy Naa, At, A
Matrix_Multy W, At, L
MajorInColGuass Naa, W, x
' 分离旋转和尺度参数
If Abs(x(3)) < 0.00000001 Then
If x(4) > 0 Then
Ex = pi / 2
Else
Ex = pi * 3 / 2
End If
Else
Ex = Atn(x(4) / x(3))
If x(3) < 0 And x(4) > 0 Then
Ex = pi - Ex
ElseIf x(3) < 0 And x(4) < 0 Then
Ex = pi + Ex
ElseIf x(3) > 0 And x(4) < 0 Then
Ex = pi * 2 + Ex
End If
End If
k3 = x(3) / Cos(Ex)
' 将转换参数写入相应文本框
txtK3 = Str(k3 - 1)
Ex = Ex * 180 / pi
du = Int(Ex): Ex = (Ex - du) * 60
fen = Int(Ex): Ex = (Ex - fen) * 60
Ex = Val(Format(Ex, "0.00"))
Ex = du + fen / 100# + Ex / 10000
txtEx.Text = Str(Ex)
textEy.Text = Str(Ey)
txtEz.Text = Str(Ez)
txtdX3.Text = Str(x(1))
txtdY3.Text = Str(x(2))
txtdZ3.Text = Str(x(3))
End Sub
Private Sub 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) * (X3 * 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)) + 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 Sub
Private Sub cmdClear3_Click()
txtK3.Text = ""
txtEx.Text = ""
txtEy.Text = ""
txtEz.Text = ""
txtdX3.Text = ""
txtdY3.Text = ""
txtdZ3.Text = ""
txtX3.Text = ""
txtY3.Text = ""
txtZ3.Text = ""
txtXx3.Text = ""
txtYy3.Text = ""
txtZz3.Text = ""
End Sub
Private Sub cmdconCalc3_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)
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) * (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) * Cos(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 Sub
Private Sub Command12_Click()
End
End Sub