VB icon

BinaryCrypt

Email
Submitted on: 1/23/2015 9:05:00 PM
By: Trent Gardner (from psc cd)  
Level: Intermediate
User Rating: By 4 Users
Compatibility: VB 5.0
Views: 1100
 
     This application reduces ASCII character codes to binary and then shifts the bits to the left by whatever the length of the string is.
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
'**************************************
' Name: BinaryCrypt
' Description:This application reduces ASCII character codes to binary and then shifts the bits to the left by whatever the length of the string is.
' By: Trent Gardner (from psc cd)
'
' Inputs:You need to input a string to encrypt.
'
' Returns:It returns your encrypted string
'
' Side Effects:N/A
'**************************************

'************************************************
'*******BinaryCrypt was written by*******
'*******Trent Gardner *******
'************************************************
Public BinaryStrings As New Collection
Public strEncrypted As String
Public strDecrypted As String
Public Function BinaryCrypt(strBinary As String, BinaryShift As Integer)
On Error Resume Next
Dim BinaryPositions As New Collection
Dim BinaryChange As New Collection
'128 64 32 16 8421
'[ ] [ ] [ ] [ ][ ] [ ] [ ] [ ]
For intCounter = 0 To 7
BinaryPositions.Add (Mid(strBinary, Len(strBinary) - intCounter, 1))
Next intCounter
For Positions = 1 To BinaryShift
strFinished = vbNullString
For intCounter = 1 To 8
' Rotating to the left
If intCounter = 1 Then
EighthPosition = BinaryPositions.Item(1)
Else
BinaryChange.Add (BinaryPositions.Item(intCounter))
If intCounter = 8 Then
BinaryChange.Add (EighthPosition)
End If
End If
Next intCounter
For i = 1 To 4
For intCounter = 1 To 4
'BinaryChange.Remove (intCounter)
BinaryPositions.Remove (intCounter)
Next intCounter
Next i
For i = 1 To 8
BinaryPositions.Add (BinaryChange(i))
Next i
For intCounter = 1 To BinaryChange.Count
strFinished = strFinished & BinaryPositions.Item(intCounter)
Next intCounter
For i = 1 To 4
For intCounter = 1 To 4
BinaryChange.Remove (intCounter)
'BinaryPositions.Remove (intCounter)
Next intCounter
Next i
Next Positions
BinaryCrypt = strFinished
End Function
Public Function BinaryToAsc(strBinary As String)
Dim BinaryPositions As New Collection
Dim AscFigures As New Collection
'128 64 32 16 8421
'[ ] [ ] [ ] [ ][ ] [ ] [ ] [ ]
For intCounter = 0 To 7
BinaryPositions.Add (Mid(strBinary, Len(strBinary) - intCounter, 1))
Next intCounter
AscFigures.Add (BinaryPositions.Item(1))
AscFigures.Add (BinaryPositions.Item(2) * 2)
AscFigures.Add (BinaryPositions.Item(3) * 4)
AscFigures.Add (BinaryPositions.Item(4) * 8)
AscFigures.Add (BinaryPositions.Item(5) * 16)
AscFigures.Add (BinaryPositions.Item(6) * 32)
AscFigures.Add (BinaryPositions.Item(7) * 64)
AscFigures.Add (BinaryPositions.Item(8) * 128)
For intCounter = 1 To AscFigures.Count
intAsc = intAsc + CInt(AscFigures.Item(intCounter))
Next intCounter
BinaryToAsc = intAsc
End Function
Public Function AscToBinary(strText As String)
Dim AscCollection As New Collection
Dim TempChr As Integer
'128 64 32 16 8421
'[ ] [ ] [ ] [ ][ ] [ ] [ ] [ ]
For intCounter = 1 To Len(strText)
strTemp = Asc(Mid(strText, intCounter, 1))
AscCollection.Add (strTemp)
Next intCounter
For intCounter = 1 To AscCollection.Count
TempChr = AscCollection.Item(intCounter)
If (TempChr Mod 128) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (TempChr Mod 128)
strBinaryTemp = strBinaryTemp & "1"
End If
If (TempChr Mod 64) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (AscCollection.Item(intCounter) Mod 64)
strBinaryTemp = strBinaryTemp & "1"
End If
If (TempChr Mod 32) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (AscCollection.Item(intCounter) Mod 32)
strBinaryTemp = strBinaryTemp & "1"
End If
If (TempChr Mod 16) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (AscCollection.Item(intCounter) Mod 16)
strBinaryTemp = strBinaryTemp & "1"
End If
If (TempChr Mod 8) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (AscCollection.Item(intCounter) Mod 8)
strBinaryTemp = strBinaryTemp & "1"
End If
If (TempChr Mod 4) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (AscCollection.Item(intCounter) Mod 4)
strBinaryTemp = strBinaryTemp & "1"
End If
If (TempChr Mod 2) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (AscCollection.Item(intCounter) Mod 2)
strBinaryTemp = strBinaryTemp & "1"
End If
If (TempChr Mod 1) = TempChr Then
strBinaryTemp = strBinaryTemp & "0"
Else
TempChr = (AscCollection.Item(intCounter) Mod 1)
strBinaryTemp = strBinaryTemp & "1"
End If
BinaryStrings.Add (strBinaryTemp)
Next intCounter
End Function
Public Function BinaryEncrypt(strText As String)
On Error Resume Next
strEncrypted = vbNullString
For intCounter = 1 To Len(strText)
strTemp = Mid(strText, intCounter, 1)
AscToBinary (strTemp)
Next intCounter
For intCounter = 1 To BinaryStrings.Count
strTemp = Chr(BinaryToAsc(BinaryCrypt(BinaryStrings.Item(intCounter), Len(strText) + 1)))
strEncrypted = strEncrypted & strTemp
Next intCounter
For i = 1 To CInt((BinaryStrings.Count / 2) + 1)
For intCounter = 1 To BinaryStrings.Count
BinaryStrings.Remove (intCounter)
Next intCounter
Next i
BinaryEncrypt = strEncrypted
End Function
Public Function BinaryDecrypt(strText As String)
On Error Resume Next
strDecrypted = vbNullString
For intCounter = 1 To Len(strText)
strTemp = Mid(strText, intCounter, 1)
AscToBinary (strTemp)
Next intCounter
For intCounter = 1 To BinaryStrings.Count
strTemp = Chr(BinaryToAsc(BinaryCrypt(BinaryStrings.Item(intCounter), Len(strText) + 1)))
strDecrypted = strDecrypted & strTemp
Next intCounter
For i = 1 To CInt((BinaryStrings.Count / 2) + 1)
For intCounter = 1 To BinaryStrings.Count
BinaryStrings.Remove (intCounter)
Next intCounter
Next i
BinaryDecrypt = strDecrypted
End Function
' You add it to your application as follows:
Private Sub cmdDecrypt_Click()
MsgBox BinaryDecrypt(txtEncrypted.Text)
End Sub
Private Sub cmdEncrypt_Click()
txtEncrypted.Text = BinaryEncrypt(txtPlain.Text)
End Sub


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Intermediate category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.