Option Explicit

Dim p,f,b,i,o,w,x,arg

Set o=CreateObject("Scripting.FileSystemObject")
Set w=CreateObject("WScript.Shell")

On Error Resume Next

If WScript.Arguments.Count = 0 Then
   WScript.Echo  "Please drag'n'drop your file you want to patch to this script!"
   WScript.Quit
Else
   For each arg in WScript.Arguments  
      p = arg 
   Next
End If

If o.FileExists(p) Then
  If not o.FileExists(p & ".patched.bcd") Then
    o.CopyFile p, p & ".patched.bcd"
  End If
  p = p & ".patched.bcd"
  b=RSBinaryToString(ReadBinaryFile(p))
  ' Search for StartUpURLEnabled 1
  i = InStr(1,b,chr(&H53)& chr(&H74)& chr(&H61)& chr(&H72)& chr(&H74)& chr(&H55)& chr(&H70)& chr(&H55)& chr(&H52)& chr(&H4C)& chr(&H45)& chr(&H6E)& chr(&H61)& chr(&H62)& chr(&H6C)& chr(&H65)& chr(&H64) & chr(&H00) & chr(&H31))+18
  If i = 18 Then 
    PatchError("[ERROR] Failed to bypass StartupURL")
  Else
    b = Left(b,i-1) & chr(&H30) & Mid(b,i+1)
  End if
  
  For x = 1 to 4 
    ' Search for protected 1
    i = InStr(1,b,chr(&H70)& chr(&H72)& chr(&H6F)& chr(&H74)& chr(&H65)& chr(&H63)& chr(&H74)& chr(&H65)& chr(&H64)& chr(&H00)& chr(&H31))+10
    If i = 10 Then 
      PatchError("[ERROR] Failed to bypass Protected Preset Nr." & x)
    Else
      b = Left(b,i-1) & chr(&H30) & Mid(b,i+1)
    End If
  Next 'x
  '
  On Error Resume Next
  Err.Clear
  Set f=o.OpenTextFile(p,2)
  If Err.Number<>0 Then
    Err.Clear
    WScript.Echo "Cannot write to file!" & vbcrlf & _
    "Please close any open files and retry."
    WScript.Quit
  End If
  f.Write b
  f.Close
  
  WScript.Echo "File is Patched!"
  
Else
  WScript.Echo "Unable to locate "&p
End If

WScript.Quit

Sub PatchError(m)
  WScript.Echo m&vbcrlf&vbcrlf& _
  "Possible reasons are:"&vbcrlf&vbcrlf& _
  "1. The file is already patched."&vbcrlf& _
  "2. A new patch is required."&vbcrlf&vbcrlf& _
  "Click OK to quit."
  WScript.Quit
End Sub

Function ReadBinaryFile(FileName)
Const adTypeBinary = 1
Dim BinaryStream : Set BinaryStream = CreateObject("ADODB.Stream")
  BinaryStream.Type = adTypeBinary
  BinaryStream.Open
  BinaryStream.LoadFromFile FileName
  ReadBinaryFile = BinaryStream.Read
  BinaryStream.Close
End Function


Function RSBinaryToString(xBinary)
  Dim Binary
  If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
  Dim RS, LBinary
  Const adLongVarChar = 201
  Set RS = CreateObject("ADODB.Recordset")
  LBinary = LenB(Binary)
  If LBinary>0 Then
    RS.Fields.Append "mBinary", adLongVarChar, LBinary
    RS.Open
    RS.AddNew
    RS("mBinary").AppendChunk Binary
    RS.Update
    RSBinaryToString = RS("mBinary")
  Else
    RSBinaryToString = ""
  End If
End Function