'Creates a self-extracting VBS file around three times
'the size of the original file. The created file will be named
'the same as the source file except for an additional VBS 
'extension. For example, "test.gif" would create "test.gif.vbs".
'When run, the self-extracting VBS file will create the original
'file in the same directory as the VBS file.
'
'As generated, the VBS file is kept under 80 columns wide. As 
'a result, the text can be copied and pasted into the body of 
'an email, then be copied and pasted back into a VBS file on the 
'receiving end. This effectively allows file attachments where 
'attachments aren't allowed or where separate decoders may not 
'be available.
'
'FYI, the name of this script "shar.vbs" is taken from an old 
'UNIX command "shar", which stands for "shell archive". In other 
'words, an archive that can be extracted using nothing more than 
'the "shell", or built-in operating system commands. Which is 
'exactly what this script creates.


Dim fs, ts, wsh
Dim strLine, strStatus, strPrompt
Dim varByteArray
Dim intPos, intPercent, lngCounter
Const BYTES_PER_LINE = 26 'Chosen to stay under 80 byte generated line
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 "Drop a file on me. I will create a VBS self-extracting archive."
	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

'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))
'Begin writing the output file
Set ts = fs.OpenTextFile(WScript.Arguments(0) & ".vbs", ForWriting, True)
ts.WriteLine "'This script will create a file named """ & fs.GetFileName(WScript.Arguments(0)) & """"
ts.WriteLine "Dim ts, fs, strFileName"
ts.WriteLine "Set fs = CreateObject(""Scripting.FileSystemObject"")"
ts.WriteLine "strPrompt = ""Extract " & fs.GetFileName(WScript.Arguments(0)) & " where?"""
ts.WriteLine "On Error Resume Next"
ts.WriteLine "Set ts = Nothing"
ts.WriteLine "strFileName = BrowseForFolder(strPrompt)"
ts.WriteLine "If strFileName <> """" Then"
ts.WriteLine vbTab & "strFileName = fs.BuildPath(strFileName, """ & fs.GetFileName(WScript.Arguments(0)) & """)"
ts.WriteLine vbTab & "Err.Clear"
ts.WriteLine vbTab & "Set ts = fs.OpenTextFile(strFileName, 2, True)"
ts.WriteLine vbTab & "If Err.Number <> 0 Then Set ts = Nothing"
ts.WriteLine "End If"
intPercent = 0

'Now read every byte in the file and spit out hex
strLine = ""
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
		'Show progress
		If Cint(100 * lngCounter / UBound(varByteArray)) <> intPercent Then
			intPercent = Cint(100 * lngCounter / UBound(varByteArray))
			strStatus = CStr(intPercent)
			If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then
				'Text output if host is CSCRIPT
				WScript.Echo strStatus & "%"
			End If
		Else 
			strStatus = ""
		End If
		'write the accumulated data line
		ts.WriteLine "Hex2File """ & strLine & """, ts, """ & strStatus & """"
		strLine = ""
	End If
Next

'Handle leftovers
If strLine <> "" Then 
	'write the accumulated data line
	ts.WriteLine "Hex2File """ & strLine & """, ts, """ & strStatus & """"
End If
ts.WriteLine "ts.Close"

'Write the hex data to binary file subroutine
ts.WriteLine ""
ts.WriteLine "Sub Hex2File(strHexData, tsFile, strStatus)"
ts.WriteLine "Dim intCount, strBuffer"
ts.WriteLine vbTab & "On Error Resume Next"
ts.WriteLine vbTab & "If tsFile Is Nothing Then Exit Sub"
ts.WriteLine vbTab & "For intCount = 1 To Len(strHexData) Step 2"
ts.WriteLine vbTab & vbTab & "strBuffer = strBuffer & Chr(Clng(""&H"" & Mid(strHexData, intCount, 2)))"
ts.WriteLine vbTab & "Next"
ts.WriteLine vbTab & "tsFile.Write strBuffer"
ts.WriteLine vbTab & "If strStatus <> """" Then Wscript.StdOut.WriteLine strStatus & ""%"""
ts.WriteLine "End Sub"

'Write the BrowseForFolder function
ts.WriteLine ""
ts.WriteLine "Function BrowseForFolder(strPrompt)"
ts.WriteLine "Const ssfPERSONAL = 5 'My Documents"
ts.WriteLine "Const ssfDRIVES = 17 'My Computer"
ts.WriteLine "Const SFVVO_SHOWALLOBJECTS = 1"
ts.WriteLine "Const SFVVO_SHOWEXTENSIONS = 2"
ts.WriteLine "Dim sh, fol, fs, lngView, strPath"
ts.WriteLine vbTab & "Set sh = CreateObject(""Shell.Application"")"
ts.WriteLine vbTab & "Set fs = CreateObject(""Scripting.FileSystemObject"")"
ts.WriteLine vbTab & "If Instr(TypeName(sh), ""Shell"") = 0 Then"
ts.WriteLine vbTab & vbTab & "strPath = fs.GetParentFolderName(WScript.ScriptFullName)"
ts.WriteLine vbTab & vbTab & "BrowseForFolder = InputBox(strPrompt, ""Destination"", strPath)"
ts.WriteLine vbTab & vbTab & "Exit Function"
ts.WriteLine vbTab & "End If"
ts.WriteLine vbTab & "lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS"
ts.WriteLine vbTab & "strPath = """""
ts.WriteLine vbTab & "Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)"
ts.WriteLine vbTab & "Err.Clear"
ts.WriteLine vbTab & "On Error Resume Next"
ts.WriteLine vbTab & "strPath = fol.ParentFolder.ParseName(fol.Title).Path"
ts.WriteLine vbTab & "'An error occurs if the user selects a drive instead of a folder"
ts.WriteLine vbTab & "If Err.Number <> 0 Then"
ts.WriteLine vbTab & vbTab & "BrowseForFolder = Left(Right(fol.Title, 3), 2) & ""\"""
ts.WriteLine vbTab & "Else"
ts.WriteLine vbTab & vbTab & "BrowseForFolder = strPath"
ts.WriteLine vbTab & "End If"
ts.WriteLine "End Function"
ts.Close

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