Encryption Module

joeroot · 07-10-2014, 02:27 AM

Crypter used in writing the best encoding mAlArdAn one example, you took many hours did you 35/0 bi cryptor udla after you've b crypt Did you have looked results 35/8 was 35/10 became so your all your efforts wasted Encryption Modulein this case strongly recommend only using I bi algo is the knowing use for those new to If the request can I make anat, the best use ...

PHP Code:
cOption 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 As String strALPKeyMask
    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 = 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 As String strALPKeyMask
    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)
            DM = 99999999 Then lngEncryptionCount
                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", "400", "43", "27", "D2", "07", "D4", "THE", "C7 "," 67 "," 18 "," 89 "," CB "," 30 "," 1F ", _
    "8D", "G6", "8f", "AA", "C8", "74", "600", "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", "TO", "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
    Perform Translation = 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 

milamila · 03-31-2019, 06:31 PM

does any one knows to how find out the encryption key if we now encrypted data and the result by encripted by cliper

bumbuls6 · 11-26-2023, 04:46 PM

The only thing VB has going for it is the basic syntax if you grew on it so it has a sorta nostalgic value ("muh goto").

Quote:

alx08 · 02-23-2024, 01:29 PM

(07-10-2014, 02:27 AM)joeroot Wrote: Crypter used in writing the best encoding mAlArdAn one example, you took many hours did you 35/0 bi cryptor udla after you've b crypt Did you have looked results 35/8 was 35/10 became so your all your efforts wasted Encryption Modulein this case strongly recommend only using I bi algo is the knowing use for those new to If the request can I make anat, the best use ...

PHP Code:
cOption 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 As String strALPKeyMask 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 = 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 As String strALPKeyMask 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) DM = 99999999 Then lngEncryptionCount 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", "400", "43", "27", "D2", "07", "D4", "THE", "C7 "," 67 "," 18 "," 89 "," CB "," 30 "," 1F ", _ "8D", "G6", "8f", "AA", "C8", "74", "600", "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", "TO", "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 Perform Translation = 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

damn thats a fuck ton of code

werreo · 06-05-2024, 03:40 AM

Nice thanks for sharing your script

Encryption Module
Author Message