17-10-12, 12:12 AM
كاتب الموضوع : AhmedEssawy
ليس هناك الكثير لشرحه من خلال الكود ، كل ما يقوم به الكود هو تطويع للطرق الرياضية لاستخدام عمليات على المصفوفات :كود :
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 AThe first row is 0 because itïs
'much 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 it more
'than once.
' You have also to tell it in which 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 one dimensional 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 errhandler
Dim Row1() As Double, Row2() As Double, tmpRow1() As Double
Dim tmpRow2() As Double
Dim i As Integer
Dim j As Integer
If (MatrixARows <> MatrixBRows) Or _
(MatrixACols <> MatrixBCols) Then GoTo errhandler
' 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
errhandler:
Addition = False
End Function
Function Subtraction(Result() As Double) As Boolean
'
On Error GoTo errhandler
Dim Row1() As Double, Row2() As Double, tmpRow1() As Double
Dim tmpRow2() As Double
Dim i As Integer
Dim j As Integer
If (MatrixARows <> MatrixBRows) Or _
(MatrixACols <> MatrixBCols) Then GoTo errhandler
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
Subtraction = True
Exit Function
errhandler:
Subtraction = False
End Function
Function Multiplication(Result() As Double) As Boolean
' This is the function which multiplies two matrices.
' The Result Array looks like the Result Array from the Addition.
On Error GoTo errhandler
Dim Row1() As Double, Row2() As Double, tmpRow1() As Double
Dim tmpRow2() As Double
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim i As Integer, j As Integer, k As Integer
If (MatrixACols <> MatrixBRows) Then GoTo errhandler
' 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
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
Multiplication = True
Exit Function
errhandler:
' Error
Multiplication = False
End Function
Private Sub ClearUp()
ReDim MatrixA(0, 0)
ReDim MatrixB(0, 0)
End Sub
Private Sub Class_Initialize()
ClearUp
End Sub