VB Code:
Attribute VB_Name = "modGost"
'-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-
'Gosudarstvennyi Standard Soyuza SSR 28147-89
' (GOST 28147-89)
'-=-=-=-=-=-=-=-=-=-=-=-=-=--=-=-=-=-=-=-=-=-
Private S1, S2, S3, S4, S5, S6, S7, S8
Private Function F(R As String, k As String) As String
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
Public Sub InitGOST()
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
Private Function Encrypt(ByVal inp As String, ByVal key As String) As String
Dim k(1 To 8) As String
Dim l As String
Dim R As String
k(1) = mid(key, 1, 8)
k(2) = mid(key, 8, 8)
k(3) = mid(key, 16, 8)
k(4) = mid(key, 24, 8)
k(5) = mid(key, 32, 8)
k(6) = mid(key, 40, 8)
k(7) = mid(key, 48, 8)
k(8) = mid(key, 56, 8)
For j = 1 To Len(inp) Step 16
DoEvents
l = mid(inp, j, 8)
R = mid(inp, 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(inp, j, 8) = R
Mid(inp, j + 8, 8) = l
Next j
Encrypt = inp
End Function
Public Function EncryptGOST(ByVal inp As String, ByVal key As String) As String
Dim inpHex As String
inpHex = PadInp(EnHex(inp))
EncryptGOST = Encrypt(inpHex, key)
End Function
Public Function DecryptGOST(ByVal inp As String, ByVal key As String) As String
Dim k(1 To 8) As String
Dim l As String
Dim R As String
k(1) = mid(key, 1, 8)
k(2) = mid(key, 8, 8)
k(3) = mid(key, 16, 8)
k(4) = mid(key, 24, 8)
k(5) = mid(key, 32, 8)
k(6) = mid(key, 40, 8)
k(7) = mid(key, 48, 8)
k(8) = mid(key, 56, 8)
For j = 1 To Len(inp) Step 16
DoEvents
l = mid(inp, j, 8)
R = mid(inp, 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
Mid(inp, j, 8) = R
Mid(inp, j + 8, 8) = l
Next j
DecryptGOST = inp
End Function
Public Function GenKeyGOST() 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
GenKeyGOST = key
End Function
Public Function EnHex(X As String) 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
Public Function DeHex(inp As String) 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
Public 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 main()
'Init
'key = GenKey
'x = PadInp(EnHex("Test This Encryption"))
'L = Encrypt(CStr(x), CStr(key))
'MsgBox DeHex(CStr(L))
'inp = Decrypt(CStr(L), CStr(key))
'x = DeHex(CStr(inp))
'MsgBox x
'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
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
