by Ascher Stefan (8 Submissions)
Category: Math/Dates
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Tue 9th March 1999
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Matrices the second, now it will work, for sure ;-), it¡s not that easy, that it looks like.
VBcoders
' up and multiply two (MatrixA and MatrixB) matrices. To set the datas
' in it, call for Matrix A 'SetArrayA' with an onedimensional Array
' that will be the Rows, and the Column in wich you want to have
' this Datas. For Matrix B ist´s the same.
Option Explicit
Private MatrixA() As Double
Private MatrixB() As Double ' Our two Matrices
Public Property Get MatrixARows() As Integer
' Gives you an Integer Value for the count of rows of Matrix A
' The first row is 0 because it´s much more easier to calculate
' 0-based.
MatrixARows = UBound(MatrixA, 1)
End Property
Public Property Get MatrixBRows() As Integer
' Gives you an Integer value for the count of rows of Matrix B
' The first row is 0
MatrixBRows = UBound(MatrixB, 1)
End Property
Public Property Get MatrixACols() As Integer
' Gives you an Integer Value for the count of columns of Matrix A
' The first column is 0
MatrixACols = UBound(MatrixA, 2)
End Property
Public Property Get MatrixBCols() As Integer
' Gives you an Integer Value for the count of columns of Matrix B
' The first column is 0
MatrixBCols = UBound(MatrixB, 2)
End Property
Public Function SetArrayA(InputArray() As Double, Col As Integer)
' Set the Array for the Matrix A. InputArray() is onedimensional
' for the rows. If you want more than one row, so call ist more than once.
' You have also to tell it, in wich column this rows should be.
On Error Resume Next
Dim i As Integer
If UBound(MatrixA, 1) < 1 Then
ReDim MatrixA(UBound(InputArray()), Col)
Else
ReDim Preserve MatrixA(UBound(InputArray()), Col)
End If
For i = 0 To UBound(InputArray())
MatrixA(i, Col) = InputArray(i)
Next i
End Function
Public Function SetArrayB(InputArray() As Double, Col As Integer)
' Same than SetArrayA but for the Matrix B
On Error Resume Next
Dim i As Integer
If UBound(MatrixB, 1) < 1 Then
ReDim MatrixB(UBound(InputArray()), Col)
Else
ReDim Preserve MatrixB(UBound(InputArray()), Col)
End If
For i = 0 To UBound(InputArray())
MatrixB(i, Col) = InputArray(i)
Next i
End Function
Public Function GetArrayA(OutputArray() As Double, Col As Integer)
' Gives you an onedimensional Array from a column.
On Error Resume Next
Dim i As Integer
ReDim OutputArray(UBound(MatrixA, 1))
For i = 0 To UBound(MatrixA, 1)
OutputArray(i) = MatrixA(i, Col)
Next i
End Function
Public Function GetArrayB(OutputArray() As Double, Col As Integer)
' Same
On Error Resume Next
Dim i As Integer
ReDim OutputArray(UBound(MatrixB, 1))
For i = 0 To UBound(MatrixB, 1)
OutputArray(i) = MatrixB(i, Col)
Next i
End Function
Function Addition(Result() As Double) As Boolean
' Sums up Matrix A and Matrix B
' Result is a twodimensional Array with the result.
' For Example: Result(0,0) = 1 1 3
' Result(1,0) = 2 2 4
' Result(0,1) = 3
' Result(1,1) = 4 will be the Result matrix
' The first index in the Result Array will be the row, and the second
' the column.
On Error GoTo Fehler
Dim Row1() As Double, Row2() As Double, tmpRow1() As Double, tmpRow2() As Double
Dim i As Integer ' Zeilen
Dim j As Integer ' Spalten
If (MatrixARows <> MatrixBRows) Or (MatrixACols <> MatrixBCols) Then GoTo Fehler
' NOTE: You can only summerize matrices when they are from the same
' dimension: A(2,3)+B(2,3) will work fine but
' A(4,5)+B(1,2) ist not possible.
ReDim Row1(MatrixARows, MatrixACols)
ReDim Row2(MatrixBRows, MatrixBCols)
For i = 0 To MatrixACols
GetArrayA tmpRow1(), i
For j = 0 To UBound(tmpRow1())
Row1(j, i) = tmpRow1(j)
Next j
Next i
For i = 0 To MatrixBCols
GetArrayB tmpRow2(), i
For j = 0 To UBound(tmpRow2())
Row2(j, i) = tmpRow2(j)
Next j
Next i
ReDim Result(MatrixARows, MatrixACols)
For i = 0 To MatrixARows
For j = 0 To MatrixACols
Result(i, j) = Row1(i, j) + Row2(i, j)
Next j
Next i
Addition = True
Exit Function
Fehler:
Addition = False
End Function
Function Subtraktion(Result() As Double) As Boolean
' I don´t know if it´s legal to subtract two matrices.
'
On Error GoTo Fehler
Dim Row1() As Double, Row2() As Double, tmpRow1() As Double, tmpRow2() As Double
Dim i As Integer ' Zeilen
Dim j As Integer ' Spalten
If (MatrixARows <> MatrixBRows) Or (MatrixACols <> MatrixBCols) Then GoTo Fehler
ReDim Row1(MatrixARows, MatrixACols)
ReDim Row2(MatrixBRows, MatrixBCols)
For i = 0 To MatrixACols
GetArrayA tmpRow1(), i
For j = 0 To UBound(tmpRow1())
Row1(j, i) = tmpRow1(j)
Next j
Next i
For i = 0 To MatrixBCols
GetArrayB tmpRow2(), i
For j = 0 To UBound(tmpRow2())
Row2(j, i) = tmpRow2(j)
Next j
Next i
ReDim Result(MatrixARows, MatrixACols)
For i = 0 To MatrixARows
For j = 0 To MatrixACols
Result(i, j) = Row1(i, j) - Row2(i, j)
Next j
Next i
Subtraktion = True
Exit Function
Fehler:
Subtraktion = False
End Function
Function Multiplikation(Result() As Double) As Boolean
' This ist the function wich multiply two matrices.
' The Result Array looks like the Result Array from the Addition.
On Error GoTo Fehler
Dim Row1() As Double, Row2() As Double, tmpRow1() As Double, tmpRow2() As Double
Dim x As Integer ' Zeilen
Dim y As Integer ' Spalten
Dim z As Integer
Dim i As Integer, j As Integer, k As Integer
If (MatrixACols <> MatrixBRows) Then GoTo Fehler
' NOTE: You can only multiple Matrices if there are as many columns in
' the first Matrix than rows in the second.
i = MatrixARows: j = MatrixBCols: k = MatrixACols
ReDim Row1(i, k) ' first Matrix, bad name but first I made it different
ReDim Row2(k, j) ' second Matrix
For x = 0 To k
GetArrayA tmpRow1(), x
For y = 0 To UBound(tmpRow1())
Row1(y, x) = tmpRow1(y)
Next y
Next x
For x = 0 To j
GetArrayB tmpRow2(), x
For y = 0 To UBound(tmpRow2())
Row2(y, x) = tmpRow2(y)
Next y
Next x
ReDim Result(i, j)
Dim Sum As Double
Sum = 0
For x = 0 To i
For y = 0 To j
For z = 0 To k
Sum = Sum + (Row1(x, z) * Row2(z, y))
Next z
Result(x, y) = Sum
Sum = 0
Next y
Next x
' Everything fine
Multiplikation = True
Exit Function
Fehler:
' Error
Multiplikation = False
End Function
Public Function DeterminanteA(ResArray() As Double) As Boolean
' coming soon
End Function
Public Function DeterminanteB(ResArray() As Double) As Boolean
' coming soon
End Function
Private Sub ClearUp()
ReDim MatrixA(0, 0)
ReDim MatrixB(0, 0)
End Sub
Private Sub Class_Initialize()
ClearUp
End Sub
No comments have been posted about Matrices the second, now it will work, for sure ;-), it¡s not that easy, that it looks like.. Why not be the first to post a comment about Matrices the second, now it will work, for sure ;-), it¡s not that easy, that it looks like..
