Locked Encodes a VBS script using simple hex encoding.

[sQuo]

Encodes a VBS script using simple hex encoding.

 

 

[HIDE-THANKS]

[LENGUAJE=vbscript]

'Encodes a VBS script using simple hex encoding.

 

Dim fs, ts, wsh

Dim strLine, varByteArray, lngCounter, blnFirst

'BYTES_PER_LINE is chosen to limit generated line length.

'Line length = (2 * BYTES_PER_LINE) + 16

'Use + 14 if you don't want to count CRLF as part of the line.

'A value of 26 is suggested for in-body email,

'248 max recommended, 251 max allowed.

Const BYTES_PER_LINE = 248

Const ForWriting = 2

Set wsh = CreateObject("Wscript.Shell")

Set fs = CreateObject("Scripting.FileSystemObject")

 

'Verify we have a good argument

If WScript.Arguments.Count 1 Then

WScript.Echo "Pass a VBS file as an argument. I'll hex-encode that file while leaving it functional!"

WScript.Quit 1

End If

If Not fs.FileExists(WScript.Arguments(0)) Then

WScript.Echo "The argument you supplied does not exist as a file."

WScript.Quit 1

End If

If Not Lcase(Right(WScript.Arguments(0), 4)) = ".vbs" Then

WScript.Echo "The file you supplied is not a VBS file."

WScript.Quit 1

End If

 

'Verify we have the ADODB.Stream object available

If Not IsRegistered("ADODB.Stream") Then

WScript.Echo "ADODB is not installed on your system. Please install the latest Microsoft data access components from www.microsoft.com/data."

WScript.Quit

End If

 

'Read the source file

varByteArray = ReadByteArray(WScript.Arguments(0))

'Open the script for writing -- we'll be modifying the original script!

Set ts = fs.OpenTextFile(WScript.Arguments(0), ForWriting, True)

 

'Now read every byte in the file and spit out hex

strLine = ""

blnFirst = True

For lngCounter = 1 to UBound(varByteArray) + 1

strLine = strLine & Right("00" & Hex(Ascb(Midb(varByteArray,lngCounter,1))), 2)

If lngCounter Mod BYTES_PER_LINE = 0 Then

'write the accumulated data line

If blnFirst Then

ts.WriteLine "x = Hd(""" & strLine & """)"

blnFirst = False

Else

ts.WriteLine "x = x & Hd(""" & strLine & """)"

End If

strLine = ""

End If

Next

 

'Handle leftovers

If strLine "" Then

ts.WriteLine "x = x & Hd(""" & strLine & """)"

End If

 

'Write the "action" line!

ts.WriteLine "ExecuteGlobal x"

'Write the hex decode function (x = hex data, n = index, s = buffer)

'If our lines will be long enough, put the function on a single line

If BYTES_PER_LINE

ts.WriteLine "Function Hd(x)"

ts.WriteLine vbTab & "For n = 1 To Len(x) Step 2"

ts.WriteLine vbTab & vbTab & "s = s & Chr(Clng(""&H"" & Mid(x, n, 2)))"

ts.WriteLine vbTab & "Next"

ts.WriteLine vbTab & "Hd = s"

ts.WriteLine "End Function"

Else

ts.WriteLine "Function Hd(x) : For n = 1 To Len(x) Step 2 : s = s & Chr(Clng(""&H"" & Mid(x, n, 2))) : Next : Hd = s : End Function"

End If

 

Function IsRegistered(strObjectName)

'Returns True if object can be created

Dim obj

On Error Resume Next

Set obj = Nothing

Set obj = CreateObject(strObjectName)

If obj Is Nothing Then

IsRegistered = False

Else

IsRegistered = True

Set obj = Nothing

End If

End Function

 

Function ReadByteArray(strFileName)

Const adTypeBinary = 1

Dim bin

Set bin = CreateObject("ADODB.Stream")

bin.Type = adTypeBinary

bin.Open

bin.LoadFromFile strFileName

ReadByteArray = bin.Read

End Function

 

[/LENGUAJE][/HIDE-THANKS]