RSA implementation in VB

Here is a Blowfish implementation.  Please note:

1.  Not compiled as a separate DLL, but is a class that you can include in your project.  Doesn't require turning off overflow checking like the TwoFish implementation.

2.  Basically works on byte arrays, but it has wrapper functions for Text (shown in test code.)

3.  I will not assume any liablility for loss of data or any other damages arising from use of this code.  It is essentially a step for step translation of the original BF algorithm, and I have tested it on many different data sources without problem.  If there are any bugs, a) they would be quite subtle  b) I am not aware of them.

4.  The bf.dat file contains the initialization data for the p and s boxes.  You have a couple of choices.

a) You can load these arrays with random data. (Make sure you are using the full range of the Long data type if you do this.)  if you test the routine against the test vectors provided at Counterpane, you will not get the same results.  However, your data should be as secure.

b)  I can e-mail you the file.

c)  You can recreate the file from the source at www.counterpane.com (what I did originally, although I don't have the source for that anymore :( )

Any questions comments etc. you can post here.  Test code follows the code for clsBlowfish.




Option Explicit

'Long(long integer)  4 bytes -2,147,483,648 to 2,147,483,647

Private Const MaxLong = 2147483647
Private Const MinLong = -2147483648#

Private mbIsInit As Boolean
Private Const strErrSrc = "clsBlowfish"

Private P(1 To 18) As Long
Private S(1 To 4, 0 To 255) As Long

'Types for extracting bytes from words
Private Type LongByteW
    w As Long
End Type

Private Const BFErr = 3400 + vbObjectError

Private Type LongByteB
    b4 As Byte
    b3 As Byte
    b2 As Byte
    b1 As Byte
End Type

Private Function fAddBytes(b1 As Byte, b2 As Byte) As Byte
    fAddBytes = CByte((CInt(b1) + CInt(b2)) Mod 256)
End Function

Private Function fAddLongs(L1 As Long, L2 As Long) As Long
    Dim curRes As Currency, c1 As Currency, c2 As Currency
    Static intCount As Integer
     
    'This function allows you to add the longs without turning off the
    'integer overflow checking.  Thus it is slower, but works in the IDE
    'and with any project you wish to add this code to.
     
    c1 = L1
    c2 = L2
     
    curRes = c1 + c2
     
    If curRes > MaxLong Then
        curRes = curRes - MaxLong + MinLong - 1
    End If
     
    If curRes < MinLong Then
        curRes = curRes + MaxLong - MinLong + 1
    End If
     
    fAddLongs = CLng(curRes)
         
End Function

Public Sub sInitBF(strKey As String)
    Dim i As Integer
    Dim j As Integer
    Dim x As LongByteW      'For conversion
    Dim y As LongByteB      ' """"
    Dim intKeyLen As Integer
    Dim bytKey() As Byte
    Dim lngDataL As Long, lngDataR As Long
     
    intKeyLen = Len(strKey)
    ReDim bytKey(0 To intKeyLen - 1)
     
    Call sStringToByte(strKey, bytKey)
     

    Call sSetPSBox
     
     
    j = 0
    For i = 1 To 18
        y.b1 = bytKey(j)
        y.b2 = bytKey((j + 1) Mod intKeyLen)
        y.b3 = bytKey((j + 2) Mod intKeyLen)
        y.b4 = bytKey((j + 3) Mod intKeyLen)
        LSet x = y
        P(i) = P(i) Xor x.w
        j = (j + 4) Mod intKeyLen
    Next
     
    lngDataL = 0: lngDataR = 0

    For i = 1 To 17 Step 2
        Call BFEncipher(lngDataL, lngDataR)
        P(i) = lngDataL
        P(i + 1) = lngDataR
    Next
     
    For i = 1 To 4
        For j = 0 To 254 Step 2
            Call BFEncipher(lngDataL, lngDataR)
            S(i, j) = lngDataL
            S(i, j + 1) = lngDataR
        Next j
    Next i
     
    mbIsInit = True
     
End Sub

Private Function F(Word As Long) As Long
    Dim x As LongByteW
    Dim y As LongByteB

    x.w = Word
     
    LSet y = x
    'Debug.Print S(1, Y.b1), S(2, Y.b2)
    F = fAddLongs(fAddLongs(S(1, y.b1), S(2, y.b2)) Xor (S(3, y.b3)), S(4, y.b4))
     

End Function

Private Sub Round(xL As Long, xR As Long, intRound As Integer)
    'Debug.Print F(xR), xR
    xL = xL Xor (F(xR) Xor P(intRound))
End Sub

Private Sub BFEncipher(xL As Long, xR As Long)
    Dim lngTemp As Long
    Dim i As Integer
    xL = xL Xor P(1)
    'Call sFilePrintSP
    For i = 2 To 16 Step 2
        Call Round(xR, xL, i)
        Call Round(xL, xR, i + 1)
    Next
     
    xR = xR Xor P(18)
     
    'Swap left and right
    lngTemp = xR
    xR = xL
    xL = lngTemp


End Sub


Private Sub BFDecipher(xL As Long, xR As Long)
    Dim lngTemp As Long
    Dim i As Integer
     
    xL = xL Xor P(18)
     
    For i = 17 To 3 Step -2
        Call Round(xR, xL, i)
        Call Round(xL, xR, i - 1)
    Next
     
    xR = xR Xor P(1)
     
    'Swap left and right
    lngTemp = xR
    xR = xL
    xL = lngTemp


End Sub





Private Sub sFilePrintSP()
'For debugging only.
     
    Dim i As Integer
     
    Open "C:\Windows\Desktop\SPWin.txt" For Output As #1
     
    Print #1, ""
    Print #1, "PBox"
    Print #1, ""
    For i = 1 To 15 Step 6
        Print #1, P(i), P(i + 1), P(i + 2), P(i + 3), P(i + 4), P(i + 5)
    Next
    Print #1, ""
    Print #1, "SBox"
    Print #1, ""
    For i = 0 To 252 Step 4
        Print #1, S(1, i), S(1, i + 1), S(1, i + 2), S(1, i + 3)
    Next
    Close #1



End Sub

Public Sub sEncrypt(bytToEncrypt() As Byte, bytEncrypted() As Byte)

'This Sub assumes you are passing a 64 bit divisible zero-based array of bytes to
'encode and a similarly sized array to hold the encrypted version.
'Todo:  Add error checking for these conditions

    Dim lngLenStr As Long
    Dim lngLenBStr As Long
    Dim xL As LongByteB, xR  As LongByteB
    Dim yL As LongByteW, yR  As LongByteW
    Dim i As Long
    Dim strRet As String
    Dim bytB As Byte
     
    'Check zero based
    bytB = bytToEncrypt(0)
    bytB = bytEncrypted(0)
     
     
    If UBound(bytToEncrypt) <> UBound(bytEncrypted) Then
        Err.Raise BFErr + 2, strErrSrc, "Need to pass two byte arrays the same size"
        Exit Sub
    End If
     
    If (UBound(bytToEncrypt) + 1) Mod 8 <> 0 Then
        Err.Raise BFErr + 3, strErrSrc, "Byte array must be sized divisible by 8."
        Exit Sub
    End If
     
    If Not mbIsInit Then
        Err.Raise BFErr + 1, strErrSrc, "Call sInitBF before calling this sub"
        Exit Sub
    End If
     
    lngLenBStr = UBound(bytToEncrypt) + 1
     
    For i = 0 To lngLenBStr - 8 Step 8
        xL.b1 = bytToEncrypt(i)
        xL.b2 = bytToEncrypt(i + 1)
        xL.b3 = bytToEncrypt(i + 2)
        xL.b4 = bytToEncrypt(i + 3)
         
        xR.b1 = bytToEncrypt(i + 4)
        xR.b2 = bytToEncrypt(i + 5)
        xR.b3 = bytToEncrypt(i + 6)
        xR.b4 = bytToEncrypt(i + 7)
         
        LSet yR = xR
        LSet yL = xL
         
'        Debug.Print Hex(yL.w), Hex(yR.w)
         
        Call BFEncipher(yL.w, yR.w)
         
'        Debug.Print Hex(yL.w), Hex(yR.w)
         
        LSet xR = yR
        LSet xL = yL
         
        bytEncrypted(i) = xL.b1
        bytEncrypted(i + 1) = xL.b2
        bytEncrypted(i + 2) = xL.b3
        bytEncrypted(i + 3) = xL.b4
         
        bytEncrypted(i + 4) = xR.b1
        bytEncrypted(i + 5) = xR.b2
        bytEncrypted(i + 6) = xR.b3
        bytEncrypted(i + 7) = xR.b4
         
         
    Next i
     

End Sub


Public Sub sDecrypt(bytToDecrypt() As Byte, bytUnencrypted() As Byte)

'This Sub assumes you are passing a 64 bit divisible zero-based array of bytes to
'encode and a similarly sized array to hold the encrypted version.
'Todo:  Add error checking for these conditions

'    Dim bytToDecrypt() As Byte
    Dim lngLenStr As Long
    Dim lngLenBStr As Long
    Dim xL As LongByteB, xR  As LongByteB
    Dim yL As LongByteW, yR  As LongByteW
    Dim i As Long
    Dim strRet As String
     
   lngLenStr = UBound(bytToDecrypt) + 1
    lngLenBStr = lngLenStr
     
    If UBound(bytToDecrypt) <> UBound(bytUnencrypted) Then
        Err.Raise BFErr + 2, strErrSrc, "Need to pass two byte arrays the same size"
        Exit Sub
    End If
     
    If (UBound(bytToDecrypt) + 1) Mod 8 <> 0 Then
        Err.Raise BFErr + 3, strErrSrc, "Byte array must be sized divisible by 8."
        Exit Sub
    End If
     
    If Not mbIsInit Then
        Err.Raise BFErr + 1, strErrSrc, "Call sInitBF before calling this sub"
        Exit Sub
    End If

     
    For i = 0 To lngLenBStr - 8 Step 8
        xL.b1 = bytToDecrypt(i)
        xL.b2 = bytToDecrypt(i + 1)
        xL.b3 = bytToDecrypt(i + 2)
        xL.b4 = bytToDecrypt(i + 3)
         
        xR.b1 = bytToDecrypt(i + 4)
        xR.b2 = bytToDecrypt(i + 5)
        xR.b3 = bytToDecrypt(i + 6)
        xR.b4 = bytToDecrypt(i + 7)
         
        LSet yR = xR
        LSet yL = xL
         
'        Debug.Print Hex(yL.w), Hex(yR.w)
         
        Call BFDecipher(yL.w, yR.w)
         
'        Debug.Print Hex(yL.w), Hex(yR.w)
         
        LSet xR = yR
        LSet xL = yL
         
        bytUnencrypted(i) = xL.b1
        bytUnencrypted(i + 1) = xL.b2
        bytUnencrypted(i + 2) = xL.b3
        bytUnencrypted(i + 3) = xL.b4
         
        bytUnencrypted(i + 4) = xR.b1
        bytUnencrypted(i + 5) = xR.b2
        bytUnencrypted(i + 6) = xR.b3
        bytUnencrypted(i + 7) = xR.b4
         
         
    Next i


End Sub


Private Function fTrimZeroBytes(S As String) As String

    Dim i As Long
    Dim lngLen As Long
    Dim lngPos As Long
     
    lngLen = Len(S)
     
    For i = lngLen To 1 Step -1
        If Asc(Mid$(S, i, 1)) <> 0 Then
            lngPos = i
            Exit For
        End If
    Next i
     
    fTrimZeroBytes = Left$(S, lngPos)
     
End Function



Private Sub sSetPSBox()

    Dim strPath As String
    Dim hFile As Integer
     
    strPath = App.Path
     
    If Right$(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
'    Debug.Print strPath
    If Len(Dir(strPath & "bf.dat")) = 0 Then
        Err.Raise BFErr + 3, , "bf.dat not found"
        Exit Sub
    End If
     
    hFile = FreeFile
    Open strPath & "bf.dat" For Binary As hFile
    Get #hFile, , P
    Get #hFile, , S
    Close #hFile
     
End Sub

Public Sub sFileEncrypt(strFileSrc As String, strFileTrg As String)
     
     
    Dim lngLen As Long
    Dim lngLenB As Long
    Dim strFile As String
    Dim strEnc As String
    Dim bytSource() As Byte
    Dim bytTarget() As Byte
    Dim strUnEnc As String
    Dim sngTimer As Single
    Dim hFile As Integer
     
    If Not mbIsInit Then
        Err.Raise BFErr + 1, , "Call sInitBF before calling this sub"
        Exit Sub
    End If
     
    If Len(Dir(strFileSrc)) = 0 Then
        Err.Raise BFErr + 2, , "Source file is not found"
        Exit Sub
    End If
     
    sngTimer = Timer
     
    lngLen = FileLen(strFileSrc)
    ReDim bytSource(0 To lngLen - 1)
     
    hFile = FreeFile
    Open strFileSrc For Binary As #hFile
    Get #hFile, , bytSource
    Close #hFile
     
    'Need to pad the string with zeroes if not divisible by 64 bits
    If lngLen Mod 8 <> 0 Then
        lngLenB = lngLen + (8 - lngLen Mod 8)
    Else
        lngLenB = lngLen
    End If
     
'    Debug.Print lngLenB
     
    ReDim Preserve bytSource(0 To lngLenB - 1)
    ReDim bytTarget(0 To lngLenB - 1)
     
     
    Call sEncrypt(bytSource, bytTarget)
     
    If Len(Dir(strFileTrg)) <> 0 Then
        Kill strFileTrg
    End If
     
     
     
    hFile = FreeFile
    Open strFileTrg For Binary As #hFile
    'Save the original file length so that we know how much padding to remove.
    Put #hFile, , lngLen
    Put #hFile, , bytTarget
    Close #hFile
     
    Debug.Print Timer - sngTimer


End Sub

Public Sub sFileDecrypt(strFileSrc As String, strFileTrg As String)
     
     
    Dim lngLen As Long
    Dim lngLenB As Long
    Dim strFile As String
    Dim strEnc As String
    Dim bytSource() As Byte
    Dim bytTarget() As Byte
    Dim strUnEnc As String
    Dim sngTimer As Single
    Dim hFile As Integer
     
    If Not mbIsInit Then
        Err.Raise BFErr + 1, , "Call sInitBF before calling this sub"
        Exit Sub
    End If
     
    If Len(Dir(strFileSrc)) = 0 Then
        Err.Raise BFErr + 2, , "Source file is not found"
        Exit Sub
    End If

    sngTimer = Timer
     
     
    lngLenB = FileLen(strFileSrc) - 4
     
'    Debug.Print lngLenB
     
    ReDim bytSource(0 To lngLenB - 1)
    ReDim bytTarget(0 To lngLenB - 1)
     
     
    hFile = FreeFile
    Open strFileSrc For Binary As #hFile
    Get #hFile, , lngLen
    Get #hFile, , bytSource
    Close #hFile
     
   
     
    Call sDecrypt(bytSource, bytTarget)
     
    ReDim Preserve bytTarget(0 To lngLen - 1)
     
    If Len(Dir(strFileTrg)) <> 0 Then
        Kill strFileTrg
    End If
     
    hFile = FreeFile
    Open strFileTrg For Binary As #hFile
    Put #hFile, , bytTarget
    Close #hFile
     
    Debug.Print Timer - sngTimer

End Sub

Private Sub sStringToByte(strS As String, bytB() As Byte)

'    Dim i As Integer
'
'    For i = 1 To Len(strS)
'        bytB(i - 1) = CByte(Asc(Mid$(strS, i, 1)))
'    Next

bytB = StrConv(strS, vbFromUnicode)

End Sub

Public Sub sStringEncrypt(strToEncrypt As String, strEncrypted As String)
    Dim bytToEncrypt() As Byte
    Dim bytEncrypted() As Byte
    Dim lngLenStr As Long
    Dim lngLenBStr As Long
    Dim xL As LongByteB, xR  As LongByteB
    Dim yL As LongByteW, yR  As LongByteW
    Dim i As Long
    Dim strRet As String
     
    lngLenStr = Len(strToEncrypt)
     
     
    'Need to pad the string with zeroes if not divisible by 64 bits
    If lngLenStr Mod 8 <> 0 Then
        lngLenBStr = lngLenStr + (8 - lngLenStr Mod 8)
    Else
        lngLenBStr = lngLenStr
    End If
     
     
'    ReDim bytToEncrypt(0 To lngLenBStr - 1)
     
    Call sStringToByte(strToEncrypt, bytToEncrypt)
    ReDim Preserve bytToEncrypt(0 To lngLenBStr - 1)
    ReDim bytEncrypted(0 To lngLenBStr - 1)
     
    Call sEncrypt(bytToEncrypt, bytEncrypted)
     
    strEncrypted = StrConv(bytEncrypted, vbUnicode)



End Sub


Public Sub sStringDecrypt(strToDecrypt As String, strUnencrypted As String)
     Dim bytToDecrypt() As Byte
    Dim bytDecrypted() As Byte
    Dim lngLenStr As Long
    Dim lngLenBStr As Long
    Dim xL As LongByteB, xR  As LongByteB
    Dim yL As LongByteW, yR  As LongByteW
    Dim i As Long
    Dim strRet As String
     
    lngLenStr = Len(strToDecrypt)
    'Should be divisible by 8
    'TODO:
    'Error checking on 64 bit boundary
     
    If lngLenStr Mod 8 <> 0 Then
        Err.Raise BFErr + 3, , "String to decrypt should be sized divisible by 8."
        Exit Sub
     
    End If
 
    Call sStringToByte(strToDecrypt, bytToDecrypt)
    ReDim bytDecrypted(0 To UBound(bytToDecrypt))
     
    Call sDecrypt(bytToDecrypt, bytDecrypted)
     
    strUnencrypted = StrConv(bytDecrypted, vbUnicode)
    i = InStr(1, strUnencrypted, Chr(0))
    If i > 1 Then
        strUnencrypted = Left$(strUnencrypted, i - 1)
    End If
     



End Sub



'-----Test code

Private Sub Command5_Click()
    Dim Enc As clsBlowfish
    Dim strEnc As String
    Dim strPlain As String
     

    Set Enc = New clsBlowfish

    Call Enc.sInitBF("abcdefghijklmnopqrstuvwxyz")
    Call Enc.sStringEncrypt("BLOWFISHHowdiedoodie was a sailor.....     ", strEnc)
    Debug.Print strEnc
     
    Call Enc.sStringDecrypt(strEnc, strPlain)
    Debug.Print strPlain
'    call enc.sStringDecrypt(
     
'    Debug.Print Enc.fDecrypt(strEnc)


End Sub