modEncryption.bas

 Attribute VB_Name = "modEncryption"
Option Private Module
Option Explicit

Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetProvParam Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwParam As Long, ByRef pbData As Any, ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal HKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDeriveKey Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, ByRef phKey As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
Private Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal HKey As Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, ByRef pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal HKey As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal HKey As Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, ByRef pdwDataLen As Long) As Long
Private Const SERVICE_PROVIDER As String = "Microsoft Base Cryptographic Provider v1.0"
Private Const PROV_RSA_FULL As Long = 1
Private Const PP_NAME As Long = 4
Private Const PP_CONTAINER As Long = 6
Private Const CRYPT_NEWKEYSET As Long = 8
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_MD5 As Long = 3
Private Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
Private Const CALG_RC4 As Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
Private Const ENCRYPT_ALGORITHM As Long = CALG_RC4
Private Const ENCRYPT_NUMBERKEY As String = "16006833"
Private lngCryptProvider As Long
Private avarSeedValues As Variant
Private lngSeedLevel As Long
Private lngDecryptPointer As Long
Private astrEncryptionKey(0 To 131) As String
Private Const lngALPKeyLength As Long = 8
Public strKeyContainer As String

Public Function DecryptWithALP(strData As String) As String
    Dim strALPKey As String
    Dim strALPKeyMask As String
    Dim lngIterator As Long
    Dim blnOscillator As Boolean
    Dim strOutput As String
    Dim lngHex As Long
    If Len(strData) = 0 Then
        Exit Function
    End If
    strALPKeyMask = Right$(String$(lngALPKeyLength, "0") + DoubleToBinary(CLng("&H" + Left$(strData, 2))), lngALPKeyLength)
    strData = Right$(strData, Len(strData) - 2)
    For lngIterator = lngALPKeyLength To 1 Step -1
        If Mid$(strALPKeyMask, lngIterator, 1) = "1" Then
            strALPKey = Left$(strData, 1) + strALPKey
            strData = Right$(strData, Len(strData) - 1)
        Else
            strALPKey = Right$(strData, 1) + strALPKey
            strData = Left$(strData, Len(strData) - 1)
        End If
    Next lngIterator
    lngIterator = 0
    Do Until Len(strData) = 0
        blnOscillator = Not blnOscillator
        lngIterator = lngIterator + 1
        If lngIterator > lngALPKeyLength Then
            lngIterator = 1
        End If
        lngHex = IIf(blnOscillator, CLng("&H" + Left$(strData, 2) - Asc(Mid$(strALPKey, lngIterator, 1))), CLng("&H" + Left$(strData, 2) + Asc(Mid$(strALPKey, lngIterator, 1))))
        If lngHex > 255 Then
            lngHex = lngHex - 255
        ElseIf lngHex < 0 Then
            lngHex = lngHex + 255
        End If
        strOutput = strOutput + Chr$(lngHex)
        strData = Right$(strData, Len(strData) - 2)
    Loop
    DecryptWithALP = strOutput
End Function

Public Function DecryptWithClipper(ByVal strData As String, ByVal strCryptKey As String) As String
    Dim strDecryptionChunk As String
    Dim strDecryptedText As String
    On Error Resume Next
    InitCrypt strCryptKey
    Do Until Len(strData) < 16
        strDecryptionChunk = ""
        strDecryptionChunk = Left$(strData, 16)
        strData = Right$(strData, Len(strData) - 16)
        If Len(strDecryptionChunk) > 0 Then
            strDecryptedText = strDecryptedText + PerformClipperDecryption(strDecryptionChunk)
        End If
    Loop
    DecryptWithClipper = Trim(strDecryptedText)
End Function

Public Function DecryptWithCSP(ByVal strData As String, ByVal strCryptKey As String) As String
    Dim lngEncryptionCount As Long
    Dim strDecrypted As String
    Dim strCurrentCryptKey As String
    If EncryptionCSPConnect() Then
        lngEncryptionCount = DecryptNumber(Mid$(strData, 1, 8))
        strCurrentCryptKey = strCryptKey & lngEncryptionCount
        strDecrypted = EncryptDecrypt(Mid$(strData, 9), strCurrentCryptKey, False)
        DecryptWithCSP = strDecrypted
        EncryptionCSPDisconnect
    End If
End Function

Public Function EncryptWithALP(strData As String) As String
    Dim strALPKey As String
    Dim strALPKeyMask As String
    Dim lngIterator As Long
    Dim blnOscillator As Boolean
    Dim strOutput As String
    Dim lngHex As Long
    If Len(strData) = 0 Then
        Exit Function
    End If
    Randomize
    For lngIterator = 1 To lngALPKeyLength
        strALPKey = strALPKey + Trim$(Hex$(Int(16 * Rnd)))
        strALPKeyMask = strALPKeyMask + Trim$(Int(2 * Rnd))
    Next lngIterator
    lngIterator = 0
    Do Until Len(strData) = 0
        blnOscillator = Not blnOscillator
        lngIterator = lngIterator + 1
        If lngIterator > lngALPKeyLength Then
            lngIterator = 1
        End If
        lngHex = IIf(blnOscillator, CLng(Asc(Left$(strData, 1)) + Asc(Mid$(strALPKey, lngIterator, 1))), CLng(Asc(Left$(strData, 1)) - Asc(Mid$(strALPKey, lngIterator, 1))))
        If lngHex > 255 Then
            lngHex = lngHex - 255
        ElseIf lngHex < 0 Then
            lngHex = lngHex + 255
        End If
        strOutput = strOutput + Right$(String$(2, "0") + Hex$(lngHex), 2)
        strData = Right$(strData, Len(strData) - 1)
    Loop
    For lngIterator = 1 To lngALPKeyLength
        If Mid$(strALPKeyMask, lngIterator, 1) = "1" Then
            strOutput = Mid$(strALPKey, lngIterator, 1) + strOutput
        Else
            strOutput = strOutput + Mid$(strALPKey, lngIterator, 1)
        End If
    Next lngIterator
    EncryptWithALP = Right$(String$(2, "0") + Hex$(BinaryToDouble(strALPKeyMask)), 2) + strOutput
End Function

Public Function EncryptWithClipper(ByVal strData As String, ByVal strCryptKey As String) As String
    Dim strEncryptionChunk As String
    Dim strEncryptedText As String
    If Len(strData) > 0 Then
        InitCrypt strCryptKey
        Do Until Len(strData) = 0
            strEncryptionChunk = ""
            If Len(strData) > 6 Then
                strEncryptionChunk = Left$(strData, 6)
                strData = Right$(strData, Len(strData) - 6)
            Else
                strEncryptionChunk = Left$(strData + Space(6), 6)
                strData = ""
            End If
            If Len(strEncryptionChunk) > 0 Then
                strEncryptedText = strEncryptedText + PerformClipperEncryption(strEncryptionChunk)
            End If
        Loop
    End If
    EncryptWithClipper = strEncryptedText
End Function

Public Function EncryptWithCSP(ByVal strData As String, ByVal strCryptKey As String) As String
    Dim strEncrypted As String
    Dim lngEncryptionCount As Long
    Dim strCurrentCryptKey As String
    If EncryptionCSPConnect() Then
        lngEncryptionCount = 0
        strCurrentCryptKey = strCryptKey & lngEncryptionCount
        strEncrypted = EncryptDecrypt(strData, strCurrentCryptKey, True)
        Do While (InStr(1, strEncrypted, vbCr) > 0) Or (InStr(1, strEncrypted, vbLf) > 0) Or (InStr(1, strEncrypted, Chr$(0)) > 0) Or (InStr(1, strEncrypted, vbTab) > 0)
            lngEncryptionCount = lngEncryptionCount + 1
            strCurrentCryptKey = strCryptKey & lngEncryptionCount
            strEncrypted = EncryptDecrypt(strData, strCurrentCryptKey, True)
            If lngEncryptionCount = 99999999 Then
                Err.Raise vbObjectError + 999, "EncryptWithCSP", "This Data cannot be successfully encrypted"
                EncryptWithCSP = ""
                Exit Function
            End If
        Loop
        EncryptWithCSP = EncryptNumber(lngEncryptionCount) & strEncrypted
        EncryptionCSPDisconnect
    End If
End Function

Public Function GetCSPDetails() As String
    Dim lngDataLength As Long
    Dim bytContainer() As Byte
    If EncryptionCSPConnect Then
        If lngCryptProvider = 0 Then
            GetCSPDetails = "Not connected to CSP"
            Exit Function
        End If
        lngDataLength = 1000
        ReDim bytContainer(lngDataLength)
        If CryptGetProvParam(lngCryptProvider, PP_NAME, bytContainer(0), lngDataLength, 0) <> 0 Then
            GetCSPDetails = "Cryptographic Service Provider name: " & ByteToString(bytContainer, lngDataLength)
        End If
        lngDataLength = 1000
        ReDim bytContainer(lngDataLength)
        If CryptGetProvParam(lngCryptProvider, PP_CONTAINER, bytContainer(0), lngDataLength, 0) <> 0 Then
            GetCSPDetails = GetCSPDetails & vbCrLf & "Key Container name: " & ByteToString(bytContainer, lngDataLength)
        End If
        EncryptionCSPDisconnect
    Else
        GetCSPDetails = "Not connected to CSP"
    End If
End Function

Private Function DecryptNumber(ByVal strData As String) As Long
    Dim lngIterator As Long
    For lngIterator = 1 To 8
        DecryptNumber = (10 * DecryptNumber) + (Asc(Mid$(strData, lngIterator, 1)) - Asc(Mid$(ENCRYPT_NUMBERKEY, lngIterator, 1)))
    Next lngIterator
End Function
Private Function EncryptDecrypt(ByVal strData As String, ByVal strCryptKey As String, ByVal Encrypt As Boolean) As String
    Dim lngDataLength As Long
    Dim strTempData As String
    Dim lngHaslngCryptKey As Long
    Dim lngCryptKey As Long
    If lngCryptProvider = 0 Then
        Err.Raise vbObjectError + 999, "EncryptDecrypt", "Not connected to CSP"
        Exit Function
    End If
    If CryptCreateHash(lngCryptProvider, CALG_MD5, 0, 0, lngHaslngCryptKey) = 0 Then
        Err.Raise vbObjectError + 999, "EncryptDecrypt", "Error during CryptCreateHash."
    End If
    If CryptHashData(lngHaslngCryptKey, strCryptKey, Len(strCryptKey), 0) = 0 Then
        Err.Raise vbObjectError + 999, "EncryptDecrypt", "Error during CryptHashData."
    End If
    If CryptDeriveKey(lngCryptProvider, ENCRYPT_ALGORITHM, lngHaslngCryptKey, 0, lngCryptKey) = 0 Then
        Err.Raise vbObjectError + 999, "EncryptDecrypt", "Error during CryptDeriveKey!"
    End If
    strTempData = strData
    lngDataLength = Len(strData)
    If Encrypt Then
        If CryptEncrypt(lngCryptKey, 0, 1, 0, strTempData, lngDataLength, lngDataLength) = 0 Then
            Err.Raise vbObjectError + 999, "EncryptDecrypt", "Error during CryptEncrypt."
        End If
    Else
        If CryptDecrypt(lngCryptKey, 0, 1, 0, strTempData, lngDataLength) = 0 Then
            Err.Raise vbObjectError + 999, "EncryptDecrypt", "Error during CryptDecrypt."
        End If
    End If
    EncryptDecrypt = Mid$(strTempData, 1, lngDataLength)
    If lngCryptKey <> 0 Then
        CryptDestroyKey lngCryptKey
    End If
    If lngHaslngCryptKey <> 0 Then
        CryptDestroyHash lngHaslngCryptKey
    End If
End Function

Private Function EncryptionCSPConnect() As Boolean
    If Len(strKeyContainer) = 0 Then
        strKeyContainer = "FastTrack"
    End If
    If CryptAcquireContext(lngCryptProvider, strKeyContainer, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 Then
        If CryptAcquireContext(lngCryptProvider, strKeyContainer, SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0 Then
            Err.Raise vbObjectError + 999, "EncryptionCSPConnect", "Error during CryptAcquireContext for a new key container." & vbCrLf & "A container with this name probably already exists."
            EncryptionCSPConnect = False
            Exit Function
        End If
    End If
    EncryptionCSPConnect = True
End Function

Private Function EncryptNumber(ByVal lngData As Long) As String
    Dim lngIterator As Long
    Dim strData As String
    strData = Format$(lngData, "00000000")
    For lngIterator = 1 To 8
        EncryptNumber = EncryptNumber & Chr$(Asc(Mid$(ENCRYPT_NUMBERKEY, lngIterator, 1)) + Val(Mid$(strData, lngIterator, 1)))
    Next lngIterator
End Function

Private Sub EncryptionCSPDisconnect()
    If lngCryptProvider <> 0 Then
        CryptReleaseContext lngCryptProvider, 0
    End If
End Sub

Private Sub InitCrypt(ByRef strEncryptionKey As String)
    avarSeedValues = Array("A3", "D7", "09", "83", "F8", "48", "F6", "F4", "B3", "21", "15", "78", "99", "B1", "AF", _
    "F9", "E7", "2D", "4D", "8A", "CE", "4C", "CA", "2E", "52", "95", "D9", "1E", "4E", "38", "44", "28", "0A", "DF", _
    "02", "A0", "17", "F1", "60", "68", "12", "B7", "7A", "C3", "E9", "FA", "3D", "53", "96", "84", "6B", "BA", "F2", _
    "63", "9A", "19", "7C", "AE", "E5", "F5", "F7", "16", "6A", "A2", "39", "B6", "7B", "0F", "C1", "93", "81", "1B", _
    "EE", "B4", "1A", "EA", "D0", "91", "2F", "B8", "55", "B9", "DA", "85", "3F", "41", "BF", "E0", "5A", "58", "80", _
    "5F", "66", "0B", "D8", "90", "35", "D5", "C0", "A7", "33", "06", "65", "69", "45", "00", "94", "56", "6D", "98", _
    "9B", "76", "97", "FC", "B2", "C2", "B0", "FE", "DB", "20", "E1", "EB", "D6", "E4", "DD", "47", "4A", "1D", "42", _
    "ED", "9E", "6E", "49", "3C", "CD", "43", "27", "D2", "07", "D4", "DE", "C7", "67", "18", "89", "CB", "30", "1F", _
    "8D", "C6", "8F", "AA", "C8", "74", "DC", "C9", "5D", "5C", "31", "A4", "70", "88", "61", "2C", "9F", "0D", "2B", _
    "87", "50", "82", "54", "64", "26", "7D", "03", "40", "34", "4B", "1C", "73", "D1", "C4", "FD", "3B", "CC", "FB", _
    "7F", "AB", "E6", "3E", "5B", "A5", "AD", "04", "23", "9C", "14", "51", "22", "F0", "29", "79", "71", "7E", "FF", _
    "8C", "0E", "E2", "0C", "EF", "BC", "72", "75", "6F", "37", "A1", "EC", "D3", "8E", "62", "8B", "86", "10", "E8", _
    "08", "77", "11", "BE", "92", "4F", "24", "C5", "32", "36", "9D", "CF", "F3", "A6", "BB", "AC", "5E", "6C", "A9", _
    "13", "57", "25", "B5", "E3", "BD", "A8", "3A", "01", "05", "59", "2A", "46")
    SetKey strEncryptionKey
End Sub

Private Function PerformClipperDecryption(ByVal strData As String) As String
    Dim bytChunk(1 To 4, 0 To 32) As String
    Dim bytCounter(0 To 32) As Byte
    Dim lngIterator As Long
    Dim strDecryptedData As String
    On Error Resume Next
    bytChunk(1, 32) = Mid(strData, 1, 4)
    bytChunk(2, 32) = Mid(strData, 5, 4)
    bytChunk(3, 32) = Mid(strData, 9, 4)
    bytChunk(4, 32) = Mid(strData, 13, 4)
    lngSeedLevel = 32
    lngDecryptPointer = 31
    For lngIterator = 0 To 32
        bytCounter(lngIterator) = lngIterator + 1
    Next lngIterator
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel - 1) = PerformClipperDecryptionChunk(bytChunk(2, lngSeedLevel), astrEncryptionKey())
        bytChunk(2, lngSeedLevel - 1) = PerformXOR(PerformClipperDecryptionChunk(bytChunk(2, lngSeedLevel), astrEncryptionKey()), PerformXOR(bytChunk(3, lngSeedLevel), Hex(bytCounter(lngSeedLevel - 1))))
        bytChunk(3, lngSeedLevel - 1) = bytChunk(4, lngSeedLevel)
        bytChunk(4, lngSeedLevel - 1) = bytChunk(1, lngSeedLevel)
        lngDecryptPointer = lngDecryptPointer - 1
        lngSeedLevel = lngSeedLevel - 1
    Next lngIterator
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel - 1) = PerformClipperDecryptionChunk(bytChunk(2, lngSeedLevel), astrEncryptionKey())
        bytChunk(2, lngSeedLevel - 1) = bytChunk(3, lngSeedLevel)
        bytChunk(3, lngSeedLevel - 1) = bytChunk(4, lngSeedLevel)
        bytChunk(4, lngSeedLevel - 1) = PerformXOR(PerformXOR(bytChunk(1, lngSeedLevel), bytChunk(2, lngSeedLevel)), Hex(bytCounter(lngSeedLevel - 1)))
        lngDecryptPointer = lngDecryptPointer - 1
        lngSeedLevel = lngSeedLevel - 1
    Next lngIterator
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel - 1) = PerformClipperDecryptionChunk(bytChunk(2, lngSeedLevel), astrEncryptionKey())
        bytChunk(2, lngSeedLevel - 1) = PerformXOR(PerformClipperDecryptionChunk(bytChunk(2, lngSeedLevel), astrEncryptionKey()), PerformXOR(bytChunk(3, lngSeedLevel), Hex(bytCounter(lngSeedLevel - 1))))
        bytChunk(3, lngSeedLevel - 1) = bytChunk(4, lngSeedLevel)
        bytChunk(4, lngSeedLevel - 1) = bytChunk(1, lngSeedLevel)
        lngDecryptPointer = lngDecryptPointer - 1
        lngSeedLevel = lngSeedLevel - 1
    Next lngIterator
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel - 1) = PerformClipperDecryptionChunk(bytChunk(2, lngSeedLevel), astrEncryptionKey())
        bytChunk(2, lngSeedLevel - 1) = bytChunk(3, lngSeedLevel)
        bytChunk(3, lngSeedLevel - 1) = bytChunk(4, lngSeedLevel)
        bytChunk(4, lngSeedLevel - 1) = PerformXOR(PerformXOR(bytChunk(1, lngSeedLevel), bytChunk(2, lngSeedLevel)), Hex(bytCounter(lngSeedLevel - 1)))
        lngDecryptPointer = lngDecryptPointer - 1
        lngSeedLevel = lngSeedLevel - 1
    Next lngIterator
    strDecryptedData = HexToString(bytChunk(1, 0) & bytChunk(2, 0) & bytChunk(3, 0) & bytChunk(4, 0))
    If InStr(strDecryptedData, Chr$(0)) > 0 Then
        strDecryptedData = Left$(strDecryptedData, InStr(strDecryptedData, Chr$(0)) - 1)
    End If
    PerformClipperDecryption = strDecryptedData
End Function

Private Function PerformClipperDecryptionChunk(ByVal strData As String, ByRef strEncryptionKey() As String) As String
    Dim astrDecryptionLevel(1 To 6) As String
    Dim strDecryptedString As String
    astrDecryptionLevel(5) = Mid(strData, 1, 2)
    astrDecryptionLevel(6) = Mid(strData, 3, 2)
    strDecryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrDecryptionLevel(5), strEncryptionKey((4 * lngDecryptPointer) + 3)))))
    astrDecryptionLevel(4) = PerformXOR(strDecryptedString, astrDecryptionLevel(6))
    strDecryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrDecryptionLevel(4), strEncryptionKey((4 * lngDecryptPointer) + 2)))))
    astrDecryptionLevel(3) = PerformXOR(strDecryptedString, astrDecryptionLevel(5))
    strDecryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrDecryptionLevel(3), strEncryptionKey((4 * lngDecryptPointer) + 1)))))
    astrDecryptionLevel(2) = PerformXOR(strDecryptedString, astrDecryptionLevel(4))
    strDecryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrDecryptionLevel(2), strEncryptionKey(4 * lngDecryptPointer)))))
    astrDecryptionLevel(1) = PerformXOR(strDecryptedString, astrDecryptionLevel(3))
    strDecryptedString = astrDecryptionLevel(1) & astrDecryptionLevel(2)
    PerformClipperDecryptionChunk = strDecryptedString
End Function

Private Function PerformClipperEncryption(ByVal strData As String) As String
    Dim bytChunk(1 To 4, 0 To 32) As String
    Dim lngCounter As Long
    Dim lngIterator As Long
    On Error Resume Next
    strData = StringToHex(strData)
    bytChunk(1, 0) = Mid(strData, 1, 4)
    bytChunk(2, 0) = Mid(strData, 5, 4)
    bytChunk(3, 0) = Mid(strData, 9, 4)
    bytChunk(4, 0) = Mid(strData, 13, 4)
    lngSeedLevel = 0
    lngCounter = 1
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel + 1) = PerformXOR(PerformXOR(PerformClipperEncryptionChunk(bytChunk(1, lngSeedLevel), astrEncryptionKey()), bytChunk(4, lngSeedLevel)), Hex(lngCounter))
        bytChunk(2, lngSeedLevel + 1) = PerformClipperEncryptionChunk(bytChunk(1, lngSeedLevel), astrEncryptionKey())
        bytChunk(3, lngSeedLevel + 1) = bytChunk(2, lngSeedLevel)
        bytChunk(4, lngSeedLevel + 1) = bytChunk(3, lngSeedLevel)
        lngCounter = lngCounter + 1
        lngSeedLevel = lngSeedLevel + 1
    Next lngIterator
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel + 1) = bytChunk(4, lngSeedLevel)
        bytChunk(2, lngSeedLevel + 1) = PerformClipperEncryptionChunk(bytChunk(1, lngSeedLevel), astrEncryptionKey())
        bytChunk(3, lngSeedLevel + 1) = PerformXOR(PerformXOR(bytChunk(1, lngSeedLevel), bytChunk(2, lngSeedLevel)), Hex(lngCounter))
        bytChunk(4, lngSeedLevel + 1) = bytChunk(3, lngSeedLevel)
        lngCounter = lngCounter + 1
        lngSeedLevel = lngSeedLevel + 1
    Next lngIterator
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel + 1) = PerformXOR(PerformXOR(PerformClipperEncryptionChunk(bytChunk(1, lngSeedLevel), astrEncryptionKey()), bytChunk(4, lngSeedLevel)), Hex(lngCounter))
        bytChunk(2, lngSeedLevel + 1) = PerformClipperEncryptionChunk(bytChunk(1, lngSeedLevel), astrEncryptionKey())
        bytChunk(3, lngSeedLevel + 1) = bytChunk(2, lngSeedLevel)
        bytChunk(4, lngSeedLevel + 1) = bytChunk(3, lngSeedLevel)
        lngCounter = lngCounter + 1
        lngSeedLevel = lngSeedLevel + 1
    Next lngIterator
    For lngIterator = 1 To 8
        bytChunk(1, lngSeedLevel + 1) = bytChunk(4, lngSeedLevel)
        bytChunk(2, lngSeedLevel + 1) = PerformClipperEncryptionChunk(bytChunk(1, lngSeedLevel), astrEncryptionKey())
        bytChunk(3, lngSeedLevel + 1) = PerformXOR(PerformXOR(bytChunk(1, lngSeedLevel), bytChunk(2, lngSeedLevel)), Hex(lngCounter))
        bytChunk(4, lngSeedLevel + 1) = bytChunk(3, lngSeedLevel)
        lngCounter = lngCounter + 1
        lngSeedLevel = lngSeedLevel + 1
    Next lngIterator
    PerformClipperEncryption = bytChunk(1, 32) & bytChunk(2, 32) & bytChunk(3, 32) & bytChunk(4, 32)
End Function

Private Function PerformClipperEncryptionChunk(ByVal strData As String, ByRef strEncryptionKey() As String) As String
    Dim astrEncryptionLevel(1 To 6) As String
    Dim strEncryptedString As String
    astrEncryptionLevel(1) = Mid(strData, 1, 2)
    astrEncryptionLevel(2) = Mid(strData, 3, 2)
    strEncryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrEncryptionLevel(2), strEncryptionKey(4 * lngSeedLevel)))))
    astrEncryptionLevel(3) = PerformXOR(strEncryptedString, astrEncryptionLevel(1))
    strEncryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrEncryptionLevel(3), strEncryptionKey((4 * lngSeedLevel) + 1)))))
    astrEncryptionLevel(4) = PerformXOR(strEncryptedString, astrEncryptionLevel(2))
    strEncryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrEncryptionLevel(4), strEncryptionKey((4 * lngSeedLevel) + 2)))))
    astrEncryptionLevel(5) = PerformXOR(strEncryptedString, astrEncryptionLevel(3))
    strEncryptedString = avarSeedValues(CByte(PerformTranslation(PerformXOR(astrEncryptionLevel(5), strEncryptionKey((4 * lngSeedLevel) + 3)))))
    astrEncryptionLevel(6) = PerformXOR(strEncryptedString, astrEncryptionLevel(4))
    strEncryptedString = astrEncryptionLevel(5) & astrEncryptionLevel(6)
    PerformClipperEncryptionChunk = strEncryptedString
End Function

Private Function PerformTranslation(ByVal strData As String) As Double
    Dim strTranslationString As String
    Dim strTranslationChunk As String
    Dim lngTranslationIterator As Long
    Dim lngHexConversion As Long
    Dim lngHexConversionIterator As Long
    Dim dblTranslation As Double
    Dim lngTranslationMarker As Long
    Dim lngTranslationModifier As Long
    Dim lngTranslationLayerModifier As Long
    strTranslationString = strData
    strTranslationString = Right$(strTranslationString, 8)
    strTranslationChunk = String$(8 - Len(strTranslationString), "0") + strTranslationString
    strTranslationString = ""
    For lngTranslationIterator = 1 To 8
        lngHexConversion = Val("&H" + Mid$(strTranslationChunk, lngTranslationIterator, 1))
        For lngHexConversionIterator = 3 To 0 Step -1
            If lngHexConversion And 2 ^ lngHexConversionIterator Then
                strTranslationString = strTranslationString + "1"
            Else
                strTranslationString = strTranslationString + "0"
            End If
        Next lngHexConversionIterator
    Next lngTranslationIterator
    dblTranslation = 0
    For lngTranslationIterator = Len(strTranslationString) To 1 Step -1
        If Mid(strTranslationString, lngTranslationIterator, 1) = "1" Then
            lngTranslationLayerModifier = 1
            lngTranslationMarker = (Len(strTranslationString) - lngTranslationIterator)
            lngTranslationModifier = 2
            Do While lngTranslationMarker > 0
                Do While (lngTranslationMarker / 2) = (lngTranslationMarker \ 2)
                    lngTranslationModifier = (lngTranslationModifier * lngTranslationModifier) Mod 255
                    lngTranslationMarker = lngTranslationMarker / 2
                Loop
                lngTranslationLayerModifier = (lngTranslationModifier * lngTranslationLayerModifier) Mod 255
                lngTranslationMarker = lngTranslationMarker - 1
            Loop
            dblTranslation = dblTranslation + lngTranslationLayerModifier
        End If
    Next lngTranslationIterator
    PerformTranslation = dblTranslation
End Function

Private Function PerformXOR(ByVal strData As String, ByVal strMask As String) As String
    Dim strXOR As String
    Dim lngXORIterator As Long
    Dim lngXORMarker As Long
    lngXORMarker = Len(strData) - Len(strMask)
    If lngXORMarker < 0 Then
        strXOR = Left$(strMask, Abs(lngXORMarker))
        strMask = Mid$(strMask, Abs(lngXORMarker) + 1)
    ElseIf lngXORMarker > 0 Then
        strXOR = Left$(strData, Abs(lngXORMarker))
        strData = Mid$(strData, lngXORMarker + 1)
    End If
    For lngXORIterator = 1 To Len(strData)
        strXOR = strXOR + Hex$(Val("&H" + Mid$(strData, lngXORIterator, 1)) Xor Val("&H" + Mid$(strMask, lngXORIterator, 1)))
    Next lngXORIterator
    PerformXOR = Right(strXOR, 8)
End Function

Private Sub SetKey(ByVal strEncryptionKey As String)
    Dim intEncryptionKeyIterator As Integer
    For intEncryptionKeyIterator = 0 To 131 Step 10
        If intEncryptionKeyIterator = 130 Then
            astrEncryptionKey(intEncryptionKeyIterator + 0) = Mid(strEncryptionKey, 1, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 1) = Mid(strEncryptionKey, 3, 2)
        Else
            astrEncryptionKey(intEncryptionKeyIterator + 0) = Mid(strEncryptionKey, 1, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 1) = Mid(strEncryptionKey, 3, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 2) = Mid(strEncryptionKey, 5, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 3) = Mid(strEncryptionKey, 7, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 4) = Mid(strEncryptionKey, 9, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 5) = Mid(strEncryptionKey, 11, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 6) = Mid(strEncryptionKey, 13, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 7) = Mid(strEncryptionKey, 15, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 8) = Mid(strEncryptionKey, 17, 2)
            astrEncryptionKey(intEncryptionKeyIterator + 9) = Mid(strEncryptionKey, 19, 2)
        End If
    Next
End Sub

Private Function BinaryToDouble(ByVal strData As String) As Double
    Dim dblOutput As Double
    Dim lngIterator As Long
    Do Until Len(strData) = 0
        dblOutput = dblOutput + IIf(Right$(strData, 1) = "1", (2 ^ lngIterator), 0)
        strData = Left$(strData, Len(strData) - 1)
        lngIterator = lngIterator + 1
    Loop
    BinaryToDouble = dblOutput
End Function

Private Function DoubleToBinary(ByVal dblData As Double) As String
    Dim strOutput As String
    Dim lngIterator As Long
    Do Until (2 ^ lngIterator) > dblData
        strOutput = IIf(((2 ^ lngIterator) And dblData) > 0, "1", "0") + strOutput
        lngIterator = lngIterator + 1
    Loop
    DoubleToBinary = strOutput
End Function

Private Function HexToString(ByVal strData As String) As String
    Dim strOutput As String
    Do Until Len(strData) < 2
        strOutput = strOutput + Chr$(CLng("&H" + Left$(strData, 2)))
        strData = Right$(strData, Len(strData) - 2)
    Loop
    HexToString = strOutput
End Function

Private Function StringToHex(ByVal strData As String) As String
    Dim strOutput As String
    Do Until Len(strData) = 0
        strOutput = strOutput + Right$(String$(2, "0") + Hex$(Asc(Left$(strData, 1))), 2)
        strData = Right$(strData, Len(strData) - 1)
    Loop
    StringToHex = strOutput
End Function

Private Function ByteToString(ByRef bytData() As Byte, ByVal lngDataLength As Long) As String
    Dim lngIterator As Long
    For lngIterator = LBound(bytData) To (LBound(bytData) + lngDataLength)
        ByteToString = ByteToString & Chr$(bytData(lngIterator))
    Next lngIterator
End Function

Project Homepage: