First of all this isn't a great form of encryption, because it doubles the length of the string. However, it is hard to decrypt because even if the person decrypting it knew it was done using these functions they would also need the parameters. For those of you who don't know a matrix is an array of numbers set in an X by X table.
[1 4 6] [5 7 4 8] [4 5]
[3 7 3] [5 2 6 1] [3 7]
[4 7 2 5] [2 6]
2 by 3 3 by 4 3 by 2
These functions takes a matrix given as a parameter and then takes whatever amount of characters necessary out of the string to encrypt gets the ANSI values of the code to make a second matrix, then multiplies the two to get a third matrix. You can find plenty of other resources on how to multiply matrixes, so I not going to explain it hear. To decrypt instead of multiplying the function first has to find the inverse of the given matrix the doing the same thing as before.
Special Notes:
- Because we are dealing with ANSI we can't have values that are over 255, so don't put values over 3 in the matrix.
- Currently these function only support 2 by 2 matrixes, this will change eventually.
- Send a matrix in a string format like this '1,2,3,4'
'****
' Author: Nick Avery, [email protected]
' Date: October 25, 2001
' Description: Text Encryption
'****
Public Function Encrypt(Text As String, Matrix As String)
If Len(Text) = 2 Then
Encrypt = Text
Exit Function
End If
Dim Mat() As Integer
Dim Code() As Integer
Dim Txt() As Integer
Dim AmountOfRows As Integer
'Get the numbers from Matrix and put them in Mat
ReDim Preserve Mat(0 To 0)
Do Until Matrix = ""
ReDim Preserve Mat(0 To UBound(Mat) + 1)
If InStr(Matrix, ",") <> 0 Then
Mat(UBound(Mat)) = Left(Matrix, InStr(Matrix,
",") - 1)
Matrix = Right(Matrix, Len(Matrix) -
InStr(Matrix, ","))
Else
Mat(UBound(Mat)) = Matrix
Matrix = ""
End If
Loop
Do Until Int(Sqr(UBound(Mat))) = Sqr(UBound(Mat))
ReDim Preserve Mat(0 To UBound(Mat) + 1)
Mat(UBound(Mat)) = 3
Loop
AmountOfRows = Int(Sqr(UBound(Mat)))
ReDim Preserve Txt(1 To AmountOfRows)
ReDim Preserve Code(1 To AmountOfRows)
Do Until Len(Text) < AmountOfRows
'Get values from text
For X = 1 To UBound(Code)
Txt(X) = Asc(Left(Text, 1))
Text = Right(Text, Len(Text) - 1)
Next
'Multiply the matrixes
For X = 1 To UBound(Txt)
Code(X) = 0
For Y = 1 To AmountOfRows
Code(X) = Code(X) + (Mat(((UBound(Mat)
/ AmountOfRows) * (Y - 1)) + X) * Txt(Y))
Next
Next
'Put the new values in the text
For X = 1 To UBound(Txt)
'More often then not, the value after
being run
'through the matrix is over 255. Because
we can't
'use the Chr function with numbers over
255 we need
'a more complex way to put the value
in the text.
'Hear we will do it by finding a number
to divide
'it by then insert that number and the
result. This
'doubles the length, but what can you
do?
Y = 1
Do Until Code(X) / Y <= 256 And Round(Code(X)
/ Y, 0) * Y = Code(X)
Y = Y + 1
If Code(X) = Y Then 'The
number is prime. Now we have to
'assign a number to every prime
number
'above 255(1-257,2-263,3-269,ect).
Then
'insert an identifier character
and the
'prime number id.
Y = 0
X2 = 255
Do
X2 = X2 + 1
For Y2 = 2 To Code(X)
If Int(X2 / Y2) = X2 / Y2 Then GoTo NextNum
If Y2 = X2 - 1 Then
Y = Y + 1
If X2 = Code(X) Then
X2 = 0
End If
GoTo NextNum
End If
Next
NextNum:
If X2 = 0 Then Exit Do
Loop
Encrypt
= Encrypt & Chr$(255) & Chr$(Y) 'Chr$(255) will be the identifier
Y = 0
Exit Do
End If
Loop
If Y <> 0 Then Encrypt = Encrypt
& Chr$(Y) & Chr$(Code(X) / Y)
Next
Loop
Encrypt = Encrypt & Text
End Function
Public Function Decrypt(Text As String, Matrix As String)
If Len(Text) = 2 Then
Decrypt = Text
Exit Function
End If
Dim Mat() As Double
Dim Mat2() As Double
Dim Determinant As Integer
Dim Code() As Integer
Dim Txt() As Integer
Dim AmountOfRows As Integer
'Get the numbers from Matrix and put them in Mat
ReDim Preserve Mat(0 To 0)
Do Until Matrix = ""
ReDim Preserve Mat(0 To UBound(Mat) + 1)
If InStr(Matrix, ",") <> 0 Then
Mat(UBound(Mat)) = Left(Matrix, InStr(Matrix,
",") - 1)
Matrix = Right(Matrix, Len(Matrix) -
InStr(Matrix, ","))
Else
Mat(UBound(Mat)) = Matrix
Matrix = ""
End If
Loop
Do Until Int(Sqr(UBound(Mat))) = Sqr(UBound(Mat))
ReDim Preserve Mat(0 To UBound(Mat) + 1)
Mat(UBound(Mat)) = 3
Loop
AmountOfRows = Int(Sqr(UBound(Mat)))
'Find the inverse of mat
'The inverse of the matrix [a b] is [1 / (a
* d - c * b) * d 1 / (a * d - c * b) * (b *
-1)]
'
[c d] [1 / (a * d - c
* b) * (c * -1) 1 / (a * d - c * b) * a ]
'a * d - c * b is called the determinant
'Get the determinant
Determinant = (Mat(1) * Mat(4)) - (Mat(2) * Mat(3))
'Put the inverse of Mat into Mat2
ReDim Mat2(1 To UBound(Mat))
For X = 1 To UBound(Mat)
If X = 1 Then
Mat2(X) = (1 / Determinant) * Mat(4)
ElseIf X = 4 Then
Mat2(X) = (1 / Determinant) * Mat(1)
Else
Mat2(X) = (1 / Determinant) * (Mat(X)
* -1)
End If
Next
'Put valuse of Mat2 in Mat
For X = 1 To UBound(Mat)
Mat(X) = Mat2(X)
Next
ReDim Preserve Txt(1 To AmountOfRows)
ReDim Preserve Code(1 To AmountOfRows)
Do Until Len(Text) < AmountOfRows
'Get values from code
For X = 1 To UBound(Txt)
If Asc(Left(Text, 1)) = 255 Then
Y = 0
Code(X) = Asc(Right(Left(Text,
2), 1))
X2 = 255
Do
X2 = X2
+ 1
Y2 = 1
Do
Y2 = Y2 + 1
If Int(X2 / Y2) = X2 / Y2 Then Exit Do
If Y2 * 2 > X2 - 1 Then
Y = Y + 1
If Y = Code(X) Then
Code(X) = X2
X2 = 0
End If
Exit Do
End If
Loop
If X2 =
0 Then Exit Do
Loop
Else
Code(X) = Asc(Left(Text,
1)) * Asc(Right(Left(Text, 2), 1))
End If
Text = Right(Text, Len(Text) - 2)
Next
'Multiply the matrixes
For X = 1 To UBound(Txt)
Txt(X) = 0
For Y = 1 To AmountOfRows
Txt(X) = Txt(X) + (Mat(((UBound(Mat)
/ AmountOfRows) * (Y - 1)) + X) * Code(Y))
Next
Next
'Take value from the Txt and make text
For X = 1 To UBound(Txt)
Decrypt = Decrypt & Chr$(Txt(X))
Next
Loop
Decrypt = Decrypt & Text
End Function
I am as a web developer for a small company, working for a small company. I work on banking websites and verious related projects.
Comments