mdladjust.bas

采用VB编写

Attribute VB_Name = "mdlAdjust"
Const PI = 3.14159265358932


'求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
    If fen = 60 Then
        du = du + 1
        fen = 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

'矩阵转置的通用过程
Public Sub MatrixTrans(A, c)
    Dim i%, 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
            c(j, i) = A(i, j)
        Next j
    Next i
End Sub

'矩阵相加的通用过程
Public Sub MatrixPlus(A, b, c)
    Dim i%, j%
    Dim R1%, C1%, R2%, C2%
    On Error Resume Next
    C1 = UBound(A, 2) - LBound(A, 2) + 1
    If Err Then
        MsgBox "第一个矩阵维数不对！"
        Exit Sub
    End If
    On Error Resume Next
    C2 = UBound(b, 2) - LBound(b, 2) + 1
    If Err Then
        MsgBox "第二个矩阵维数不对！"
        Exit Sub
    End If
    R1 = UBound(A, 1) - LBound(A, 1) + 1
    R2 = UBound(b, 1) - LBound(b, 1) + 1

    If R1 <> R2 Or C1 <> C2 Then
        MsgBox "输入的两个矩阵维数不等，不能相加！"
        Exit Sub
    End If

    ReDim c(1 To m, 1 To n) As Double
    For i = 1 To m
        For j = 1 To n
            c(i, j) = A(i, j) + b(i, j)
        Next j
    Next i
End Sub

'矩阵相减的通用过程
Public Sub MatrixMinus(A, b, c)
    Dim i%, j%
    Dim R1%, C1%, R2%, C2%
    On Error Resume Next
    C1 = UBound(A, 2) - LBound(A, 2) + 1
    If Err Then
        MsgBox "第一个矩阵维数不对！"
        Exit Sub
    End If
    On Error Resume Next
    C2 = UBound(b, 2) - LBound(b, 2) + 1
    If Err Then
        MsgBox "第二个矩阵维数不对！"
        Exit Sub
    End If
    R1 = UBound(A, 1) - LBound(A, 1) + 1
    R2 = UBound(b, 1) - LBound(b, 1) + 1

    If R1 <> R2 Or C1 <> C2 Then
        MsgBox "输入的两个矩阵维数不等，不能相减！"
        Exit Sub
    End If

    ReDim c(1 To m, 1 To n) As Double
    For i = 1 To m
        For j = 1 To n
            c(i, j) = A(i, j) - b(i, j)
        Next j
    Next i
End Sub

'矩阵相乘：输入矩阵或数Qa、Qb，自动识别它们的维数，并输出它们的乘积Qn
Public 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 = UBound(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 = True 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 ai = 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, 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
        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(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 UBound(Qa, 2)
                    Qn(ai, bi) = Qa(ai) * Qb(bi)
                Next bi
            Next ai
    End If
End Sub

'矩阵相乘的通用过程
Public Sub MatrixMulti(A, b, c)
    Dim i%, j%, K%
    Dim R1%, C1%, R2%, C2%
    On Error Resume Next
    C1 = UBound(A, 2) - LBound(A, 2) + 1
    If Err Then
        MsgBox "第一个矩阵维数不对！"
        Exit Sub
    End If
    On Error Resume Next
    C2 = UBound(b, 2) - LBound(b, 2) + 1
    If Err Then
        MsgBox "第二个矩阵维数不对！"
        Exit Sub
    End If
    R1 = UBound(A, 1) - LBound(A, 1) + 1
    R2 = UBound(b, 1) - LBound(b, 1) + 1

    If C1 <> R2 Then
        MsgBox "输入的两个矩阵大小不对，不能相乘！"
        Exit Sub
    End If

    m = R1: s = C1: n = C2
    ReDim c(1 To m, 1 To n) As Double
    For i = 1 To m
        For j = 1 To n
            For K = 1 To s
                c(i, j) = c(i, j) + A(i, K) * b(K, j)
            Next K
        Next j
    Next i
End Sub

'列选主元法Guass约化求解线性方程组
Public Sub MajorInColGuass(A, b, X)
    Dim Row%, Col%, n%              '矩阵大小
    Dim iStep%, iRow%, iCol%        '循环变量
    Dim L() As Double               '各行的约化系数
    '计算并检查矩阵的大小