mdlmatrix.bas

制作矩阵的控件。

Attribute VB_Name = "mdlMatrix"
Option Explicit
Public Type Matrix
    m As Integer           'm为矩阵的行
    n As Integer           'n为矩阵的列
    Element() As Double    '2D array of elements
End Type

Public Function CreateMatrix(ByVal m As Integer, ByVal n As Integer, ParamArray Values() As Variant) As Matrix
    '  #Rows, #Cols [, R1C1, R1C2, R1C3... R1Cn, R2C1, R2C2, R2C3 .... RmCn]

    ' 创建一个m行、n列的矩阵;格式如下
    ' [ R1C1 R1C2 R1C3 ... R1Cn ]
    ' [ R2C1 R2C2 R2C3 ... R2Cn ]
    ' [ R3C1 R3C2 R3C3 ... R3Cn ]
    '   ...  ...  ...  ... ...
    ' [ RmC1 RmC2 RmC3 ... RmCn ]
    Dim i As Integer, j As Integer, k As Integer
    Dim Temp As Matrix
    
    Select Case True
        Case m = 0, n = 0
            MsgBox "不能创建一个零维矩阵", , "矩阵操作 - 矩阵创建"
            Exit Function
    End Select
    
    With Temp
        ReDim .Element(1 To m, 1 To n)  ' 分配内存存储矩阵
        .m = m                ' 设定矩阵的维数
        .n = n
        
        '如果存在数据，则将数据填充到矩阵中
        If UBound(Values) > 0 Then
            For i = 1 To m
                For j = 1 To n
                ' 如果下标越界，则跳出for循环
                If k > UBound(Values) Then Exit For
                    .Element(i, j) = Values(k) ' 存储数据在矩阵中
                    k = k + 1                  ' 下一矩阵元素
                Next j
                ' 如果下标越界，则跳出for循环
                If k > UBound(Values) Then Exit For
            Next i
        End If
    End With

    CreateMatrix = Temp    ' 返回创建的矩阵
End Function


Public Function TransposeMatrix(ByRef dMat As Matrix) As Matrix
    '矩阵转置，形式如下：
    ' [ R1C1 R1C2 R1C3 ... R1Cn ]       [ R1C1 R2C1 R3C1 ... RmC1 ]
    ' [ R2C1 R2C2 R2C3 ... R2Cn ]       [ R1C2 R2C2 R3C2 ... RmC2 ]
    ' [ R3C1 R3C2 R3C3 ... R3Cn ]  =>   [ R1C3 R2C3 R3C3 ... RmC3 ]
    '   ...  ...  ...  ... ...            ...  ...  ...  ... ...
    ' [ RmC1 RmC2 RmC3 ... RmCn ]       [ R1Cn R2Cn R3Cn ... RmCn ]

    Dim i As Integer, j As Integer
    Dim Temp As Matrix
    
    With dMat
        ' 创建一临时矩阵
        Temp = CreateMatrix(.n, .m) '设置临时矩阵的维数与给出的矩阵相反的维数
        
        For i = 1 To .m   ' 行、列值互换
            For j = 1 To .n
                Temp.Element(j, i) = .Element(i, j)
            Next j
        Next i
    End With
    
    TransposeMatrix = Temp
End Function


Public Function ScaleMatrix(ByRef dMat As Matrix, ByVal Multiplier As Double) As Matrix
    ' 矩阵与常数相乘，例如：
    '   [ a b ]    [ 2a 2b ]
    ' 2 [ c d ] => [ 2c 2d ]
    '   [ e f ]    [ 2e 2f ]
    
    Dim i As Integer, j As Integer
    Dim Temp As Matrix
    Temp = dMat
    
    With Temp
        For i = 1 To .m
            For j = 1 To .n
                .Element(i, j) = .Element(i, j) * Multiplier
            Next j
        Next i
    End With
     
    ScaleMatrix = Temp
End Function


Public Function AddMatrix(ByRef dMat1 As Matrix, ByRef dMat2 As Matrix) As Matrix
    ' 两个同维数的矩阵相加，例如：
    ' [ a b ]   [ u v ]    [ a+u  b+v ]
    ' [ c d ] + [ w x ] => [ c+w  d+x ]
    ' [ e f ]   [ y z ]    [ e+y  f+z ]
    ' 注意：两相加矩阵必须具体相同的维数，否则函数将提示出错
    '
    Dim i As Integer, j As Integer
    Dim Temp As Matrix
    
    i = dMat1.m
    j = dMat1.n
    
    '检查矩阵是否同维数
    Select Case False
        Case i = dMat2.m, j = dMat2.n
            MsgBox "两不同维数的矩阵不能相加", , "矩阵操作 - 矩阵相加"
            Exit Function
    End Select
    
    Temp = CreateMatrix(i, j)
    
    With Temp
        For i = 1 To .m
            For j = 1 To .n
                .Element(i, j) = dMat1.Element(i, j) + dMat2.Element(i, j)
            Next j
        Next i
    End With
    
    AddMatrix = Temp
End Function


Public Function SubMatrix(ByRef dMat1 As Matrix, ByRef dMat2 As Matrix) As Matrix
    '两个同维数的矩阵相减，见矩阵相加
    Dim i As Integer, j As Integer
    Dim Temp As Matrix
    
    i = dMat1.m
    j = dMat1.n
    
    '检查矩阵是否同维数
    Select Case False
        Case i = dMat2.m, j = dMat2.n
            MsgBox "两不同维数的矩阵不能相减", , "矩阵操作 - 矩阵相减"
            Exit Function
    End Select
    
    Temp = CreateMatrix(i, j)
    
    With Temp
        For i = 1 To .m
            For j = 1 To .n
                .Element(i, j) = dMat1.Element(i, j) - dMat2.Element(i, j)
            Next j
        Next i
    End With
    
    SubMatrix = Temp
End Function


Public Function MultiplyMatrix(ByRef dMat1 As Matrix, ByRef dMat2 As Matrix) As Matrix
    ' 两个矩阵相乘，条件是左矩阵的列数等于右矩阵的行数，例如：
    ' [ a b c ]   [ u v ]     [ (au+bw+cy) (av+bx+cz) ]
    ' [ d e f ] * [ w x ] = > [ (du+ew+fy) (dv+ex+fz) ]
    '             [ y z ]
    
    ' 注意：因为矩阵值使用了双精度、浮点型
    '      如果含有一个值为:如 2.22044E-16 或者0.00000000000000022044
    '      其实这个值就是零
    Dim i As Integer, j As Integer, k As Integer
    Dim Tot As Double
    Dim Temp As Matrix
    
    i = dMat1.n
    j = dMat2.m
    
    If i <> j Then
        MsgBox "左矩阵的列数不等于右矩阵的行数，两矩阵不能相乘", , "矩阵操作 - 矩阵相乘"
        Exit Function
    End If
    
    Temp = CreateMatrix(dMat1.m, dMat2.n)
    
    With dMat1
        For k = 1 To dMat2.n        ' 对右矩阵的每行进行操作
            For i = 1 To .m         ' 对左矩阵的每行进行操作
                Tot = 0             ' 重置累加值为0
                For j = 1 To .n     ' 对左矩阵的每列进行操作
                    ' 把对应的元素值相乘并累加在一块
                    Tot = Tot + .Element(i, j) * dMat2.Element(j, k)
                Next j
                ' 存储累加值
                Temp.Element(i, k) = Tot
            Next i
        Next k
    End With
    
    MultiplyMatrix = Temp
End Function


Public Function Determinant(ByRef dMat As Matrix) As Double
    ' 计算矩阵的行列式，要求矩阵为方阵,也即矩阵的m=n，例如：
    ' |         |
    ' | [ a b ] | => (a*d)-(b*c)
    ' | [ c d ] |
    ' |         |
    '
    ' 对于大矩阵而言，先t将其化为上三角形式，上三角形式如下：
    ' [ R11 R12 R13 ... R1n ]        [ R11' R12' R13' ... R1n' ]
    ' [ R21 R22 R23 ... R2n ]        [   0  R22' R23' ... R2n' ]
    ' [ R31 R32 R33 ... R3n ]   =>   [   0    0  R33' ... R3n' ]
    '   ... ... ... ... ...            ...  ...  ...  ... ...
    ' [ Rm1 Rm2 Rm3 ... Rmn ]        [   0    0    0  ... Rmn' ]
    ' 矩阵的行列式即为上三角矩阵的对角线各元素值的乘数
    
    Dim i As Integer, j As Integer
    Dim m As Integer, n As Integer
    
    Dim a1 As Double, b1 As Double
    Dim a2 As Double, b2 As Double
    
    Dim Mult As Double
    Dim det As Double
    Dim Temp As Matrix
    
    Dim x As Integer, y As Integer
    
    With dMat
        i = .m
        j = .n
        
        '检查矩阵是否为方阵
        Select Case True
            Case i <> j
                MsgBox "矩阵不为方阵，不能求行列式", , "矩阵操作 - 矩阵行列式计算"
                Exit Function
            Case i = 0
                MsgBox "不能对零维矩阵求行列式", , "矩阵操作 - 矩阵行列式计算"
                Exit Function
        End Select
        
        Select Case j
            Case 1
                '一维矩阵的行列式计算
                det = .Element(1, 1)
            Case 2
                '二维方阵的行列式计算
                det = (.Element(1, 1) * .Element(2, 2)) - (.Element(1, 2) * .Element(2, 1))
            Case Else
                '大于等于三维的方阵的行列式计算
                Temp = dMat
                det = 1
                
                '对方阵进行高斯-约化
                For i = 1 To j