VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsRndCrypt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'
' RndCrypt Level 2
'
' Made by Michael Ciurescu (CVMichael from vbforums.com)
'
' Date Created: November 27, 2007
'

Public Enum e_Enc_InOutType
    eBinaryString = 1
    eHex = 2
    eBase64 = 3
End Enum

Private Base64EncodeTable(0 To 63) As Byte
Private Base64DecodeTable(0 To 255) As Byte
Private HexDecodeTable(0 To 255) As Byte
Private HexEncodeTable(0 To 255) As String * 2

Private Sub Class_Initialize()
    Dim K As Long
    
    For K = 0 To 25
        Base64EncodeTable(K) = K + 65 ' K + Asc("A")
    Next K
    
    For K = 0 To 25
        Base64EncodeTable(K + 26) = K + 97 ' K + Asc("a")
    Next K
    
    For K = 0 To 9
        Base64EncodeTable(K + 52) = K + 48 ' K + Asc("0")
    Next K
    
    Base64EncodeTable(62) = 43 ' Asc("+")
    Base64EncodeTable(63) = 47 ' Asc("/")
    
    For K = 0 To 255
        Base64DecodeTable(K) = 255
    Next K
    
    For K = 0 To 25
        Base64DecodeTable(K + 65) = K
    Next K
    
    For K = 26 To 51
        Base64DecodeTable(K + 71) = K
    Next K
    
    For K = 52 To 61
        Base64DecodeTable(K - 4) = K
    Next K
    
    Base64DecodeTable(43) = 62
    Base64DecodeTable(47) = 63
    
    For K = 48 To 57
        HexDecodeTable(K) = K - 48 ' K - Asc("0")
    Next K
    
    For K = 65 To 70
        HexDecodeTable(K) = K - 55 ' K - Asc("A") - 10
    Next K
    
    For K = 0 To 255
        HexEncodeTable(K) = Right$("0" & Hex$(K), 2)
    Next K
End Sub

Public Function RndCrypt(ByVal Str As String, ByVal Password As String) As String
'
'    Made by Michael Ciurescu (CVMichael from vbforums.com)
'    Original thread: [url]http://www.vbforums.com/showthread.php?t=231798[/url]
'
    Dim SK As Long, K As Long
    
'    init randomizer for password
    Rnd -1
    Randomize Len(Password)
'    (((K Mod 256) Xor Asc(Mid$(Password, K, 1))) Xor Fix(256 * Rnd)) -> makes sure that a
'    password like "pass12" does NOT give the same result as the password "sspa12" or "12pass"
'    or "1pass2" etc. (or any combination of the same letters)
    
    For K = 1 To Len(Password)
        SK = SK + (((K Mod 256) Xor Asc(Mid$(Password, K, 1))) Xor Fix(256 * Rnd))
    Next K
    
'    init randomizer for encryption/decryption
    Rnd -1
    Randomize SK
    
'    encrypt/decrypt every character using the randomizer
    For K = 1 To Len(Str)
        Mid$(Str, K, 1) = Chr(Fix(256 * Rnd) Xor Asc(Mid$(Str, K, 1)))
    Next K
    
    RndCrypt = Str
End Function

Public Function RndCryptB(ByRef tmpToEncrypt As String, ByVal tmpPassword As String) As String
'    Original function/idea by Michael Ciurescu (CVMichael from vbforums.com)
'    This function by frozen on vbforums.com
'    Original thread: [url]http://www.vbforums.com/showthread.php?t=231798[/url]
    
    Dim tmpToEncryptB() As Byte
    Dim tmpPasswordB() As Byte
    Dim tmpIndex As Long
    Dim tmpSeed As Long
    
    Rnd -1
    Randomize Len(tmpPassword)
    
    tmpPasswordB = StrConv(tmpPassword, vbFromUnicode)
    
    For tmpIndex = 0 To UBound(tmpPasswordB) - 1
        tmpSeed = tmpSeed + (((tmpIndex Mod 256) Xor tmpPasswordB(tmpIndex)) Xor Fix(256 * Rnd))
    Next
    
    Rnd -1
    Randomize tmpSeed
    
    tmpToEncryptB = StrConv(tmpToEncrypt, vbFromUnicode)
    
    For tmpIndex = 0 To UBound(tmpToEncryptB) - 1
        tmpToEncryptB(tmpIndex) = Fix(256 * Rnd) Xor tmpToEncryptB(tmpIndex)
    Next tmpIndex
    
    RndCryptB = StrConv(tmpToEncryptB, vbUnicode)
End Function

Public Function RndCryptLevel2(strValue As String, strPassword As String, Optional bSeedPasses As Byte = 3, Optional bDataPasses As Byte = 2, Optional InputType As e_Enc_InOutType = eBinaryString, Optional OutputType As e_Enc_InOutType = eBinaryString, Optional RemoveInvalidChars As Boolean = True) As String
    Dim PassByte() As Byte, LNPassByte1 As Long
    Dim InHex() As Byte
    Dim ValByte() As Byte, LNValByte As Long
    Dim OutByte() As Byte, LNOutByte As Long
    Dim lngSeed As Long, btSeed As Byte, N As Long
    Dim K As Long, Q As Long
    
    If Len(strValue) = 0 Then Exit Function
    If Len(strPassword) = 0 Then strPassword = Chr(0)
    If bSeedPasses = 0 Then bSeedPasses = 1
    
    Select Case InputType
    Case eBinaryString
        ValByte = StrConv(strValue, vbFromUnicode)
    Case eHex
        If RemoveInvalidChars Then
            For K = 0 To 255
                If Not (Chr(K) Like "[0-9A-F]") Then
                    If InStr(1, strValue, Chr(K)) > 0 Then strValue = Replace$(strValue, Chr(K), "")
                End If
            Next K
        End If
        
        InHex = StrConv(strValue, vbFromUnicode)
        ReDim ValByte((Len(strValue) \ 2) - 1)
        
        For K = 0 To UBound(ValByte)
            ValByte(K) = HexDecodeTable(InHex(K * 2)) * 16 Or HexDecodeTable(InHex(K * 2 + 1))
        Next K
        
        Erase InHex
    Case eBase64
        ValByte = Base64DecodingB(strValue, RemoveInvalidChars)
    End Select
    
    PassByte = StrConv(strPassword, vbFromUnicode)
    
    LNValByte = UBound(ValByte)
    ReDim OutByte(LNValByte)
    LNOutByte = UBound(OutByte)
    LNPassByte1 = UBound(PassByte) + 1
    
    N = (LNValByte + 1) + LNPassByte1 * bSeedPasses
    Rnd -1
    Randomize N
    
    For K = 1 To N
        N = PassByte(K Mod LNPassByte1) ^ (1 + 2.7526486955 * Rnd)
        lngSeed = ((lngSeed And &H3FFFFFFF) + N) Or CLng(1000 * Rnd)
    Next K
    
    Rnd -1
    Randomize lngSeed
    
    For K = 0 To LNValByte
        btSeed = lngSeed And &HFF
        
        OutByte(K) = (CByte(255.49 * Rnd) Xor ValByte(K)) Xor btSeed
        
        N = (255 * Rnd) ^ (1 + 2.7526486955 * Rnd)
        lngSeed = (lngSeed \ 2) + N
    Next K
    
    For Q = 1 To bDataPasses - 1
        For K = 0 To LNValByte
            btSeed = lngSeed And &HFF
            
            OutByte(K) = (CByte(255.49 * Rnd) Xor OutByte(K)) Xor btSeed
            
            N = (255 * Rnd) ^ (1 + 2.7526486955 * Rnd)
            lngSeed = (lngSeed \ 2) + N
        Next K
    Next Q
    
    Select Case OutputType
    Case eBinaryString
        RndCryptLevel2 = StrConv(OutByte, vbUnicode)
    Case eHex
        RndCryptLevel2 = String((LNOutByte + 1) * 2, "-")
        
        For K = 0 To LNOutByte
            Mid$(RndCryptLevel2, 1 + K * 2, 2) = HexEncodeTable(OutByte(K))
        Next K
    Case eBase64
        RndCryptLevel2 = Base64EncodingB(OutByte)
    End Select
End Function

Public Function Base64EncodingB(StrIn() As Byte) As String
    Dim K As Long, OutStr() As Byte, Lng As Long
    Dim LenStrIn As Long
    
    If UBound(StrIn) = -1 Then Exit Function
    LenStrIn = UBound(StrIn) + 1
    
    If (LenStrIn Mod 3) = 0 Then
        ReDim OutStr((LenStrIn \ 3) * 4 - 1)
    Else
        ReDim OutStr(((LenStrIn \ 3) + 1) * 4 - 1)
    End If
    
    For K = 0 To LenStrIn \ 3 - 1
        Lng = StrIn(K * 3 + 2) Or (StrIn(K * 3 + 1) * &H100&) Or (StrIn(K * 3) * &H10000)
        
        OutStr(K * 4 + 0) = Base64EncodeTable((Lng And &HFC0000) \ &H40000)
        OutStr(K * 4 + 1) = Base64EncodeTable((Lng And &H3F000) \ &H1000&)
        OutStr(K * 4 + 2) = Base64EncodeTable((Lng And &HFC0&) \ &H40&)
        OutStr(K * 4 + 3) = Base64EncodeTable(Lng And &H3F&)
    Next K
    
    If (LenStrIn Mod 3) = 1 Then
        Lng = StrIn(UBound(StrIn)) * &H10000
        
        OutStr(UBound(OutStr) - 3) = Base64EncodeTable((Lng And &HFC0000) \ &H40000)
        OutStr(UBound(OutStr) - 2) = Base64EncodeTable((Lng And &H3F000) \ &H1000&)
        OutStr(UBound(OutStr) - 1) = Asc("=")
        OutStr(UBound(OutStr) - 0) = Asc("=")
    ElseIf (LenStrIn Mod 3) = 2 Then
        Lng = (StrIn(UBound(StrIn)) * &H100&) Or (StrIn(UBound(StrIn) - 1) * &H10000)
        
        OutStr(UBound(OutStr) - 3) = Base64EncodeTable((Lng And &HFC0000) \ &H40000)
        OutStr(UBound(OutStr) - 2) = Base64EncodeTable((Lng And &H3F000) \ &H1000&)
        OutStr(UBound(OutStr) - 1) = Base64EncodeTable((Lng And &HFC0&) \ &H40&)
        OutStr(UBound(OutStr) - 0) = Asc("=")
    End If
    
    Base64EncodingB = StrConv(OutStr, vbUnicode)
End Function

Public Function Base64DecodingB(ByVal StrToDecode As String, Optional RemoveInvalidChars As Boolean = True) As Byte()
    Dim OutStr() As Byte, StrIn() As Byte
    Dim K As Long, Lng As Long
    Dim K3 As Long, K4 As Long
    
    If StrToDecode = "" Then Exit Function
    
    StrToDecode = Trim(StrToDecode)
    
    If RemoveInvalidChars Then
        For K = 0 To 255
            If Not (Chr(K) Like "[A-Za-z0-9+/=]") Then
                If InStr(1, StrToDecode, Chr(K)) > 0 Then StrToDecode = Replace$(StrToDecode, Chr(K), "")
            End If
        Next K
    End If
    
    StrIn() = StrConv(StrToDecode, vbFromUnicode)
    
    If StrIn(UBound(StrIn) - 1) = 61 Then
        ReDim OutStr(0 To ((Len(StrToDecode) \ 4) * 3 - 3))
    ElseIf StrIn(UBound(StrIn)) = 61 Then
        ReDim OutStr(0 To ((Len(StrToDecode) \ 4) * 3 - 2))
    Else
        ReDim OutStr(0 To ((Len(StrToDecode) \ 4) * 3 - 1))
    End If
    
    For K = 0 To Len(StrToDecode) \ 4 - 2
        K4 = K * 4
        Lng = Base64DecodeTable(StrIn(K4 + 3))
        Lng = Lng Or (Base64DecodeTable(StrIn(K4 + 2)) * &H40&)
        Lng = Lng Or (Base64DecodeTable(StrIn(K4 + 1)) * &H1000&)
        Lng = Lng Or (Base64DecodeTable(StrIn(K4 + 0)) * &H40000)
        
        K3 = K * 3
        OutStr(K3 + 0) = (Lng And &HFF0000) \ &H10000
        OutStr(K3 + 1) = (Lng And &HFF00&) \ &H100&
        OutStr(K3 + 2) = Lng And &HFF&
    Next K
    
    Lng = 0
    K4 = K * 4
    If Base64DecodeTable(StrIn(K4 + 3)) <> 255 Then Lng = Base64DecodeTable(StrIn(K4 + 3))
    If Base64DecodeTable(StrIn(K4 + 2)) <> 255 Then Lng = Lng Or (Base64DecodeTable(StrIn(K4 + 2)) * &H40&)
    If Base64DecodeTable(StrIn(K4 + 1)) <> 255 Then Lng = Lng Or (Base64DecodeTable(StrIn(K4 + 1)) * &H1000&)
    If Base64DecodeTable(StrIn(K4 + 0)) <> 255 Then Lng = Lng Or (Base64DecodeTable(StrIn(K4 + 0)) * &H40000)
    
    K3 = K * 3
    OutStr(K3 + 0) = (Lng And &HFF0000) \ &H10000
    If UBound(OutStr) >= (K3 + 1) Then OutStr(K3 + 1) = (Lng And &HFF00&) \ &H100&
    If UBound(OutStr) >= (K3 + 2) Then OutStr(K3 + 2) = Lng And &HFF&
    
    Base64DecodingB = OutStr
End Function