D2/W2 CDKey encode/decode

[Ringo]

Iv spent a fair bit of time over the last few days working on this, and with abit of help from Adron and l)ragon i was able to get my head round it
I havent tested it fully yet (only on some test keys) but it seems to work ok.
Im not one to be greedy, so here ya go:

Code Select Expand


Private Const KeyCodes As String = "246789BCDEFGHJKMNPRTVWXZ"
Public Function DecodeD2(ByVal CDKey As String) As String
    Dim tmpByte As Byte, i%, A&, B&, R&, Key$(15)
    For i = 1 To 16 'Fill array
        Key(i - 1) = UCase(Mid$(CDKey, i, 1))
    Next i
    Dim IntStr%(1), i2%
    R = 1 'base flag
    For i = 0 To 14 Step 2
        For i2 = 0 To 1
            IntStr(i2) = InStr(1, KeyCodes, Key(i + i2)) - 1
            If IntStr(i2) = -1 Then IntStr(i2) = &HFF
            If i2 = 0 Then A = IntStr(i2) * 3 Else A = IntStr(i2) + A * 8
        Next i2
        If A >= &H100 Then
            A = A - &H100
            tmpByte = tmpByte Or R 'set flag
        End If
        B = ((RShift(A, 4) And &HF) + &H30)
        A = ((A And &HF) + &H30)
        If B > &H39 Then B = B + &H7
        If A > &H39 Then A = A + &H7
        Key(i) = Chr$(B)
        Key(i + 1) = Chr$(A)
        R = R * 2 'upgrade flag
    Next i
    Erase IntStr()
    '//Valid Check
    R = 3
    For i = 0 To 15
        R = R + (GetNumValue(Key(i)) Xor (R * 2))
    Next i
    R = R And &HFF
    If Not R = tmpByte Then
        'Cdkey is shit
    End If
    '//Shuffling
    Dim tmpD As String * 1
    For i = 15 To 0 Step -1
        If i > 8 Then tmpByte = ((i - 9) And &HF) Else tmpByte = ((i + 7) And &HF)
        tmpD = Key(i)
        Key(i) = Key(tmpByte)
        Key(tmpByte) = tmpD
    Next i
    '//hash Values
    Dim HashKey&
    HashKey = &H13AC9741
    For i = 15 To 0 Step -1
        tmpByte = Asc(Key(i))
        If tmpByte <= &H37 Then
            Key(i) = Chr$(((HashKey And &HFF) And 7) Xor tmpByte)
            HashKey = RShift(HashKey, 3)
        ElseIf tmpByte < &H41 Then
            Key(i) = Chr$((i And 1) Xor tmpByte)
        Else
            Key(i) = Chr$(tmpByte)
        End If
    Next i
    '//return key
    DecodeD2 = Join(Key, vbNullString)
    Erase Key()
End Function


Public Function EncodeD2(ByVal CDKey As String) As String
    Dim tmpByte As Byte, i%, A&, B&, R&, Key$(15)
    For i = 1 To 16 'Fill array
        Key(i - 1) = UCase(Mid$(CDKey, i, 1))
    Next i
    '//unhashsing
    Dim HashKey&
    HashKey = &H13AC9741
    For i = 15 To 0 Step -1
        tmpByte = Asc(Key(i))
        If tmpByte <= &H37 Then
            Key(i) = Chr$(((HashKey And &HFF) And 7) Xor tmpByte)
            HashKey = RShift(HashKey, 3)
        ElseIf Val(tmpByte) < &H41 Then
            Key(i) = Chr$((i And 1) Xor tmpByte)
        Else
            Key(i) = Chr$(tmpByte)
        End If
    Next i
    '//unshuffling
    Dim tmpD As String * 1
    For i = 0 To 15
        If i > 8 Then tmpByte = ((i - 9) And &HF) Else tmpByte = ((i + 7) And &HF)
        tmpD = Key(i)
        Key(i) = Key(tmpByte)
        Key(tmpByte) = tmpD
    Next i
    '//flag extract
    R = 3
    For i = 0 To 15
        R = R + (GetNumValue(Key(i)) Xor (R * 2))
    Next i
    R = R And &HFF
    tmpByte = &H80 'seed the flag
    '//convert hex to KeyCodes
    For i = 14 To 0 Step -2
        A = GetNumValue(Key(i))
        B = GetNumValue(Key(i + 1))
        A = CLng("&H" & Hex(A) & Hex(B))
        If R And tmpByte Then A = A + &H100
        Call KeyCodeOffSets(A, B)
        Key(i) = Mid(KeyCodes, B + 1, 1)
        Key(i + 1) = Mid(KeyCodes, A + 1, 1)
        tmpByte = tmpByte / 2 'downgrade flag
    Next i
    '//return encoded key
    EncodeD2 = Join(Key, vbNullString)
    Erase Key()
End Function

Private Sub KeyCodeOffSets(Bit1&, Bit2&)
    Bit2 = 0
    While Bit1 >= &H18
        Bit2 = Bit2 + 1
        Bit1 = Bit1 - &H18
    Wend
End Sub

Public Function RShift(ByVal pnValue As Long, ByVal pnShift As Long) As Double
    On Error Resume Next
    RShift = CDbl(pnValue \ (2 ^ pnShift))
End Function

Public Function GetNumValue(ByVal c As String) As Long
    On Error Resume Next
    c = UCase(c)
    If IsNumeric(c) Then
        GetNumValue = Asc(c) - &H30
    Else
        GetNumValue = Asc(c) - &H37
    End If
End Function