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

Dim di(15) As String 'Hex

Dim table(255) As Long
Dim Key(255) As Long
Dim keyWindow(1023) As Long
Dim I As Long
Dim J As Long

Public Sub setKey(s As String)
On Error Resume Next

Dim s1 As String
Dim s2 As String
Dim I As Long
Dim i2 As Long
Dim l As Long
Dim J As Long
Dim j2 As String
    'Initialize PRIVATE KEY
    Call Initialize

    'DECODE KEY
    If Len(s) Mod 2 = 1 Then
        s = Left(s, Len(s) - 1)
    End If
    
    s1 = Mid(s, 1, Len(s) / 2)
    s2 = Mid(s, Len(s) / 2 + 1, Len(s) / 2)
    l = 0
    For I = 1 To Len(s1)
        j2 = Mid(s2, I, 1)
        i2 = 1
        Do Until Mid(s1, i2, 1) = j2
            If i2 > Len(s1) Then
                i2 = -1
                Exit Do
            End If
            i2 = i2 + 1
        Loop
        J = i2 - 1
        
        If J Mod 2 = 0 Then
            J = J * 2
        End If
        If (I - 1) Mod 3 = 0 Then
            J = J * 3
        End If
        If J < 0 Then
            J = Len(s1) Mod 2
        End If
        l = l + J
        l = l Xor LShift(J, ((I - 1) Mod 3) * 8)
    Next
    
    I = 0
    J = 0

    'Initialize PUBLIC KEY
    Call Init(l)
    
    I = 0
    J = 0
    Call preMixTable(FrmSettings.txt_preMixTable.Text, FrmSettings.txt_preMixTable_len.Text)
End Sub

Public Function encipher(ByVal Data As String) As String
On Error Resume Next

Dim cipher As String
Dim t As Long
Dim k As Long
Dim a As Long
Dim c As Long
    t = 0
    k = 0
    For a = 1 To Len(Data)
    
        I = (I + 1) Mod 256
        J = (J + table(I)) Mod 256
        t = table(I)
        table(I) = table(J)
        table(J) = t
        k = table((table(I) + table(J)) Mod 256)
        
        c = Asc(Mid(Data, a, 1)) Xor k
        
        If c <= 0 Then
            cipher = cipher & "00"
        Else
            cipher = cipher & di(RShift(c, 4) And &HF)
            cipher = cipher & di(c And &HF)
        End If
    Next
    
    encipher = cipher
End Function

Public Function decipher(ByVal Data As String) As String
On Error Resume Next

Dim cipher As String
Dim t As Long
Dim k As Long
Dim a As Long
    t = 0
    k = 0
    a = 1
    Do
        I = (I + 1) Mod 256
        J = (J + table(I)) Mod 256
        t = table(I)
        table(I) = table(J)
        table(J) = t
        k = table((table(I) + table(J)) Mod 256)
        
        t = HexToDec(Mid(Data, a, a + 2))
        cipher = cipher & Chr(t Xor k)
        a = a + 2
    Loop Until a >= Len(Data)
    
    decipher = cipher
End Function

Private Function HexToDec(ByVal Data As String) As Long
On Error Resume Next

Dim tempData As String
Dim Y As Long
Dim tStr As String
Dim tHex As String
    tempData = Data
    For Y = (1) To Len(Data) Step 2
        tStr = Mid(Data, Y, 2)
        tHex = tHex & Chr("&h" & tStr)
    Next Y

    HexToDec = Asc(tHex)
End Function

Private Function Init(ByVal sKey As String) As Boolean
On Error Resume Next

Dim keyValue As Long
Dim keyLength As Long
Dim keyOffset As Long
Dim keySkip As Long
Dim prevKey As Long
Dim w() As Long
Dim b As Long
Dim a As Long
Dim t As Long
Dim m As Long
Dim tOwn, tGiven As Long

    keyValue = Int(sKey)
    keyLength = (keyValue And 248) / 8
    
    If keyLength < 20 Then
        keyLength = keyLength + 20
    End If
    keyOffset = keyValue Mod 1024
    
    prevKey = 0
    m = 5
    
    ReDim w(keyLength - 1)
    tGiven = keyValue
    
    For I = 0 To keyLength - 1
        tOwn = keyWindow(Math.Abs(keyOffset + I) Mod (1024))
        w(I) = Math.Abs(tGiven Xor tOwn)
        If I = 31 Then
            tGiven = keyValue
        Else
            tGiven = Int(tGiven / 2)
        End If
    Next
    
    For a = 0 To 255
        Key(a) = w(a Mod (UBound(w) + 1))
        table(a) = a
    Next

    b = 0
    t = 0
    For a = 0 To 255
        b = (b + table(a) + Key(a)) Mod 256
        t = table(a)
        table(a) = table(b)
        table(b) = t
    Next
    
    I = 0
    Init = True
End Function

Private Sub preMixTable(Data As String, Count As Long)
On Error Resume Next

Dim I As Long
Dim TEMP As String
  
  For I = 1 To Count
    TEMP = encipher(Data)
  Next
End Sub

Private Sub Initialize()
On Error Resume Next

    For I = 0 To 15
        Select Case I
        Case 10
            di(I) = "A"
        Case 11
            di(I) = "B"
        Case 12
            di(I) = "C"
        Case 13
            di(I) = "D"
        Case 14
            di(I) = "E"
        Case 15
            di(I) = "F"
        Case Else
            di(I) = I
        End Select
    Next
    
    Dim X As Long
    For X = 0 To 1023
    keyWindow(X) = GetINISetting(App.Path & "\Encryption.ini", "Initialize", "keyWindow_" & X, "")
    Next X
    
    I = 0
    J = 0
End Sub

Private Function Shift(ByVal lValue As Long, ByVal lNumberOfBitsToShift As Long, ByVal lDirectionToShift As Long) As Long
Const ksCallname As String = "Shift"
Dim LShift As Long
On Error GoTo Procedure_Error

    If lDirectionToShift Then
        LShift = lValue * (2 ^ lNumberOfBitsToShift)
    Else
        LShift = lValue \ (2 ^ lNumberOfBitsToShift)
    End If
    
Procedure_Exit:
    Shift = LShift
    Exit Function
    
Procedure_Error:
    Err.Raise Err.Number, ksCallname, Err.Description, Err.HelpFile, Err.HelpContext
    Resume Procedure_Exit
End Function

Private Function LShift(ByVal lValue As Long, ByVal lNumberOfBitsToShift As Long) As Long
Const ksCallname As String = "LShift"
On Error GoTo Procedure_Error

    LShift = Shift(lValue, lNumberOfBitsToShift, -1)
    
Procedure_Exit:
    Exit Function
    
Procedure_Error:
    Err.Raise Err.Number, ksCallname, Err.Description, Err.HelpFile, Err.HelpContext
    Resume Procedure_Exit
End Function

Private Function RShift(ByVal lValue As Long, ByVal lNumberOfBitsToShift As Long) As Long
Const ksCallname As String = "LShift"
On Error GoTo Procedure_Error

    RShift = Shift(lValue, lNumberOfBitsToShift, 0)
    
Procedure_Exit:
    Exit Function
    
Procedure_Error:
    Err.Raise Err.Number, ksCallname, Err.Description, Err.HelpFile, Err.HelpContext
    Resume Procedure_Exit
End Function

