[RaggiTech]

كاتب المشاركة : 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