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 (http://forum.valhallalegends.com/index.php?topic=13989.msg142839#msg142839) 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:
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