module2.bas

摄影测量影象匹配

Attribute VB_Name = "过程定义集合"
Option Explicit

Public Sub huidujisuan(huidul As Long, huiji As Single)   '将长整型的灰度的数值转换到0-255之间
Dim r As Single, g As Single, b As Single

r = huidul Mod 256
g = (huidul Mod 65536) / 256
b = (huidul Mod 16777216) / 65536
huiji = (77 * r + 150 * g + 29 * b) \ 256

End Sub




Public Sub x_xt(X As Single, Y As Single, xa1 As Double, xb1 As Double, xc1 As Double, xa2 As _
Double, xb2 As Double, xc2 As Double, xa3 As Double, xb3 As Double, xc3 As Double) '将倾斜照片的像平面坐标转换到与之对应的水平坐标系中
Dim xt As Single, yt As Single, fenmu As Double, fenzi As Double

fenzi = (f * xa2 + xa3 * Y) * (xc1 * f ^ 2 + xc3 * X * f) - (xc2 * f ^ 2 + xc3 * Y * f) * (f * xa1 + xa3 * X)
fenmu = (f * xa2 + xa3 * Y) * (f * xb1 + xb3 * X) - (f * xb2 + xb3 * Y) * (f * xa1 + xa3 * X)
yt = fenzi / fenmu
fenzi = X * xc3 * f - xb3 * X * yt - f * xb1 * yt + xc1 * f ^ 2
fenmu = f * xa1 + xa3 * X
xt = fenzi / fenmu

X = xt
Y = yt

End Sub



Public Sub xt_x(xt As Single, yt As Single, xa1 As Double, xb1 As Double, xc1 As Double, xa2 As _
Double, xb2 As Double, xc2 As Double, xa3 As Double, xb3 As Double, xc3 As Double) '将水平像平面坐标系中的坐标的数值转换与之对应的倾斜像平面坐标中
Dim X As Single, Y As Single
Dim fenmu  As Double, fenzi As Double

fenmu = xa3 * xt + xb3 * yt - xc3 * f
fenzi = xa1 * xt + xb1 * yt - xc1 * f
X = -f * fenzi / fenmu
fenzi = xa2 * xt + xb2 * yt - xc2 * f
Y = -f * fenzi / fenmu
xt = X
yt = Y

End Sub



Public Sub jiaohanshu(xq As Double, xw As Double, xk As Double, xa1 As Double, xa2 As Double, xa3 As _
Double, xb1 As Double, xb2 As Double, xb3 As Double, xc1 As Double, xc2 As Double, xc3 As Double) '计算左右影象的六个角函数的数值

xa1 = Cos(xq) * Cos(xk) - Sin(xq) * Sin(xw) * Sin(xk)
xa2 = -Cos(xq) * Sin(xk) - Sin(xq) * Sin(xw) * Cos(xk)
xa3 = -Sin(xq) * Cos(xw)

xb1 = Cos(xw) * Sin(xk)
xb2 = Cos(xw) * Cos(xk)
xb3 = -Sin(xw)

xc1 = Sin(xq) * Cos(xk) + Cos(xq) * Sin(xw) * Sin(xk)
xc2 = -Sin(xq) * Sin(xk) + Cos(xq) * Sin(xw) * Cos(xk)
xc3 = Cos(xq) * Cos(xw)

End Sub


Public Sub chongcaiyang(x1 As Single, y1 As Single, xhui1 As Single, xhui2 _
As Single, xhui3 As Single, xhui4 As Single, huicha As Single)      '双线性插值采样点的灰度的数值

    Dim fenmu As Double, fenzi As Double
fenmu = (jiange ^ 2)
fenzi = (jiange - x1) * (jiange - y1) * xhui1 + (jiange - y1) * x1 * xhui2 + x1 * y1 * xhui3 + _
(jiange - x1) * y1 * xhui4
huicha = fenzi / fenmu

End Sub
Function MRinv(n As Integer, mtxA() As Double) As Boolean
    ' 局部变量
    ReDim nIs(n) As Integer, nJs(n) As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim d As Double, p As Double

    ' 全选主元，消元
    For k = 1 To n
        d = 0#
        For i = k To n
            For j = k To n
                p = Abs(mtxA(i, j))
                If (p > d) Then
                    d = p
                    nIs(k) = i
                    nJs(k) = j
                End If
            Next j
        Next i
        
        ' 求解失败
        If (d + 1# = 1#) Then
            MRinv = False
            Exit Function
        End If

        If (nIs(k) <> k) Then
            For j = 1 To n
                p = mtxA(k, j)
                mtxA(k, j) = mtxA(nIs(k), j)
                mtxA(nIs(k), j) = p
            Next j
        End If

        If (nJs(k) <> k) Then
            For i = 1 To n
                p = mtxA(i, k)
                mtxA(i, k) = mtxA(i, nJs(k))
                mtxA(i, nJs(k)) = p
            Next i
        End If

        mtxA(k, k) = 1# / mtxA(k, k)
        For j = 1 To n
            If (j <> k) Then mtxA(k, j) = mtxA(k, j) * mtxA(k, k)
        Next j
        For i = 1 To n
            If (i <> k) Then
                For j = 1 To n
                    If (j <> k) Then mtxA(i, j) = mtxA(i, j) - mtxA(i, k) * mtxA(k, j)
                Next j
            End If
        Next i
        For i = 1 To n
            If (i <> k) Then mtxA(i, k) = -mtxA(i, k) * mtxA(k, k)
        Next i
    Next k

    ' 调整恢复行列次序
    For k = n To 1 Step -1
        If (nJs(k) <> k) Then
          For j = 1 To n
              p = mtxA(k, j)
              mtxA(k, j) = mtxA(nJs(k), j)
              mtxA(nJs(k), j) = p
          Next j
        End If
        If (nIs(k) <> k) Then
          For i = 1 To n
              p = mtxA(i, k)
              mtxA(i, k) = mtxA(i, nIs(k))
              mtxA(i, nIs(k)) = p
          Next i
        End If
    Next k
    
    ' 求解成功
    MRinv = True

End Function

Public Sub MTrans(m As Integer, n As Integer, a() As Double, mtxAt() As Double)
Dim i As Integer, j As Integer
    For i = 1 To n
        For j = 1 To m
            mtxAt(i, j) = a(j, i)
        Next j
    Next i
End Sub

Public Sub MMul(m As Integer, n As Integer, l As Integer, mtxbt() As Double, mtxB() As Double, mtxC() As Double)
    Dim i As Integer, j As Integer, k As Integer
    For i = 1 To m
        For j = 1 To l
            mtxC(i, j) = 0#
            For k = 1 To n
                mtxC(i, j) = mtxC(i, j) + mtxbt(i, k) * mtxB(k, j)
            Next k
        Next j
    Next i

End Sub