Rabu, 28 Oktober 2009

Listing program algoritma enkripsi XOR

Private Function ascii2hex(ByVal ascii As String)
Dim intStrLen As Integer
Dim i As Integer
Dim strHex As String

ascii = Trim(ascii)
intStrLen = Len(ascii)
For i = 1 To intStrLen
strHex = strHex & " " & Hex(Asc(Mid(ascii, i, 1)))
Next
ascii2hex = strHex
End Function

Public Function hex2ascii(sText As String) As String
On Error Resume Next
Dim sBuff() As String, A As Long
Dim hasil As String
sBuff() = Split(sText, Space$(1))
For A = 0 To UBound(sBuff)
hasil = hasil & Chr$("&h" & sBuff(A))
Next A
hex2ascii = hasil
End Function

Public Function Hex2Binary(ByVal Data As String) As String
Dim Binary As String
Dim Pos As Integer

Hex2Binary = ""
For Pos = 1 To Len(Data)
Select Case Mid(Data, Pos, 1)
Case "0": Binary = "0000"
Case "1": Binary = "0001"
Case "2": Binary = "0010"
Case "3": Binary = "0011"
Case "4": Binary = "0100"
Case "5": Binary = "0101"
Case "6": Binary = "0110"
Case "7": Binary = "0111"
Case "8": Binary = "1000"
Case "9": Binary = "1001"
Case "A": Binary = "1010"
Case "B": Binary = "1011"
Case "C": Binary = "1100"
Case "D": Binary = "1101"
Case "E": Binary = "1110"
Case "F": Binary = "1111"
End Select
Hex2Binary = Hex2Binary & Binary
Next
End Function

Public Function Bin2Hex(ByVal Data As String) As String
Dim Hex As String
Dim Pos As Integer

Data = Right("00000000" & Data, 8)

Bin2Hex = ""
For Pos = 1 To 2
Select Case Mid(Data, Len(Data) + 1 - 4 * Pos, 4)
Case "0000": Hex = "0"
Case "0001": Hex = "1"
Case "0010": Hex = "2"
Case "0011": Hex = "3"
Case "0100": Hex = "4"
Case "0101": Hex = "5"
Case "0110": Hex = "6"
Case "0111": Hex = "7"
Case "1000": Hex = "8"
Case "1001": Hex = "9"
Case "1010": Hex = "A"
Case "1011": Hex = "B"
Case "1100": Hex = "C"
Case "1101": Hex = "D"
Case "1110": Hex = "E"
Case "1111": Hex = "F"
End Select
Bin2Hex = Hex & Bin2Hex
Next
End Function

Private Function CekBitWise(ByVal binary1 As String, ByVal binary2 As String) As String
Dim hasil As String
If binary1 = "0" And binary2 = "0" Then
hasil = "0"
End If
If binary1 = "1" And binary2 = "0" Then
hasil = "1"
End If
If binary1 = "0" And binary2 = "1" Then
hasil = "1"
End If
If binary1 = "1" And binary2 = "1" Then
hasil = "0"
End If
CekBitWise = hasil
End Function

Private Sub cmdDecode_Click()
Dim tmp1 As String
Dim key As String
Dim tmpBitwise As String
Dim kata As String
Dim hasil As String

key = ascii2hex(Me.txtKey.Text)
key = Hex2Binary(key)
kata = Me.txtEncoded.Text
For i = 1 To Len(kata)
tmp1 = ascii2hex(Mid(kata, i, 1))
tmp1 = Hex2Binary(tmp1)

Dim sBuff() As String
For A = 1 To 8
tmpBitwise = tmpBitwise + CekBitWise(Mid(key, A, 1), Mid(tmp1, A, 1))
Next
hasil = hasil + hex2ascii(Bin2Hex(tmpBitwise))

Next

Me.txtDecoded.Text = hasil
End Sub

Private Sub cmdEncode_Click()
Dim tmp1 As String
Dim key As String
Dim tmpBitwise As String
Dim kata As String
Dim hasil As String

key = ascii2hex(Me.txtKey.Text)
key = Hex2Binary(key)
kata = Me.txtKata.Text
For i = 1 To Len(kata)
tmp1 = ascii2hex(Mid(kata, i, 1))
tmp1 = Hex2Binary(tmp1)

Dim sBuff() As String
For A = 1 To 8
tmpBitwise = tmpBitwise + CekBitWise(Mid(key, A, 1), Mid(tmp1, A, 1))
Next
hasil = hasil + hex2ascii(Bin2Hex(tmpBitwise))

Next

Me.txtEncoded.Text = hasil
End Sub