矩阵基本运算

Option Explicit

Type Matrix
  element() As Single
  err As Byte '非零为错误
End Type
'矩阵求逆
Function Inverse(a As Matrix) As Matrix
  Dim i As Integer
  Dim j As Integer
  Dim n As Integer
  Dim m As Integer
  Dim h As Integer
  Dim k As Single
  Dim addition As Matrix '扩充矩阵
  Dim AllZero As Boolean '某列是否全零
  On Error GoTo warn
  n = UBound(a.element, 1)
  ReDim Inverse.element(1 To n, 1 To n)
  ReDim addition.element(1 To n, 1 To 2 * n)
  For i = 1 To n '初始化扩充矩阵
    For j = 1 To n
      addition.element(i, j) = a.element(i, j)
    Next
  Next
  For i = 1 To n
    For j = n + 1 To 2 * n
      If j - i = n Then
        addition.element(i, j) = 1
      Else
        addition.element(i, j) = 0
      End If
    Next
  Next
  With addition
    For m = 2 To n '下三角
      For i = n To m Step -1
        '后续需要考虑保证.element(m-1,m-1)非0的代码处理
        If .element(m - 1, m - 1) = 0 Then
          AllZero = True
          For h = m To n
            If .element(h, m - 1) <> 0 Then AllZero = False: Exit For
          Next
          If AllZero = True Then GoTo warn '某列全零则矩阵不满秩，退出
          For j = 1 To 2 * n
            .element(m - 1, j) = .element(m - 1, j) + .element(h, j)
          Next
        End If
        '以上为完善部分
   
        If .element(i, m - 1) <> 0 Then
          k = .element(m - 1, m - 1) / .element(i, m - 1)
          For j = 1 To 2 * n
            .element(i, j) = .element(i, j) * k - .element(m - 1, j)
          Next
        End If
      Next
    Next

 
    For m = n - 1 To 1 Step -1 '上三角
      For i = 1 To m
        '后续需要考虑保证.element(m+1,m+1)非0的代码处理
        'If .element(m + 1, m + 1) = 0 Then
        '  For h = m To 1 Step -1
        '    If .element(h, m + 1) <> 0 Then Exit For
        '  Next
        '  For j = 1 To 2 * n
        '    .element(m + 1, j) = .element(m + 1, j) + .element(h, j)
        '  Next
        'End If
        '以上为完善部分，未验证
        '上三角完成后，下三角主对角元素不可能为零！
        If .element(i, m + 1) <> 0 Then
          k = .element(m + 1, m + 1) / .element(i, m + 1)
          For j = 1 To 2 * n
            .element(i, j) = .element(i, j) * k - .element(m + 1, j)
          Next
        End If
      Next
    Next
    For i = 1 To n '主对角线元素置1
      k = .element(i, i)
      For j = 1 To 2 * n
        .element(i, j) = .element(i, j) / k
      Next
    Next
    For i = 1 To n '输出
      For j = 1 To n
        Inverse.element(i, j) = .element(i, j + n)
      Next
    Next
  End With
  Exit Function
warn:
  Inverse.err = 1

End Function
'矩阵加减flag=0求和,flag=1求差
Function Add(a As Matrix, b As Matrix, flag As Byte) As Matrix
  Dim i As Integer
  Dim j As Integer
  If flag <> 0 And flag <> 1 Then MsgBox ("Flag有误！"): Exit Function
  If UBound(a.element, 1) <> UBound(b.element, 1) Or UBound(a.element, 2) <> UBound(b.element, 2) Then MsgBox ("输入矩阵有误！"): Exit Function
  ReDim Add.element(1 To UBound(a.element, 1), 1 To UBound(a.element, 2))
  For i = 1 To UBound(a.element, 1)
    For j = 1 To UBound(a.element, 2)
        Add.element(i, j) = a.element(i, j) + (1 - 2 * flag) * b.element(i, j)
    Next
  Next
End Function
'矩阵乘法
Function Multiply(a As Matrix, b As Matrix) As Matrix
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
  If UBound(a.element, 2) <> UBound(b.element, 1) Then Multiply.err = 2: Exit Function
  ReDim Multiply.element(1 To UBound(a.element, 1), 1 To UBound(b.element, 2))
  For i = 1 To UBound(a.element, 1)
    For j = 1 To UBound(b.element, 2)
      Multiply.element(i, j) = 0
      For k = 1 To UBound(a.element, 2)
        Multiply.element(i, j) = Multiply.element(i, j) + a.element(i, k) * b.element(k, j)
      Next
    Next
  Next
End Function
'矩阵转置
Function Transpose(a As Matrix) As Matrix
  Dim i As Integer
  Dim j As Integer
  ReDim Transpose.element(UBound(a.element, 2), UBound(a.element, 1))
    For i = 1 To UBound(a.element, 1)
      For j = 1 To UBound(a.element, 2)
        Transpose.element(j, i) = a.element(i, j)
      Next
    Next
End Function
'在目标文本框中显示矩阵
Sub Display(a As Matrix, dest As TextBox)
  Dim i As Integer
  Dim j As Integer
  dest.Text = dest.Text & "Matrix= " & vbCrLf
  For i = 1 To UBound(a.element, 1)
    For j = 1 To UBound(a.element, 2)
      dest.Text = dest.Text & a.element(i, j) & vbTab
    Next
    dest.Text = dest.Text & vbCrLf
  Next
  dest.Text = dest.Text & vbCrLf
End Sub

Option Explicit
Dim x1 As Matrix '源矩阵
Dim x2 As Matrix
Dim y As Matrix '输出矩阵

Private Sub Command1_Click()
  Dim i As Integer
  Dim j As Integer
  y = Inverse(x2)
  If y.err = 0 Then
    Display y, Text1
  Else
    MsgBox ("Error " & y.err)
  End If
End Sub

Private Sub Form_Load()
  ReDim x1.element(1 To 3, 1 To 3)
  ReDim x2.element(1 To 3, 1 To 3)
  With x1
    .element(1, 1) = 1
    .element(1, 2) = 1
    .element(1, 3) = -1
    .element(2, 1) = 0
    .element(2, 2) = 2
    .element(2, 3) = 2
    .element(3, 1) = 0
    .element(3, 2) = -1
    .element(3, 3) = 0
  End With
  With x2
    .element(1, 1) = 0
    .element(1, 2) = -1
    .element(1, 3) = 1
    .element(2, 1) = 0
    .element(2, 2) = 0
    .element(2, 3) = -1
    .element(3, 1) = 1
    .element(3, 2) = -1
    .element(3, 3) = 1
  End With
  Display x1, Text1
  Display x2, Text1
End Sub