VB - GOST data encryption standard (equivalent to the US DES)

[mentor99]

Put this into a module and uncomment the public sub main in the middle of the source file to see how it works.

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