تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
أمثلة على عمليات المصفوفات الرياضية ، ضرب طرح جمع
#1
كاتب الموضوع : 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
}}}}
تم الشكر بواسطة:
#2
كاتب المشاركة : najdat

هل لي ان اضيف الكود التالي


كود :
command1-2-3-4-56-7-8-9
------------------------------------------------
Option Explicit
Dim i, ii As Integer
Dim matA(), matB(), matC()

Private Sub Command9_Click()
Form1.Cls
Dim j As Integer
Dim matrice(1 To 100, 1 To 100)
For i = 1 To 100
For j = 1 To 100
matrice(i, j) = Int(Rnd * 100)
Next
Next
Call MatPrint("matrice inv", matrice, 1000, 0)
Call MAT_INV(matrice)
Call MatPrint("matrice inv", matrice, 4000, 0)
End Sub

Private Sub Form_Load()
On Error Resume Next
Show

ReDim matA(1 To 3, 1 To 3)
ReDim matB(1 To 3, 1 To 1)


matA(1, 1) = -1: matA(1, 2) = 8: matA(1, 3) = 3
matA(2, 1) = 2: matA(2, 2) = 4: matA(2, 3) = -1
matA(3, 1) = -2: matA(3, 2) = 1: matA(3, 3) = 0

'MATRIX B
matB(1, 1) = 2: matB(2, 1) = 1: matB(3, 1) = -1

Me.AutoRedraw = True
Call MatPrint("Matrix A", matA, 1000, 1000)
Call MatPrint("Matrix B", matB, 1000, 6000)
Me.AutoRedraw = False
End Sub

Private Sub Command1_Click() 'MULTIPLICATION
On Error Resume Next
Me.Cls
Call MatPrint(" MULTIPLICATION", matA, 3000, 1000)
Call MAT_MUL(matA(), matB(), matC())

Call MatPrint("MULTIPLIKATION", matC, 4000, 1000)
End Sub

'ADDITION
Private Sub Command2_Click()
On Error Resume Next
Me.Cls
Call MatPrint(" ADDITION", matC, 3000, 1000)
Call MAT_ADD(matA(), matB(), matC())

Call MatPrint("ADDITION", matC, 4000, 1000)
End Sub

'SUSTRAKTION
Private Sub Command3_Click()
On Error Resume Next
Me.Cls
Call MatPrint(" SUSTRACTION", matC, 3000, 1000)
Call MAT_SUB(matA(), matB(), matC())

Call MatPrint("SUBTRAKTION", matC, 4000, 1000)
End Sub

'INVERTIION
Private Sub Command4_Click()
On Error Resume Next
Me.Cls
Call MatPrint(" INVERTIION", matA, 3000, 1000)
Call MAT_INV(matA())

Call MatPrint("SOURCE A", matA, 4000, 1000)
Call MatPrint("TARGET C", matA, 4000, 1000)
End Sub

'INVERTIION
Private Sub Command5_Click()
On Error Resume Next
Me.Cls
Call MatPrint("VOR INVERTIERUNG", matB, 3000, 1000)
Call MAT_INV(matB())

Call MatPrint("INVERTIERTE B", matB, 5000, 1000)
End Sub

'TRANSPOSE
Private Sub Command6_Click()
On Error Resume Next
Me.Cls
Call MatPrint(" TRANSPOSE", matA, 3000, 1000)
Call MAT_TRA(matA())

Call MatPrint("TRANSPOSE A", matA, 4000, 1000)
End Sub

' TRANSPOSE
Private Sub Command7_Click()
On Error Resume Next
Me.Cls
Call MatPrint(" TRANSPOSE", matB, 3000, 1000)
Call MAT_TRA(matB())

Call MatPrint("TRANSPOSE B", matB, 4000, 1000)
End Sub

Private Sub Command8_Click()
On Error Resume Next
Me.Cls
Dim u

Call MAT_GAUSS(matA(), matB(), matC())

Call MatPrint("MATRIX A", matA, 3000, 1000)
Call MatPrint("VECTOR B", matB, 3000, 6000)
Call MatPrint("VECTOR X", matC, 4000, 1000)
End Sub

Private Sub MatPrint(Titel, Matrix(), y, x)
Me.CurrentY = y
Me.CurrentX = x
Me.Print Titel
For i = 1 To UBound(Matrix, 1)
Me.CurrentX = x
For ii = 1 To UBound(Matrix, 2)
Me.Print Format(Matrix(i, ii), "##0.0000") & " ";
Next ii
Me.Print
Next i
Me.Print
End Sub



-------------------------------------
modulname=Matrices
------------------------------
Dim X1, Y1, X2, Y2 As Integer
'Public A(), B(), C(), D()

Public Sub MAT_MUL(A(), B(), C())

Y1 = 0: X1 = 0: Y2 = 0: X2 = 0


Y1 = UBound(A(), 1)
X1 = UBound(A(), 2)
Y2 = UBound(B(), 1)
X2 = UBound(B(), 2)


If X1 <> Y2 Then
MsgBox (" Multiplication not possible. (X1<>Y2)")
Exit Sub
End If


ReDim C(1 To Y1, 1 To X2)


For IX2 = 1 To X2
For IY1 = 1 To Y1
For IX1 = 1 To X1
C(IY1, IX2) = C(IY1, IX2) + A(IY1, IX1) * B(IX1, IX2)
Next IX1
Next IY1
Next IX2

End Sub

Public Sub MAT_ADD(A(), B(), C())

Y1 = 0: X1 = 0: Y2 = 0: X2 = 0


Y1 = UBound(A(), 1)
X1 = UBound(A(), 2)
Y2 = UBound(B(), 1)
X2 = UBound(B(), 2)


If Y1 <> Y2 Or X1 <> X2 Then
MsgBox (" Addition not possible. (Y1<>Y2 Or X1<>X2)")
Exit Sub
End If


ReDim C(1 To Y1, 1 To X1)


For IY1 = 1 To Y1
For IX1 = 1 To X1
C(IY1, IX1) = A(IY1, IX1) + B(IY1, IX1)
Next IX1
Next IY1

End Sub

Public Sub MAT_SUB(A(), B(), C())

Y1 = 0: X1 = 0: Y2 = 0: X2 = 0


Y1 = UBound(A(), 1)
X1 = UBound(A(), 2)
Y2 = UBound(B(), 1)
X2 = UBound(B(), 2)


If Y1 <> Y2 Or X1 <> X2 Then
MsgBox (" Subtraction not possible. (Y1<>Y2 Or X1<>X2)")
Exit Sub
End If


ReDim C(1 To Y1, 1 To X1)


For IY1 = 1 To Y1
For IX1 = 1 To X1
C(IY1, IX1) = A(IY1, IX1) - B(IY1, IX1)
Next IX1
Next IY1

End Sub

Public Sub MAT_INV(C())

On Error Resume Next

Y1 = 0: X1 = 0: Y2 = 0: X2 = 0


Y1 = UBound(C(), 1)
X1 = UBound(C(), 2)

If Y1 <> X1 Then
MsgBox (" Inverting not possible. (Y1<>X1)")
Exit Sub
End If

Dim DUMMYMAT()
ReDim DUMMYMAT(Y1, X1)


For IY1 = 1 To Y1
For IX1 = 1 To X1
DUMMYMAT(IY1, IX1) = C(IY1, IX1)
C(IY1, IX1) = 0
If IY1 = IX1 Then
C(IY1, IX1) = 1
Else
C(IY1, IX1) = 0
End If
Next IX1
Next IY1


For i = 1 To UBound(DUMMYMAT, 1)
DUMMY = DUMMYMAT(i, i)


For j = 1 To UBound(DUMMYMAT, 2)
DUMMYMAT(i, j) = DUMMYMAT(i, j) / DUMMY
C(i, j) = C(i, j) / DUMMY
Next j


For x = 1 To UBound(DUMMYMAT, 1)
If x <> i Then
DUMMY = DUMMYMAT(x, i)
For j = 1 To UBound(DUMMYMAT, 2)
DUMMYMAT(x, j) = DUMMYMAT(x, j) - DUMMY * DUMMYMAT(i, j)
C(x, j) = C(x, j) - DUMMY * C(i, j)
Next j
End If
Next x
Next i

End Sub
'End Function

Public Sub MAT_TRA(C())
On Error Resume Next

Y1 = 0: X1 = 0: Y2 = 0: X2 = 0


Y1 = UBound(C(), 1)
X1 = UBound(C(), 2)


Dim DUMMYMAT()
ReDim DUMMYMAT(X1, Y1)


For IY1 = 1 To Y1
For IX1 = 1 To X1
DUMMYMAT(IX1, IY1) = C(IY1, IX1)
Next IX1
Next IY1


Y1 = UBound(DUMMYMAT(), 1)
X1 = UBound(DUMMYMAT(), 2)


ReDim C(Y1, X1)


For IY1 = 1 To Y1
For IX1 = 1 To X1
C(IY1, IX1) = DUMMYMAT(IY1, IX1)
Next IX1
Next IY1
End Sub

Public Sub MAT_GAUSS(A(), B(), C())
Dim D()
Call MAT_COPY(A(), D())
Call MAT_INV(D())
Call MAT_MUL(D(), B(), C())
Call MAT_INV(D())
End Sub

Public Sub MAT_COPY(A(), C())
On Error Resume Next

Y1 = 0: X1 = 0: Y2 = 0: X2 = 0


Y1 = UBound(A(), 1)
X1 = UBound(A(), 2)


ReDim C(1 To Y1, 1 To X1)


For IY1 = 1 To Y1
For IX1 = 1 To X1
C(IY1, IX1) = A(IY1, IX1)
Next IX1
Next IY1
End Sub

Public Sub MAT_KILL(A())
On Error Resume Next

ReDim A(0, 0)
End Sub
}}}}
تم الشكر بواسطة:


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
  أمثلة و أكواد للتعامل مع دوال Api RaggiTech 14 1,576 17-10-12, 04:36 PM
آخر رد: RaggiTech

التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم