Please ..!!!HELP !!! Looking for VB code for Encryption

Hi,

Wonder if you can point me (or provide me..even better!!) to typical encryption code written in VB? I am looking to build a security system for an existing software application and the login information of every user is written into a user manager where each password has to be encrypted.

Y0ur help is much appreciated.

Viji

Lash all this into a .cls module and a few minute's experimentation with the exposed functions should be very instructive....


Option Explicit

Private S1, S2, S3, S4, S5, S6, S7, S8
Private Const sDEFAULTKEY As String = "2E19DF4516E82D5F0B09CA870D7BB8FEA4F9B4C8480E01E23D2E9E0A83A08DC6"

Private Function F(R As String, K As String) As String
Dim x As String

Dim a, b, c, d, e, l, g, h As Integer

x = BigMod32Add(R, K)
a = Val("&H" & Mid(x, 1, 1))
b = Val("&H" & Mid(x, 2, 1))
c = Val("&H" & Mid(x, 3, 1))
d = Val("&H" & Mid(x, 4, 1))
e = Val("&H" & Mid(x, 5, 1))
l = Val("&H" & Mid(x, 6, 1))
g = Val("&H" & Mid(x, 7, 1))
h = Val("&H" & Mid(x, 8, 1))

a = S1(a)
b = S2(b)
c = S3(c)
d = S4(d)
e = S5(e)
l = S6(l)
g = S7(g)
h = S8(h)
x = a & b & c & d & e & l & g & h
x = BigShiftLeft(CStr(x), 11)
F = x
End Function
Private Sub GOSTInit()
S1 = Array(6, 5, 1, 7, 14, 0, 4, 10, 11, 9, 3, 13, 8, 12, 2, 15)
S2 = Array(14, 13, 9, 0, 8, 10, 12, 4, 7, 15, 6, 11, 3, 1, 5, 2)
S3 = Array(6, 5, 1, 7, 2, 4, 10, 0, 11, 13, 14, 3, 8, 12, 15, 9)
S4 = Array(8, 7, 3, 9, 6, 4, 14, 5, 2, 13, 0, 12, 1, 11, 10, 15)
S5 = Array(10, 9, 6, 11, 5, 1, 8, 4, 0, 13, 7, 2, 14, 3, 15, 12)
S6 = Array(5, 3, 0, 6, 11, 13, 4, 14, 10, 7, 1, 12, 2, 8, 15, 9)
S7 = Array(2, 1, 12, 3, 11, 13, 15, 7, 10, 6, 9, 14, 0, 8, 4, 5)
S8 = Array(6, 5, 1, 7, 8, 9, 4, 2, 15, 3, 13, 12, 10, 14, 11, 0)
End Sub
Public Function GOSTEncrypt(ByVal StringToEncrypt As String, Optional ByVal EncryptionKey As String) As String
Dim K(1 To 8) As String
Dim l As String
Dim R As String
Dim j As Integer
Dim i As Integer

If EncryptionKey = "" Then
EncryptionKey = sDEFAULTKEY
End If

StringToEncrypt = PadInp(EnHex(StringToEncrypt))

K(1) = Mid(EncryptionKey, 1, 8)
K(2) = Mid(EncryptionKey, 8, 8)
K(3) = Mid(EncryptionKey, 16, 8)
K(4) = Mid(EncryptionKey, 24, 8)
K(5) = Mid(EncryptionKey, 32, 8)
K(6) = Mid(EncryptionKey, 40, 8)
K(7) = Mid(EncryptionKey, 48, 8)
K(8) = Mid(EncryptionKey, 56, 8)
For j = 1 To Len(StringToEncrypt) Step 16
DoEvents
l = Mid(StringToEncrypt, j, 8)
R = Mid(StringToEncrypt, j + 8, 8)

For i = 1 To 3
R = BigXOR(R, F(l, K(1)))
l = BigXOR(l, F(R, K(2)))
R = BigXOR(R, F(l, K(3)))
l = BigXOR(l, F(R, K(4)))
R = BigXOR(R, F(l, K(5)))
l = BigXOR(l, F(R, K(6)))
R = BigXOR(R, F(l, K(7)))
l = BigXOR(l, F(R, K(8)))
Next i
R = BigXOR(R, F(l, K(8)))
l = BigXOR(l, F(R, K(7)))
R = BigXOR(R, F(l, K(6)))
l = BigXOR(l, F(R, K(5)))
R = BigXOR(R, F(l, K(4)))
l = BigXOR(l, F(R, K(3)))
R = BigXOR(R, F(l, K(2)))
l = BigXOR(l, F(R, K(1)))

Mid(StringToEncrypt, j, 8) = R
Mid(StringToEncrypt, j + 8, 8) = l
Next j
GOSTEncrypt = StringToEncrypt
End Function
Public Function GOSTDecrypt(ByVal StringToDecrypt As String, Optional ByVal DecryptionKey As String) As String
Dim K(1 To 8) As String
Dim l As String
Dim R As String
Dim j As Integer
Dim i As Integer

If DecryptionKey = "" Then
DecryptionKey = sDEFAULTKEY
End If

K(1) = Mid(DecryptionKey, 1, 8)
K(2) = Mid(DecryptionKey, 8, 8)
K(3) = Mid(DecryptionKey, 16, 8)
K(4) = Mid(DecryptionKey, 24, 8)
K(5) = Mid(DecryptionKey, 32, 8)
K(6) = Mid(DecryptionKey, 40, 8)
K(7) = Mid(DecryptionKey, 48, 8)
K(8) = Mid(DecryptionKey, 56, 8)
For j = 1 To Len(StringToDecrypt) Step 16
DoEvents
l = Mid(StringToDecrypt, j, 8)
R = Mid(StringToDecrypt, j + 8, 8)

R = BigXOR(R, F(l, K(1)))
l = BigXOR(l, F(R, K(2)))
R = BigXOR(R, F(l, K(3)))
l = BigXOR(l, F(R, K(4)))
R = BigXOR(R, F(l, K(5)))
l = BigXOR(l, F(R, K(6)))
R = BigXOR(R, F(l, K(7)))
l = BigXOR(l, F(R, K(8)))
For i = 1 To 3
R = BigXOR(R, F(l, K(8)))
l = BigXOR(l, F(R, K(7)))
R = BigXOR(R, F(l, K(6)))
l = BigXOR(l, F(R, K(5)))
R = BigXOR(R, F(l, K(4)))
l = BigXOR(l, F(R, K(3)))
R = BigXOR(R, F(l, K(2)))
l = BigXOR(l, F(R, K(1)))
Next i

'pad to j + 8 chars so subst works
Mid(StringToDecrypt, j, 8) = R
Mid(StringToDecrypt, j + 8, 8) = l
Next j
StringToDecrypt = DeHex(CStr(StringToDecrypt))
GOSTDecrypt = StringToDecrypt
End Function
Public Function GenerateGOSTKey() As String
Dim Key As String
Dim i As Integer
Dim dat As String
For i = 1 To 32
Randomize
dat = Hex(Rnd * 255)
If Len(dat) = 1 Then dat = "0" & dat
Key = Key & dat
Next i
GenerateGOSTKey = Key
End Function
Private Function EnHex(x As String) As String
Dim i As Integer
Dim v As String
Dim inp As String

For i = 1 To Len(x)
v = Hex(Asc(Mid(x, i, 1)))
If Len(v) = 1 Then v = "0" & v
inp = inp & v
Next i
EnHex = inp
End Function
Private Function DeHex(inp As String) As String
Dim i As Integer
Dim v As String
Dim x As String

For i = 1 To Len(inp) Step 2
x = x & Chr(Val("&H" & Mid(inp, i, 2)))
Next i
DeHex = x
End Function
Private Function PadInp(inp As String) As String
check1:
If Not (Len(inp) / 16) = (Len(inp) \ 16) Then
inp = inp & "0"
GoTo check1
End If
PadInp = inp
End Function
Public Sub GostTest(ByVal TestString As String, Optional ByVal Key As String)
Dim sEncString As String
Dim sDecString As String

If Key = "" Then
Key = GenerateGOSTKey
End If

sEncString = GOSTEncrypt(TestString, CStr(Key))
sDecString = GOSTDecrypt(sEncString, CStr(Key))
MsgBox "Original String: " & vbTab & TestString & vbCrLf _
& "Encrypted: " & vbTab & sEncString & vbCrLf _
& "Decrypted: " & vbTab & sDecString & vbCrLf _
& "Successful: " & vbTab & IIf(sDecString = TestString, "YES", "NO")

End Sub
Private Function BigXOR(ByVal value1 As String, ByVal value2 As String) As String
Dim valueans As String
Dim loopit As Integer, tempnum As Integer

tempnum = Len(value1) - Len(value2)
If tempnum < 0 Then
valueans = Left$(value2, Abs(tempnum))
value2 = Mid$(value2, Abs(tempnum) + 1)
ElseIf tempnum > 0 Then
valueans = Left$(value1, Abs(tempnum))
value1 = Mid$(value1, tempnum + 1)
End If

For loopit = 1 To Len(value1)
valueans = valueans + Hex$(Val("&H" + Mid$(value1, loopit, 1)) Xor Val("&H" + Mid$(value2, loopit, 1)))
Next loopit

BigXOR = Right(valueans, 8)
End Function
Private Function BigMod32Add(ByVal value1 As String, ByVal value2 As String) As String
BigMod32Add = Right$(BigAdd(value1, value2), 8)
End Function
Private Function BigAdd(ByVal value1 As String, ByVal value2 As String) As String
Dim valueans As String
Dim loopit As Integer, tempnum As Integer

tempnum = Len(value1) - Len(value2)
If tempnum < 0 Then
value1 = Space$(Abs(tempnum)) + value1
ElseIf tempnum > 0 Then
value2 = Space$(Abs(tempnum)) + value2
End If

tempnum = 0
For loopit = Len(value1) To 1 Step -1
tempnum = tempnum + Val("&H" + Mid$(value1, loopit, 1)) + Val("&H" + Mid$(value2, loopit, 1))
valueans = Hex$(tempnum Mod 16) + valueans
tempnum = Int(tempnum / 16)
Next loopit

If tempnum <> 0 Then
valueans = Hex$(tempnum) + valueans
End If

BigAdd = Right(valueans, 8)
End Function
Private Function BigShiftLeft(value1 As String, shifts As Integer) As String
Dim tempstr As String
Dim loopit As Integer, loopinner As Integer
Dim tempnum As Integer
Dim i As Integer
Dim j As Integer

shifts = shifts Mod 32

If shifts = 0 Then
BigShiftLeft = value1
Exit Function
End If

value1 = Right$(value1, 8)
tempstr = String$(8 - Len(value1), "0") + value1
value1 = ""

' Convert to binary
For loopit = 1 To 8
tempnum = Val("&H" + Mid$(tempstr, loopit, 1))
For loopinner = 3 To 0 Step -1
If tempnum And 2 ^ loopinner Then
value1 = value1 + "1"
Else
value1 = value1 + "0"
End If
Next loopinner
Next loopit

For i = 1 To shifts
For j = 1 To 32
Mid(value1, j, 1) = Mid(value1, j + 1, 1)
If Not Mid(value1, 1, 1) = "0" Then Mid(value1, 1, 1) = "0"
Next j
Next i
tempstr = value1

' And convert back to hex
value1 = ""
For loopit = 0 To 7
tempnum = 0
For loopinner = 0 To 3
If Val(Mid$(tempstr, 4 * loopit + loopinner + 1, 1)) Then
tempnum = tempnum + 2 ^ (3 - loopinner)
End If
Next loopinner
value1 = value1 + Hex$(tempnum)
Next loopit

BigShiftLeft = Right(value1, 8)
End Function



Private Sub Class_Initialize()
Call GOSTInit
End Sub


Colon-Hyphen-Close-Bracket

Go to Http://www.Planet-Source-Code.com/vb and search on "Encrypt" or "Encryption" (Without the quotes of course). You should find a variety of samples.

John G

Thanks for sharing!

Special thanks to Lothar "the Great" Haensler. Come back soon, you Guru.