I didnt wrote this, is from a post of Andy at vl forums.
Quote from: andy
Make a clsWarden file, with the following (trimmed and updated) code:
Code:
Option Explicit
Private Declare Function StandardSHA Lib "RSHA.dll" (sVal As String) As String
Private Position As Long
Private RandomData() As Byte
Private RandomSource1() As Byte
Private RandomSource2() As Byte
Private Function RShift(ByVal pnValue As Double, ByVal pnShift As Long) As Long
Dim Shft As String
Shft = Str$(pnValue / (2 ^ pnShift))
If InStr(Shft, ".") > 0 Then
RShift = CLng(Left$(Shft, InStr(Shft, ".") - 1))
Else
RShift = CLng(Shft)
End If
End Function
Public Sub Initialize(Seed As String)
Dim Length1 As Long
Dim Length2 As Long
Dim Seed1() As Byte
Dim Seed2() As Byte
Dim I As Long
Length1 = RShift(Len(Seed), 1)
Length2 = Len(Seed) - Length1
ReDim Seed1(Length1 - 1)
ReDim Seed2(Length2 - 1)
StrToByteArray Mid$(Seed, 1, Length1), Seed1
StrToByteArray Mid$(Seed, Length1 + 1, Length2), Seed2
ReDim RandomData(&H13) As Byte
StrToByteArray StandardSHA(ByteArrayToStr(Seed1)), RandomSource1
StrToByteArray StandardSHA(ByteArrayToStr(Seed2)), RandomSource2
Update
Position = 0
End Sub
Private Sub Update()
StrToByteArray StandardSHA(ByteArrayToStr(RandomSource1) & ByteArrayToStr(RandomData) & ByteArrayToStr(RandomSource2)), RandomData
End Sub
Private Function GetByte() As Byte
GetByte = RandomData(Position)
Position = Position + 1
If Position >= &H14 Then
Position = 0
Update
End If
End Function
Public Function GetBytes(ByVal bytes As Long) As String
Dim I As Integer
Dim Buffer() As Byte
ReDim Buffer(bytes) As Byte
For I = 0 To bytes
Buffer(I) = GetByte
Next I
GetBytes = ByteArrayToStr(Buffer)
End Function
Public Sub StrToByteArray(ByVal sStr As String, ByRef Ary() As Byte)
Dim I As Integer
ReDim Ary(Len(sStr) - 1) As Byte
RtlMoveMemory Ary(0), ByVal sStr, Len(sStr)
End Sub
Public Function ByteArrayToStr(ByRef bByt() As Byte, Optional ByVal lLoc As Long = 0) As String
Dim sStr As String
Dim I As Integer
sStr = String$(UBound(bByt) + 1, 0)
RtlMoveMemory ByVal sStr, bByt(lLoc), UBound(bByt) + 1
ByteArrayToStr = sStr
End Function
Public Sub SimpleCrypt(ByRef bBase() As Byte, ByRef bKey() As Byte)
Dim lVal As Long
Dim I As Long
Dim lPos As Long
Dim temp As Byte
ReDim bKey(&H101) As Byte
For I = 0 To &HFF
bKey(I) = I
Next I
For I = 1 To &H40
lVal = lVal + bKey(I * 4 - 4) + bBase(lPos Mod (UBound(bBase) + 1))
lPos = lPos + 1
temp = bKey(I * 4 - 4)
bKey(I * 4 - 4) = bKey(lVal And &HFF)
bKey(lVal And &HFF) = temp
lVal = lVal + bKey(I * 4 - 3) + bBase(lPos Mod (UBound(bBase) + 1))
lPos = lPos + 1
temp = bKey(I * 4 - 3)
bKey(I * 4 - 3) = bKey(lVal And &HFF)
bKey(lVal And &HFF) = temp
lVal = lVal + bKey(I * 4 - 2) + bBase(lPos Mod (UBound(bBase) + 1))
lPos = lPos + 1
temp = bKey(I * 4 - 2)
bKey(I * 4 - 2) = bKey(lVal And &HFF)
bKey(lVal And &HFF) = temp
lVal = lVal + bKey(I * 4 - 1) + bBase(lPos Mod (UBound(bBase) + 1))
lPos = lPos + 1
temp = bKey(I * 4 - 1)
bKey(I * 4 - 1) = bKey(lVal And &HFF)
bKey(lVal And &HFF) = temp
Next I
End Sub
Public Sub DoCrypt(ByRef bData() As Byte, ByRef bKey() As Byte, ByRef bRet() As Byte)
Dim I As Long
Dim temp As Byte
Dim Y As Long
Dim Z As Long
ReDim bRet(UBound(bData))
RtlMoveMemory bRet(0), bData(0), UBound(bData) + 1
Y = bKey(&H100)
Z = bKey(&H101)
For I = 0 To UBound(bData)
Y = (Y + 1) And &HFF
Z = (Z + bKey(Y)) And &HFF
temp = bKey(Y)
bKey(Y) = bKey(Z)
bKey(Z) = temp
bRet(I) = bRet(I) Xor bKey((CInt(bKey(Y)) + CInt(bKey(Z))) And &HFF)
Next I
bKey(&H100) = Y
bKey(&H101) = Z
End Sub
In your BNCS connection code, add the following private declarations:
Code:
Private cWarden As New clsWarden
Private wKeyOut() As Byte
Private wKeyIn() As Byte
In SID_AUTH_CHECK, somewhere after hashing your CDKey, add:
Code:
cWarden.Initialize Left$(KeyHash, 4)
cWarden.StrToByteArray cWarden.GetBytes(&HF), bRet()
cWarden.SimpleCrypt bRet(), wKeyOut()
cWarden.StrToByteArray cWarden.GetBytes(&HF), bRet()
cWarden.SimpleCrypt bRet(), wKeyIn()
To handle SID_Warden (5E):
Code:
Private Sub SID_Recv_Warden()
Dim bData() As Byte
Dim bRet() As Byte
Dim sData As String
Dim lPos As Long
Dim nFile As Integer
Dim EventNo As Byte
Dim I As Long
Dim Loops As Long
Dim Vals() As String
Dim addr() As Long
Dim readlen As Byte
Dim ToSend As String
Dim Checksum As Long
Const Req1 As Long = &H497FB0
Const Req2 As Long = &H49C33D
Const Req3 As Long = &H4A2FF7
sData = Packet.GetNull
cWarden.StrToByteArray sData, bData()
cWarden.DoCrypt bData(), wKeyIn(), bRet()
Select Case bRet(0)
Case &H0
Packet.ClearOutbound
ReDim bData(0)
bData(0) = &H1
cWarden.DoCrypt bData(), wKeyOut(), bRet()
Packet.InsertString cWarden.ByteArrayToStr(bRet())
AddQueue Packet.SendBNCSPacket(SID_WARDEN)
Case &H2
If LenB(Dir$(CFm_HashPath & "\StarCraft.exe")) > 0 Then
EventNo = bRet(1)
Loops = (Len(sData) - 3) / 7
ReDim Vals(Loops - 1) As String
ReDim addr(Loops - 1) As Long
nFile = FreeFile
Open CFm_HashPath & "\StarCraft.exe" For Binary Access Read As #nFile
lPos = 2
For I = 0 To Loops - 1
lPos = lPos + 2
RtlMoveMemory addr(I), bRet(lPos), 4
lPos = lPos + 4
readlen = bRet(lPos)
lPos = lPos + 1
Vals(I) = String$(readlen, 0)
Get #nFile, addr(I) - &H400000 + 1, Vals(I)
Next I
Close #nFile
If addr(0) = Req1 And addr(1) = Req2 And addr(2) = Req3 Then
Checksum = &H193E73E8
ElseIf addr(0) = Req2 And addr(1) = Req1 And addr(2) = Req3 Then
Checksum = &HD6557DEF
ElseIf addr(0) = Req1 And addr(1) = Req3 And addr(2) = Req2 Then
Checksum = &H2183172A
ElseIf addr(0) = Req2 And addr(1) = Req3 And addr(2) = Req1 Then
Checksum = &HCA841860
ElseIf addr(0) = Req3 And addr(1) = Req2 And addr(2) = Req1 Then
Checksum = &H9F2AD2C3
ElseIf addr(0) = Req3 And addr(1) = Req1 And addr(2) = Req2 Then
Checksum = &HC04CF757
Else
RaiseEvent BNetError("Unknown Warden Request! You will be disconnected in two minutes.")
Exit Sub
End If
Packet.ClearOutbound
For I = 0 To Loops - 1
Packet.InsertByte &H0
Packet.InsertString Vals(I)
Next I
ToSend = Packet.GetOutbound
ToSend = Chr$(&H2) & Packet.CreateWORD(Len(ToSend)) & Packet.CreateDWORD(Checksum) & ToSend
cWarden.StrToByteArray ToSend, bData()
Packet.ClearOutbound
cWarden.DoCrypt bData(), wKeyOut(), bRet()
Packet.InsertString cWarden.ByteArrayToStr(bRet())
AddQueue Packet.SendBNCSPacket(SID_WARDEN)
Else
RaiseEvent BNetError("Can't respond to Warden without StarCraft.exe!")
End If
Case Else
RaiseEvent BNetError("Unknown Warden Packet: " & StH(sData))
End Select
End Sub
That may make things a bit easier to understand.
FAQ:
Can i get banned if i use this bypass?
A=Yes you can.
This will work always?
A=No it wont, if blizzard updates the warden module this code wont work.
Can you help me?
A=No, is not my code.
Why you post it then?
A=Because it might be usefull for some people.