matrixctl.ctl

制作矩阵的控件。

VERSION 5.00
Begin VB.UserControl MatrixCtl 
   ClientHeight    =   3585
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3930
   ScaleHeight     =   3585
   ScaleWidth      =   3930
   Begin VB.PictureBox Picture1 
      BackColor       =   &H80000005&
      Height          =   615
      Left            =   0
      ScaleHeight     =   555
      ScaleWidth      =   675
      TabIndex        =   0
      Top             =   0
      Width           =   735
   End
End
Attribute VB_Name = "MatrixCtl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit ' Require all variables to be declared

Public Type Matrix
    m As Integer           'm为矩阵的行
    n As Integer           'n为矩阵的列
    Element() As Double    '2D array of elements
End Type

Private Sub UserControl_Initialize()
    m = 1
    n = 1
    ReDim Element(1)
    Element(1) = 0
End Sub

Private Sub UserControl_Resize()
    Picture1.Move 0, 0, Width, Height
End Sub

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 Sub
    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.m = .n       '设置临时矩阵的维数与给出的矩阵相反的维数r
        Temp.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 Sub
    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 Sub
    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