VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDecodeCDKey"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : clsDecodeCDKey
' Date      : 6/23/2004
' Author    :
' Purpose   :
'---------------------------------------------------------------------------------------

Option Explicit

Public Function DecodeCDKey(ByVal sCDKey As String, ByRef dProductId As Long, ByRef dValue1 As Long, ByRef dValue2 As Long) As Boolean 'Before attempting to decode the CD-Key, make sure that the CD-Key is all in uppercase format and the dashes have been removed
Select Case Len(sCDKey)
    Case 13 'StarCraft, StarCraft: Brood War
        DecodeCDKey = DecodeStarcraftKey(sCDKey)
        dValue1 = CLng(Val(Mid$(sCDKey, 3, 7)))
        dValue2 = CLng(Val(Mid$(sCDKey, 10, 3)))
    Case 16 'Diablo II, Diablo II: Lord of Destruction, Warcraft II: Battle.net Edition
        DecodeCDKey = DecodeD2Key(sCDKey)
        dValue1 = CLng(Val("&H" & Mid$(sCDKey, 3, 6)))
        dValue2 = CLng(Val("&H" & Mid$(sCDKey, 9)))
    Case 26 'Warcraft III: Reign of Chaos, Warcraft III: The Frozen Throne
    
    Case Else
        DecodeCDKey = False
        Exit Function
End Select
dProductId = CLng(Val("&H" & Left$(sCDKey, 2)))
End Function
Private Function DecodeD2Key(Key As String) As Boolean
Dim clsFunctions As New clsFunctions

Dim r As Double
Dim n As Double
Dim n2 As Double
Dim v As Double
Dim v2 As Double
Dim keyvalue As Double
Dim c1 As Byte
Dim c2 As Byte
Dim C As Byte
Dim I As Long
Dim aryKey(0 To 15) As String
Dim codevalues As String
    
codevalues = "246789BCDEFGHJKMNPRTVWXZ"
r = 1
keyvalue = 0
For I = 1 To 16
    aryKey(I - 1) = Mid$(Key, I, 1)
Next I
For I = 0 To 15 Step 2
    c1 = InStr(1, codevalues, aryKey(I)) - 1
    If c1 = -1 Then c1 = &HFF
    n = c1 * 3
    c2 = InStr(1, codevalues, aryKey(I + 1)) - 1
    If c2 = -1 Then c2 = &HFF
    n = c2 + n * 8
    If n >= &H100 Then
        n = n - &H100
        keyvalue = keyvalue Or r
    End If
    n2 = n
    n2 = clsFunctions.RShift(n2, 4)
    aryKey(I) = clsFunctions.GetHexValue(n2)
    aryKey(I + 1) = clsFunctions.GetHexValue(n)
    r = clsFunctions.LShift(r, 1)
    
Cont:
    Next I
    v = 3
    For I = 0 To 15
        C = clsFunctions.GetNumValue(aryKey(I))
        n = Val(C)
        n2 = v * 2
        n = n Xor n2
        v = v + n
    Next I
    v = v And &HFF
    If v = keyvalue Then
        DecodeD2Key = True
    Else
        DecodeD2Key = False
        Exit Function
    End If
    For I = 15 To 0 Step -1
        C = Asc(aryKey(I))
        If I > 8 Then
            n = I - 9
        Else
            n = &HF - (8 - I)
        End If
        n = n And &HF
        c2 = Asc(aryKey(n))
        aryKey(I) = Chr$(c2)
        aryKey(n) = Chr$(C)
    Next I
    v2 = &H13AC9741
    For I = 15 To 0 Step -1
        C = Asc(UCase(aryKey(I)))
        aryKey(I) = Chr$(C)
        If Val(C) <= 55 Then
            v = v2
            c2 = v And &HF
            c2 = c2 And 7
            c2 = c2 Xor C
            v = clsFunctions.RShift(v, 3)
            aryKey(I) = Chr$(c2)
            v2 = v
        ElseIf Val(C) < 65 Then
            c2 = CByte(I)
            c2 = c2 And 1
            c2 = c2 Xor C
            aryKey(I) = Chr$(c2)
        End If
    Next I
    Key = Join(aryKey(), vbNullString)
    Erase aryKey()
End Function
Private Function DecodeStarcraftKey(sKey As String) As Boolean
Dim clsFunctions As New clsFunctions

Dim r As Double
Dim n As Double
Dim n2 As Double
Dim v As Double
Dim v2 As Double
Dim keyvalue As Double
Dim c1 As Byte
Dim c2 As Byte
Dim C As Byte
Dim I As Long
Dim aryKey(0 To 12) As String
    
For I = 1 To 13
    aryKey(I - 1) = Mid$(sKey, I, 1)
Next I
v = 3
For I = 0 To 11
    C = aryKey(I)
    n = Val(C)
    n2 = v * 2
    n = n Xor n2
    v = v + n
Next I
v = v Mod 10
If Hex(v) = aryKey(12) Then
    DecodeStarcraftKey = True
Else
    DecodeStarcraftKey = False
    Exit Function
End If
v = 194
For I = 11 To 0 Step -1
    If v < 7 Then GoTo Continue
    C = aryKey(I)
    n = CInt(v / 12)
    n2 = v Mod 12
    v = v - 17
    c2 = aryKey(n2)
    aryKey(I) = c2
    aryKey(n2) = C
Next I
Continue:
    v2 = &H13AC9741
    For I = 11 To 0 Step -1
        C = UCase$(aryKey(I))
        aryKey(I) = C
        If Asc(C) <= 55 Then
            v = v2
            c2 = v And &HFF
            c2 = c2 And 7
            c2 = c2 Xor C
            v = clsFunctions.RShift(CLng(v), 3)
            aryKey(I) = c2
            v2 = v
        ElseIf Asc(C) < 65 Then
            c2 = CByte(I)
            c2 = c2 And 1
            c2 = c2 Xor C
            aryKey(I) = c2
        End If
    Next I
    sKey = Join(aryKey(), vbNullString)
    Erase aryKey()
End Function

'War3:
'Private Function DecodeW3Key(sKey As String)
'Dim aryKey(0 To 25) As String

'End Function
'Private Sub TableLookup(Key() As Byte, buf() As Byte)
'Dim ebx As Long, edx As Long
'Dim eax As Byte
'Dim I As Integer

'edx = &H21
'For I = 0 To 25 Step 1
'    ebx = (edx + &H7B5) Mod 26
'    edx = (edx + &H7B5) Mod 26
'    eax = war3_codeval(Key(I))
'    buf(ebx) = (eax / 5)
'    buf(edx) = (eax Mod 5)
'Next I
'End Sub

'Private Sub DecodeKeyTablePass1(KeyTable As Long)
'Dim ebx As Integer, ecx As Integer, edx As Integer, esi As Integer, ebp As Integer
'Dim var_C As Integer, var_8 As Integer, var_4 As Integer
'Dim I As Integer

'ebp = &H1D
'var_8 = ebp

'End Sub

'for(int i = 0x1D0; i >= 0; i -= 0x10)
'{
'esi = (ebp & 0x07) > 0x03;
'var_4 = ecx;

'edx = KeyTable[0x03 - ecx];
'ebx = 0x0F > (esi & 0xFF);

'if(i < 0x1d0)
'{
'for(int j = 0x1D; j > ebp; j--)
'{
'ecx = (j & 0x07) > 0x03)];
'ebp = (ebp & (0x0F > ecx;
'ebp ^= TranslateTable[var_C + i];
'var_C = TranslateTable[ebp+i];
'ebp = var_8;
'}
'}

'if((var_8 = ebp - 1) >= 0)
'{
'for(int j = ebp - 1; j >= 0; j--)
'{
'ecx = (j & 0x07) > 0x03)];
'ebp = (ebp & (0x0F > ecx;
'ebx = TranslateTable[var_C + i];
'ebp = (ebp & 0xFF) ^ ebx;
'var_C = TranslateTable[ebp+i];
'}
'}

'ebx = (TranslateTable[var_C + i] & 0x0F) > 5);
'ebp = *(DWORD *)((char *)(vars+3) - ((esi >> 5) > ecx;
'KeyTable [edx] = ((ebp & 1) = 120)
'esi -= 120;
'}
'}

'Private Sub DecodeKeyTablePass2(KeyTable() As Long)
'Dim eax As Long, edx As Long, ecx As Long, edi As Long, esi As Long, ebp As Long
'Dim vars(4) As Long

'Dim clsFunctions As New clsFunctions

'vars(0) = KeyTable(0)
'vars(1) = KeyTable(1)
'vars(2) = KeyTable(2)
'vars(3) = KeyTable(3)
'esi = 0
'While edi < 120
'    eax = edi And &H1F
'    ecx = esi And &H1F
'    edx = 3 - clsFunctions.RShift(edi, 5)
'    'ebp = *(DWORD *)((char *)(vars+3) - ((esi >> 5) > ecx;
'    KeyTable(edx) = ((ebp And 1) = 120)
'    edi = edi + 1
'    esi = esi - 120
'Wend
'End Sub


