'  Creates an EPUB from plain text. Can add any JPG file as cover art.
'No chapters are created (or only one chapter, which is the same thing). 

'  If a TXT file is dropped on the script, an EPUB file will 
'be created with the same base name and in the same folder.
'  If a folder is dropped on the script, any text in the 
'Windows clipboard will be made into an EPUB in that folder.
'  If a JPG file was dropped on the script in the previous 5 
'minutes, it will be used as cover art only once.
'  If no JPG file was dropped on the script, the most recent JPG 
'picture (if any) in the destination folder will be used as 
'cover art for any ebook created in that folder.
'  If this script is run from an administrative command prompt, 
'it will toggle right-click options on folders, TXT, and JPG.
'  The epub books created by this script are "uncompressed" so 
'the script doesn't need any external ZIP programs or OS features.
'  Released to Public Domain by Eric Phelps 2010, 2011, 2013
'May be used, distributed, and modified with no restrictions.
'http://www.ericphelps.com

Option Explicit

'#################### User editing area ######################
Const PROMPT_TITLE = True 'Ask the user to confirm a guess on the title (Default is first line)
Const PROMPT_AUTHOR = True 'Ask the user to confirm a guess on the author (Default is text after first "by")
Const PROMPT_ID = False 'Prompt for a unique ID (Default is timestamp, suggestion is ISBN or URL)
Const DEF_AUTHOR = "Unknown" 'Last ditch value to use as an author name
Const DEF_UNWRAP = False 'Default unwrap action for single newlines (unless overridden on command line)
Const DEF_UNHYPHEN = True 'Default end-of-line hyphen removal action (unless overridden on command line)
Const DEF_INDENT = 4 'Default indent on new paragraphs (unless overridden on command line)
Const DEF_OVERWRITE = False 'Overwrite an existing epub file without asking (unless overridden on command line)
Const DIR_RIGHT_CLICK_TEXT = "Create EPUB from Clipboard" 'Right-click folder option text. 
Const JPG_RIGHT_CLICK_TEXT = "Use JPG as next EPUB cover" 'Right-click picture option text. 
Const TXT_RIGHT_CLICK_TEXT = "Create EPUB from plain text" 'Right-click plain text option text. 
'############# No user editing below this point ###############

Const TEXT_EXTENSIONS = "ncx opf xhtm xhtml xml" 'Used to direct zip file creation
Dim strZipFileEntries, strZipDirectoryEntries 'Global variables used to accumulate zip data
Dim strCover 'Global variable used to hold the path (if any) of the cover art

Main

Sub Main()
	Dim fs, strWorkingDir
	Dim strTitle, strAuthor, strID, strContent, strFile, strIndent, strLine, strChar, intCount
	Dim blnUnwrap, blnUnHyphen, blnOverWrite, intIndent, intVerbose, strGood, strBad, lngLength
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Verify we have minimum inputs
	If WScript.Arguments.Count = 0 Then
		ToggleRightClick
		MsgBox "[Drop a plain text file on this script -or- copy some text and drop a destination folder] -and- " _
		& vbCrLf & "[Answer questions -or- edit ""Const"" values in the script -or- use command line arguments]:" & vbCrLf _
		& vbCrLf & "/file:""C:\path\file.txt""  (location of plain text)" _
		& vbCrLf & "/title:""Book Title""  (title of book DEFAULT=Based on text file name)" _
		& vbCrLf & "/author:""Author Name""  (book author DEFAULT=Byline in book beginning)" _
		& vbCrLf & "/id:ID  (isbn or other unique id DEFAULT=TIMESTAMP)" _
		& vbCrLf & "/unwrap:True|False  (replace single newline with space DEFAULT=" & DEF_UNWRAP & ")" _
		& vbCrLf & "/unhyphen:True|False  (remove hyphen-newline DEFAULT=" & DEF_UNHYPHEN & ")" _
		& vbCrLf & "/indent:0-9  (number of spaces to indent paragraphs DEFAULT=" & DEF_INDENT & ")" _
		& vbCrLf & "/overwrite:True|False  (overwrite without asking DEFAULT=" & DEF_OVERWRITE & ")" _
		& vbCrLf & vbCrLf & "If desired, cover art may be placed in the destination folder " _
		& "or dropped on the script before creating the ebook." _
		& vbCrLf & "If you run the script with no arguments from an Admin command prompt, " _
		& vbCrLf & "it will toggle (enable/disable) folder, JPG, and TXT right-click options. " _
		& "Current right-click status is " & RightClickStatus() & "." _
		& "", vbOkOnly, fs.GetBaseName(WScript.ScriptName)
		Exit Sub
	End If
	
	'If there's a named file name argument, use it.
	If WScript.Arguments.Named.Item("file") <> "" Then
		strFile = WScript.Arguments.Named.Item("file")
		Status "Named file argument: " & strFile
	Else
		'If no arguments, prompt for a source.
		If WScript.Arguments.Unnamed.Count = 0 Then
			strFile = InputBox("File Path", fs.GetBaseName(WScript.ScriptName), fs.GetAbsolutePathName("."))
		Else
			'The argument must be a file or a folder. Get it and we'll figure out which later.
			strFile = WScript.Arguments.Unnamed.Item(0)
			Status "Unnamed argument: " & strFile
		End If
	End If
	'Time to figure out whether we have a file or folder. 
	'First add quotes if they're needed.
	If fs.FileExists("""" & strFile & """") Then
		strFile = """" & strFile & """"
	End If
	If fs.FolderExists("""" & strFile & """") Then
		strFile = """" & strFile & """"
	End If
	'If a folder is passed instead of a file or named arguments, assume the 
	'source is the clipboard and the destinatition is the folder
	If fs.FolderExists(strFile) Then
		Status "Confirmed folder: " & strFile
		'If we were passed a folder, it means we're going to work with the clipboard. 
		'Get the book title so we can generate a file name based on the title.
		strContent = GetClipboard()
		Status "Clipboard content length: " & Len(strContent)
		strContent = ToAscii(strContent)
		strContent = SimplifyText(strContent)
		strContent = RemoveHighBytes(strContent)
		'Start by assuming the title is the first line in the story
		strTitle = Left(strContent, 128)
		strTitle = Replace(strTitle, vbCr, vbLf)
		For Each strLine In Split(strTitle, vbLf)
			If Trim(strLine) <> "" Then
				strTitle = strLine
				If PROMPT_TITLE Then 
					strTitle = InputBox("Book Title", fs.GetBaseName(WScript.ScriptName), strTitle)
				End If
				Exit For
			End If
		Next
		'Generate a fake input file name based on the title so we have something to name the output file
		strFile = strTitle
		For Each strChar In Split("/ \ * ? : < > | """)
			strFile = Replace(strFile, strChar, "")
		Next
		strFile = fs.BuildPath(WScript.Arguments(0), strFile & ".txt")
	Else
		'If we weren't passed a folder, then there better be a file!
		If Not fs.FileExists(strFile) Then
			MsgBox "Sorry, but " & strFile & " isn't a valid folder or file name.", vbOkOnly, fs.GetBaseName(WScript.ScriptName)
			Exit Sub
		End If
		Status "Confirmed file: " & strFile
		'If we were passed a JPG file, write its path in an INI file and exit.
		If ((Lcase(fs.GetExtensionName(strFile)) = "jpg") Or (Lcase(fs.GetExtensionName(strFile)) = "jpeg")) Then
			Status "Confirmed JPG file."
			String2File strFile, FileNameInTempDir(fs.GetBaseName(WScript.ScriptName) & ".ini")
			Exit Sub
		End If
		'Read the text content (not user-supplied, but I need it to guess at the author)
		strContent = File2String(strFile)
		strContent = SimplifyText(strContent)
		strContent = RemoveHighBytes(strContent)
		Status "File content length: " & strContent
		'Title
		If WScript.Arguments.Named.Item("title") <> "" Then 
			strTitle = WScript.Arguments.Named.Item("title") 
		Else
			If WScript.Arguments.Named.Item("file") <> "" Then
				strTitle = fs.GetBaseName(WScript.Arguments.Named.Item("file"))
			Else
				strTitle = fs.GetBaseName(WScript.Arguments.Unnamed.Item(0))
			End If
			If PROMPT_TITLE Then 
				strTitle = InputBox("Book Title", fs.GetBaseName(WScript.ScriptName), strTitle)
			End If
		End If
		strTitle = Trim(strTitle)
		If strTitle = "" Then
			MsgBox "Sorry, but epub ebooks MUST have a title", vbOkOnly, fs.GetBaseName(WScript.ScriptName)
			Exit Sub
		End If
	End If
	'Author
	If WScript.Arguments.Named.Item("author") <> "" Then 
		strAuthor = WScript.Arguments.Named.Item("author") 
	Else
		'Try to read the document looking for a "by" line on a title page
		strAuthor = Left(strContent, 128)
		strAuthor = Replace(strAuthor, vbCr, vbLf)
		If InStr(1, strAuthor, vbLf & "by ", vbTextCompare) Then
			'We found the word "by" at the beginning of a line -- very good!
			strAuthor = Mid(strAuthor, InStr(1, strAuthor, vbLf & "by ", vbTextCompare) + 4, 64)
			If InStr(strAuthor, vbLf) Then 
				strAuthor = Left(strAuthor, InStr(strAuthor, vbLf) - 1)
			End If
		Elseif InStr(1, strAuthor, "by ", vbTextCompare) Then
			'We found the word "by" in the middle of a line -- not so good.
			strAuthor = Mid(strAuthor, InStr(1, strAuthor, "by ", vbTextCompare) + 3, 64)
			If InStr(strAuthor, vbLf) Then 
				strAuthor = Left(strAuthor, InStr(strAuthor, vbLf) - 1)
			End If
		Else
			'We found nothing -- horrible! Just fill in the author name with a default value.
			strAuthor = DEF_AUTHOR
		End If
		strAuthor = Trim(strAuthor)
		If PROMPT_AUTHOR Then
			strAuthor = InputBox("Author", fs.GetBaseName(WScript.ScriptName), strAuthor)
		End If
	End If
	If strAuthor = "" Then
		strAuthor = DEF_AUTHOR
	End If
	'ID
	If WScript.Arguments.Named.Item("id") <> "" Then 
		strID = WScript.Arguments.Named.Item("id") 
	Else
		strID = DateDiff("s", Cdate(#January 1 1970#), Now())
	End If
	If PROMPT_ID Then
		strID = InputBox("Unique ID (ISBN, UUID, or URL):", fs.GetBaseName(WScript.ScriptName), strID)
	End If
	If strID = "" Then
		MsgBox "Sorry, but epub ebooks MUST have a unique ID", vbOkOnly, fs.GetBaseName(WScript.ScriptName)
		Exit Sub
	End If
	'UnWrap
	If Trim(Replace(Lcase(WScript.Arguments.Named.Item("unwrap")), """", "")) <> "" Then 
		blnUnwrap = Cbool(Eval(WScript.Arguments.Named.Item("unwrap")))
	Else
		blnUnwrap = DEF_UNWRAP
	End If
	'UnHyphen
	If Trim(Replace(Lcase(WScript.Arguments.Named.Item("unhyphen")), """", "")) <> "" Then 
		blnUnHyphen = Cbool(Eval(WScript.Arguments.Named.Item("unhyphen")))
	Else
		blnUnHyphen = DEF_UNHYPHEN
	End If
	'Overwrite
	If Trim(Replace(Lcase(WScript.Arguments.Named.Item("overwrite")), """", "")) <> "" Then 
		blnOverwrite = Cbool(Eval(WScript.Arguments.Named.Item("overwrite")))
	Else
		blnOverwrite = DEF_OVERWRITE
	End If
	'Indent
	intIndent = DEF_INDENT
	If WScript.Arguments.Named.Item("indent") <> "" Then 
		If IsNumeric(WScript.Arguments.Named.Item("indent")) Then
			intIndent = Cint(WScript.Arguments.Named.Item("indent") )
		End If
	End If
	
	'Retrieve the cover art location if we have it.
	strCover = ""
	If fs.FileExists(FileNameInTempDir(fs.GetBaseName(WScript.ScriptName) & ".ini")) Then
		Status "INI file exists."
		'Only consider the cover art if it was specified in the last 5 minutes
		If Abs(DateDiff("s", Now(), fs.GetFile(FileNameInTempDir(fs.GetBaseName(WScript.ScriptName) & ".ini")).DateLastModified)) > 300 Then
			'Ignore old setting
			Status "INI file is too old."
			strCover = ""
		Else
			'New file. Use the value for cover art.
			strCover = File2String(FileNameInTempDir(fs.GetBaseName(WScript.ScriptName) & ".ini"))
			Status "Cover art: " & strCover
			'Be sure the file still exists!
			If Not fs.FileExists(strCover) Then
				Status "Specified cover art doesn't exist."
				strCover = ""
			End If
		End If
		'Delete the INI file regardless once we've used it
		fs.DeleteFile FileNameInTempDir(fs.GetBaseName(WScript.ScriptName) & ".ini")
	Else
		Status "No INI file."
		'Maybe there's a JPG in the destination folder we can use?
		If strCover = "" Then 
			strCover = MostRecent(fs.GetParentFolderName(strFile), "jpg")
		End If
		If strCover = "" Then 
			strCover = MostRecent(fs.GetParentFolderName(strFile), "jpeg")
		End If
		If strCover = "" Then 
			Status "No cover art in destination folder."
		Else
			Status "Using " & strCover & " as cover art."
		End If
	End If
	
	'Convert newlines to a standard linefeed
	strContent = Replace(strContent, vbCrLf, Chr(127))
	strContent = Replace(strContent, vbCr, Chr(127))
	strContent = Replace(strContent, vbLf, Chr(127))
	strContent = Replace(strContent, Chr(127), vbLf)
	Status "Newlines standardized. New length: " & Len(strContent)
	
	'Remove hyphens
	If blnUnHyphen Then
		If InStr(strContent, "-" & vbLf) <> 0 Then
			strContent = Replace(strContent, "-" & vbLf, "")
			Status "Hyphens removed. New length: " & Len(strContent)
		Else
			Status "No hyphens found."
		End If
	End If
	
	'Unwrap
	'Remove trailing spaces
	If InStr(strContent, " " & vbLf) <> 0 Then
		strContent = Replace(strContent, " " & vbLf, vbLf)
		Status "Trailing spaces removed. New length: " & Len(strContent)
	Else
		Status "No trailing spaces found."
	End If
	If blnUnwrap Then
		'Preserve multiple newlines (to be restored as paragraphs)
		If InStr(strContent, vbLf & vbLf) <> 0 Then
			For intCount = 10 To 2 Step -1
				strContent = Replace(strContent, String(intCount, vbLf), Chr(127))
			Next
			Status "Blank lines removed. New length: " & Len(strContent)
		Else
			Status "No blank lines found."
		End If
		'Now unwrap by replacing the single newlines with spaces
		strContent = Replace(strContent, vbLf, " ")
		Status "Text unwrapped (length does not change)."
	Else
		'Remove multiple newlines even if we won't unwrap
		If InStr(strContent, vbLf & vbLf) <> 0 Then
			For intCount = 10 To 1 Step -1
				strContent = Replace(strContent, String(intCount, vbLf), Chr(127))
			Next
			Status "Blank lines removed. New length: " & Len(strContent)
		Else
			strContent = Replace(strContent, vbLf, Chr(127))
			Status "No blank lines found."
		End If
	End If
	'Restore escaped newlines
	strContent = Replace(strContent, Chr(127), vbLf)
	
	'Remove multiple spaces
	strContent = Replace(strContent, "&#160;", " ")
	If InStr(strContent, "  ") <> 0 Then
		Do While InStr(strContent, "  ") <> 0
			strContent = Replace(strContent, "  ", " ")
		Loop
		Status "Multiple spaces removed. New length: " & Len(strContent)
	Else
		Status "No multiple spaces found."
	End If

	'Indent
	For intCount = 1 To intIndent
		strIndent = strIndent & "&#160;"
	Next
	Do While InStr(strContent, vbLf & " ")
		strContent = Replace(strContent, vbLf & " ", vbLf)
	Loop
	Do While InStr(strContent, vbLf & vbTab)
		strContent = Replace(strContent, vbLf & vbTab, vbLf)
	Loop
	strContent = Replace(strContent, vbLf, vbLf & strIndent)
	strContent = Replace(strContent, vbLf, "</p>" & vbLf & "<p>")
	strContent = "<p>" & strContent
	strContent = strContent & "</p>"
	Status "Paragraphs indented and html paragraph tags inserted. New length: " & Len(strContent)
	
	'Add back my CRLF
	strContent = Replace(strContent, vbLf, Chr(127))
	strContent = Replace(strContent, Chr(127), vbCrLf)
	
	'Create the working directory
	strWorkingDir = fs.GetBaseName(WScript.ScriptName)
	strWorkingDir = FileNameInTempDir(strWorkingDir)
	If fs.FolderExists(strWorkingDir) Then fs.DeleteFolder strWorkingDir, True
	WScript.Sleep 500 'Time for file system to settle
	fs.CreateFolder strWorkingDir
	fs.CreateFolder fs.BuildPath(strWorkingDir, "META-INF")
	Status "Working folder created: " & strWorkingDir
	
	'Create the actual ebook file structure
	String2File MimeType(), fs.BuildPath(strWorkingDir, "mimetype")
	String2File XML(), fs.BuildPath(strWorkingDir, "META-INF\container.xml")
	String2File OPF(strTitle, strAuthor, strID, strFile), fs.BuildPath(strWorkingDir, "content.opf")
	String2File TitlePage(strTitle, strAuthor, strFile), fs.BuildPath(strWorkingDir, "title.xhtml")
	String2File DocumentBody(strContent, strTitle), fs.BuildPath(strWorkingDir, "content.xhtml")
	String2File NCX(strTitle, strAuthor), fs.BuildPath(strWorkingDir, "toc.ncx")
	If strCover <> "" Then
		fs.CopyFile strCover, fs.BuildPath(strWorkingDir, "cover.jpg")
	End If
	Status "Working folder completed: " & strWorkingDir
	
	'Zip up the epub
	Zip strWorkingDir
	Status "Created zip file: " & fs.BuildPath(fs.GetParentFolderName(strWorkingDir), fs.GetBaseName(strWorkingDir) & ".zip")
	'Move the created file to the same place as the original source file
	If fs.FileExists(fs.BuildPath(fs.GetParentFolderName(strFile), fs.GetBaseName(strFile) & ".epub")) Then
		If Not blnOverwrite Then
			If MsgBox("Overwrite existing file:" & vbCrLf & fs.BuildPath(fs.GetParentFolderName(strFile), fs.GetBaseName(strFile) & ".epub"), vbYesNo, fs.GetBaseName(WScript.ScriptName)) = vbYes Then
				fs.DeleteFile fs.BuildPath(fs.GetParentFolderName(strFile), fs.GetBaseName(strFile) & ".epub"), True
			Else
				fs.DeleteFile fs.BuildPath(fs.GetParentFolderName(strWorkingDir), fs.GetBaseName(strWorkingDir) & ".zip"), True
				fs.DeleteFolder strWorkingDir, True
				Exit Sub
			End If
		Else
			fs.DeleteFile fs.BuildPath(fs.GetParentFolderName(strFile), fs.GetBaseName(strFile) & ".epub"), True
		End If
	End If
	fs.MoveFile fs.BuildPath(fs.GetParentFolderName(strWorkingDir), fs.GetBaseName(strWorkingDir) & ".zip"), fs.BuildPath(fs.GetParentFolderName(strFile), fs.GetBaseName(strFile) & ".epub")
	Status "Moved zip file to epub: " & fs.BuildPath(fs.GetParentFolderName(strFile), fs.GetBaseName(strFile) & ".epub")
	'Clean up temp files
	fs.DeleteFolder strWorkingDir, True
	Status "Deleted working folder: " & strWorkingDir
	
End Sub

Function ToAscii(strUnicode)
	Dim lngPointer, strOut, lngLength, blnUnicode
	strOut = ""
	blnUnicode = False
	'If it's a big file, sample the text to see if converting it is worth it
	If Len(strUnicode) < 100000 Then
		blnUnicode = True
	Else
		lngLength = 1000
		If Len(strUnicode) < lngLength Then lngLength = Len(strUnicode)
		For lngPointer = 1 To lngLength
			If Eval(Chr(Asc(Mid(strUnicode, lngPointer, 1))) <> Mid(strUnicode, lngPointer, 1)) Then
				blnUnicode = True
			End If
		Next
	End If
	'If the input is unicode, process it. Otherwise do nothing
	If blnUnicode Then
		For lngPointer = 1 To Len(strUnicode)
			strOut = strOut & Chr(Asc(Mid(strUnicode, lngPointer, 1)))
		Next
	Else
		strOut = strUnicode
	End If
	ToAscii = strOut
End Function

Function SimplifyText(strText)
'Replaces unusual characters with plain ascii, escapes/unescapes html to make it simple as possible
	Dim lngLength, strGood, strBad, strContent
	strContent = strText
	lngLength = Len(strContent)
	strGood = "..." : For Each strBad In Split("&#133; &#8230;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = """" : For Each strBad In Split("“ ” &#147; &#148; &#8220; &#8221;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "--" : For Each strBad In Split("– &#150; &ndash; — &#151; &mdash;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "ss" : For Each strBad In Split("ß &#223; &szlig;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "'" : For Each strBad In Split("’ ‘ ` ´ &#145; &#146; &#8217; &#8216; &#96;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "A" : For Each strBad In Split("Ä &#196; Å &#197; À &#192; Á &#193; Â &#194; Ã &#195;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "C" : For Each strBad In Split("Ç &#199;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "E" : For Each strBad In Split("Ë &#203; È &#200; É &#201; Ê &#202;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "I" : For Each strBad In Split("Í &#205; Î &#206; Ï &#207; Ì &#204;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "N" : For Each strBad In Split("Ñ &#209;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "O" : For Each strBad In Split("Ø &#216; Ó &#211; Ô &#212; Õ &#213; Ö &#214; Ò &#210;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "U" : For Each strBad In Split("Ü &#220; Û &#219; Ú &#218; Ù &#217;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "Y" : For Each strBad In Split("Ý &#221; &Yacute;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "a" : For Each strBad In Split("å &#229; &aring; ä &#228; &auml; ã &#227; &atilde; â &#226; &acirc; á &#225; &aacute; à &#224; &agrave;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "c" : For Each strBad In Split("ç &#231; &ccedil;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "e" : For Each strBad In Split("ë &#235; &euml; ê &#234; &ecirc; é &#233; &eacute; è &#232; &egrave;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "i" : For Each strBad In Split("ï &#239; &iuml; î &#238; &icirc; í &#237; &iacute; ì &#236; &igrave;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "n" : For Each strBad In Split("ñ &#241; &ntilde;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "o" : For Each strBad In Split("ø &#248; &oslash; ö &#246; &ouml; õ &#245; &otilde; ô &#244; &ocirc; ó &#243; &oacute; ò &#242; &ograve;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "u" : For Each strBad In Split("ü &#252; &uuml; û &#251; &ucirc; ú &#250; &uacute; ù &#249; &ugrave;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "y" : For Each strBad In Split("ÿ &#255; &yuml; ý &#253; &yacute;") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "z" : For Each strBad In Split("ž &#158;") : strContent = Replace(strContent, strBad, strGood) : Next
	If lngLength <> Len(strContent) Then
		Status "Smart quotes, ellipsis, emdashes, and accents replaced. New length: " & Len(strContent)
	Else
		Status "No smart quotes, ellipsis, emdashes, or accented characters found."
	End If
	
	'Escape characters to make text xml/html safe
	lngLength = Len(strContent)
	If ((InStr(strContent,  "&gt;") <> 0) Or (InStr(strContent,  "&lt;") <> 0)) Then
		Status "Found escaped angle brackets."
	End If
	If ((InStr(strContent,  ">") <> 0) Or (InStr(strContent,  "<") <> 0)) Then
		Status "Found unescaped angle brackets."
	End If
	strContent = Replace(strContent, "&gt;", ">", 1, -1, vbTextCompare)
	strContent = Replace(strContent, "&lt;", "<", 1, -1, vbTextCompare)
	If InStr(strContent,  "&") <> 0 Then
		Status "Found ampersand characters."
	End If
	strContent = Replace(strContent, "&", "&amp;", 1, -1, vbTextCompare)
	strContent = Replace(strContent, ">", "&gt;", 1, -1, vbTextCompare)
	strContent = Replace(strContent, "<", "&lt;", 1, -1, vbTextCompare)
	If lngLength <> Len(strContent) Then
		Status "Escaped angle brackets and ampersands. New length: " & Len(strContent)
	Else
		Status "No angle brackets or ampersands located."
	End If
	SimplifyText = strContent
End Function

Function RemoveHighBytes(strBadText)
	Dim lngLength, lngCount, blnBad, strText, strOut, strBuffer, strChar
	strText = strBadText
	'Process bad text
	strOut = ""
	strBuffer = ""
	For lngCount = 1 To Len(strText)
		strChar = Mid(strText, lngCount, 1)
		If Asc(strChar) > 127 Then
			strBuffer = strBuffer & " "
		Else
			strBuffer = strBuffer & strChar
		End If
		If lngCount Mod 1000 = 0 Then
			strOut = strOut & strBuffer
			strBuffer = ""
		End If
	Next
	strOut = strOut & strBuffer
	RemoveHighBytes = strOut
End Function

Function MimeType()
	MimeType = "application/epub+zip"
End Function

Function XML()
	Dim strXML
	strXML = ""
	strXML = strXML & "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
	strXML = strXML & "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.1//EN"" " 
	strXML = strXML & """http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"">" & vbCrLf
	strXML = strXML & "<container version=""1.0"" xmlns=""urn:oasis:names:tc:opendocument:xmlns:container"">" & vbCrLf
	strXML = strXML & "<rootfiles>" & vbCrLf
	strXML = strXML & "<rootfile full-path=""content.opf"" media-type=""application/oebps-package+xml""/>" & vbCrLf
	strXML = strXML & "</rootfiles>" & vbCrLf
	strXML = strXML & "</container>" & vbCrLf
	XML = strXML
End Function

Function OPF(strTitle, strAuthor, strID, strFile)
	Dim strOPF, strCopyright, strPublisher, fs
	Set fs = CreateObject("Scripting.FileSystemObject")
	strOPF = ""
	strOPF = strOPF & "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
	strOPF = strOPF & "<package version=""2.0"" xmlns=""http://www.idpf.org/2007/opf""" & vbCrLf
	strOPF = strOPF & "unique-identifier=""ebook"">" & vbCrLf
	strOPF = strOPF & vbTab & "<metadata xmlns:dc=""http://purl.org/dc/elements/1.1/"" "
	strOPF = strOPF & "xmlns:opf=""http://www.idpf.org/2007/opf"">" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<dc:title>" & strTitle & "</dc:title>" & vbCrLf
	If strCover <> "" Then
		strOPF = strOPF & vbTab & vbTab & "<meta name=""cover"" content=""cover""/>" & vbCrLf
	End If
	strOPF = strOPF & vbTab & vbTab & "<dc:identifier id=""ebook"">" & strID & "</dc:identifier>" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<dc:creator opf:role=""aut"">" & strAuthor & "</dc:creator>" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<dc:language>en</dc:language>" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<dc:rights></dc:rights>" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<dc:publisher></dc:publisher>" & vbCrLf
	strOPF = strOPF & vbTab & "</metadata>" & vbCrLf
	strOPF = strOPF & vbTab & "<manifest>" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<item id=""ncx"" href=""toc.ncx"" media-type=""application/x-dtbncx+xml"" />" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<item id=""title"" href=""title.xhtml"" media-type=""application/xhtml+xml"" />" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<item id=""content"" href=""content.xhtml"" media-type=""application/xhtml+xml"" />" & vbCrLf
	If strCover <> "" Then
		strOPF = strOPF & vbTab & vbTab & "<item id=""cover"" href=""cover.jpg"" media-type=""image/jpeg"" />" & vbCrLf
	End If
	strOPF = strOPF & vbTab & "</manifest>" & vbCrLf
	strOPF = strOPF & vbTab & "<spine toc=""ncx"">" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<itemref idref=""title"" />" & vbCrLf
	strOPF = strOPF & vbTab & vbTab & "<itemref idref=""content"" />" & vbCrLf
	strOPF = strOPF & vbTab & "</spine>" & vbCrLf
	strOPF = strOPF & "</package>" & vbCrLf
	OPF = strOPF
End Function

Function TitlePage(strTitle, strAuthor, strFile)
	Dim strPage, fs
	Set fs = CreateObject("Scripting.FileSystemObject")
	strPage = ""
	strPage = strPage & "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
	strPage = strPage & "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD XHTML 1.1//EN"" ""http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"">" & vbCrLf
	strPage = strPage & "<html xmlns=""http://www.w3.org/1999/xhtml"">" & vbCrLf
	strPage = strPage & vbTab & "<head>" & vbCrLf
	strPage = strPage & vbTab & vbTab & "<title>" & strTitle & "</title>" & vbCrLf
	strPage = strPage & vbTab & "</head>" & vbCrLf
	strPage = strPage & vbTab & "<body>" & vbCrLf
	strPage = strPage & vbTab & vbTab & "<div  style=""text-align:center"">" & vbCrLf
	If strCover <> "" Then
		strPage = strPage & vbTab & vbTab & vbTab & "<img src=""cover.jpg"" alt=""" & Replace(SimplifyText(strTitle), """", "") & """ />" & vbCrLf
	Else
	  	strPage = strPage & vbTab & vbTab & vbTab & "<p>&#160;</p>" & vbCrLf
		strPage = strPage & vbTab & vbTab & vbTab & "<h1>" & strTitle & "</h1>" & vbCrLf
	  	strPage = strPage & vbTab & vbTab & vbTab & "<p>&#160;</p>" & vbCrLf
	  	If strAuthor <> DEF_AUTHOR Then
	  		strPage = strPage & vbTab & vbTab & vbTab & "<h3>" & strAuthor & "</h3>" & vbCrLf
	  		strPage = strPage & vbTab & vbTab & vbTab & "<p>&#160;</p>" & vbCrLf
	  	End If
	End If
	strPage = strPage & vbTab & vbTab & "</div>" & vbCrLf
	strPage = strPage & vbTab & "</body>" & vbCrLf
	strPage = strPage & "</html>"
	TitlePage = strPage
End Function

Function DocumentBody(strContent, strTitle)
	Dim strBody
	strBody = ""
	strBody = strBody & "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
	strBody = strBody & "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.1//EN"" ""http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"">" & vbCrLf
	strBody = strBody & "<html xmlns=""http://www.w3.org/1999/xhtml"">" & vbCrLf
	strBody = strBody & vbTab & "<head>" & vbCrLf
	strBody = strBody & vbTab & vbTab & "<title>" & strTitle & "</title>" & vbCrLf
	strBody = strBody & vbTab & "</head>" & vbCrLf
	strBody = strBody & vbTab & "<body>" & vbCrLf
	strBody = strBody & vbTab & vbTab & "<div>" & vbCrLf
	strBody = strBody & vbTab & vbTab & vbTab & "<h1>" & strTitle & "</h1>" & vbCrLf
	strBody = strBody & strContent & vbCrLf
	strBody = strBody & vbTab & vbTab & "</div>" & vbCrLf
	strBody = strBody & vbTab & "</body>" & vbCrLf
	strBody = strBody & "</html>" & vbCrLf
	DocumentBody = strBody
End Function

Function NCX(strTitle, strAuthor)
	Dim strNCX
	strNCX = ""
	strNCX = strNCX & "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
	'strNCX = strNCX & "<!DOCTYPE ncx PUBLIC ""-//NISO//DTD ncx 2005-1//EN http://www.daisy.org/z3986/2005/ncx-2005-1.dtd"">" & vbCrLf
	strNCX = strNCX & "<ncx xmlns=""http://www.daisy.org/z3986/2005/ncx/"" version=""2005-1"">" & vbCrLf
	strNCX = strNCX & vbTab & "<head>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & "<meta name=""dtb:uid"" content=""ebook""/>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & "<meta name=""dtb:depth"" content=""1""/>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & "<meta name=""dtb:totalPageCount"" content=""0""/>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & "<meta name=""dtb:maxPageNumber"" content=""0""/>" & vbCrLf
	strNCX = strNCX & vbTab & "</head>" & vbCrLf
	strNCX = strNCX & vbTab & "<docTitle><text>" & strTitle & "</text></docTitle>" & vbCrLf
	strNCX = strNCX & vbTab & "<navMap>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & "<navPoint id=""" & strTitle & """ playOrder=""1"">" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & "<navLabel>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & vbTab & "<text>Cover Page</text>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & "</navLabel>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & "<content src=""title.xhtml""/>" & vbCrLf
	strNCX = strNCX & vbTab &  vbTab & "</navPoint>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & "<navPoint id=""" & strTitle & """ playOrder=""2"">" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & "<navLabel>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & vbTab & "<text>" & strTitle & "</text>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & "</navLabel>" & vbCrLf
	strNCX = strNCX & vbTab & vbTab & vbTab & "<content src=""content.xhtml""/>" & vbCrLf
	strNCX = strNCX & vbTab &  vbTab & "</navPoint>" & vbCrLf
	strNCX = strNCX & vbTab & "</navMap>" & vbCrLf
	strNCX = strNCX & "</ncx>" & vbCrLf
	NCX = strNCX
End Function

Function String2File(strData, strFileName)
	'Writes a string to a file. Returns True if success.
	Dim fs 'As Scripting.FileSystemObject
	Dim ts 'As Scripting.TextStream
	Dim lngChar, strBlock, intChar, dtTimeStamp
	Const ForWriting = 2
	Set fs = CreateObject("Scripting.FileSystemObject")
	On Error Resume Next
	If fs.FileExists(strFileName) Then
		dtTimeStamp = fs.GetFile(strFileName).DateLastModified
	Else
		dtTimeStamp = CDate(0)
	End If
	Err.Clear
	Set ts = fs.OpenTextFile(strFileName, ForWriting, True, 0)
	ts.Write strData
	If Err.Number <> 0 Then
		'Must have hit one of the "problem characters" between 128 and 159
		For lngChar = 1 To Len(strData) Step 100
			Err.Clear
			ts.Write Mid(strData, lngChar, 100)
			If Err.Number <> 0 Then
				'This block of 100 must have the problem. Write them one-at-a-time
				strBlock = Mid(strData, lngChar, 100)
				For intChar = 1 To Len(strBlock)
					ts.Write Chr(255 And AscW(Mid(strBlock, intChar)))
				Next
			End If
		Next
	End If
	ts.Close
	If fs.FileExists(strFileName) Then
		If dtTimeStamp = fs.GetFile(strFileName).DateLastModified Then
			String2File = False
		Else
			String2File = True
		End If
	Else
		String2File = False
	End If
End Function

Function File2String(strFile)
	Const TristateTrue = -1 'Opens the file as Unicode.
	Const TristateFalse = 0 'Opens the file as ASCII.
	Dim fs, ts, strText, lngUnicode, lngAscii, intCount, lngLength
	Const ForReading = 1
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Make sure file exists
	If Not fs.FileExists(strFile) Then
		File2String = ""
		Exit Function
	End If
	'Make sure file is not empty
	If fs.GetFile(strFile).Size = 0 Then
		File2String = ""
		Exit Function
	End If
	'Read file as ascii and count spaces
	Set ts = fs.OpenTextFile(strFile, ForReading, True, TristateFalse)
	strText = ts.ReadAll
	ts.Close
	lngAscii = 0
	lngLength = 100
	If Len(strText) < lngLength Then lngLength = Len(strText)
	For intCount = 1 To lngLength
		If Mid(strText, intCount, 1) = " " Then lngAscii = lngAscii + 1
	Next
	'Read file as unicode and count spaces
	Set ts = fs.OpenTextFile(strFile, ForReading, True, TristateTrue)
	strText = ts.ReadAll
	ts.Close
	lngUnicode = 0
	lngLength = 100
	If Len(strText) < lngLength Then lngLength = Len(strText)
	For intCount = 1 To lngLength
		If Mid(strText, intCount, 1) = " " Then lngUnicode = lngUnicode + 1
	Next
	'Whichever way of reading generated the most spaces... Read it that way
	If lngAscii >= lngUnicode Then
		Set ts = fs.OpenTextFile(strFile, ForReading, True, TristateFalse)
		strText = ts.ReadAll
		ts.Close
	Else
		Set ts = fs.OpenTextFile(strFile, ForReading, True, TristateTrue)
		strText = ts.ReadAll
		ts.Close
		strText = ToAscii(strText)
	End If
	File2String = strText
End Function

Function FileNameInTempDir(strFileName)
'Returns the full path and file name to a file in the user's temporary directory
	Dim fs
	Const TemporaryFolder = 2
	Set fs = CreateObject("Scripting.FileSystemObject")
	FileNameInTempDir = fs.GetAbsolutePathName(fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), strFileName))
End Function

Function MostRecent(strFolderPath, strFileExtension)
'Returns the full path of the most recent file
	Dim fs, fol, fils, fil, strMostRecent
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set fol = fs.GetFolder(strFolderPath)
	Set fils = fol.Files
	strMostRecent = ""
	For Each fil In fils
		If Lcase(fs.GetExtensionName(fil.Name)) = LCase(strFileExtension) Then
			If strMostRecent = "" Then 
				strMostRecent = fil.Path
			End If
			If fil.DateLastModified > fs.GetFile(strMostRecent).DateLastModified Then
				strMostRecent = fil.Path
			End If
		End If
	Next
	MostRecent = strMostRecent
End Function

Function GetClipboard()
Dim ie
	Set ie = CreateObject("InternetExplorer.Application")
	ie.Navigate("about:blank")
	GetClipboard = ie.Document.ParentWindow.ClipboardData.GetData("text")
	ie.Quit
End Function

Sub ToggleRightClick()
Dim ws, strJPG, strTXT
	On Error Resume Next
	Set ws = CreateObject("Wscript.Shell")
	'Find the location of JPG settings
	strJPG = ""
	strJPG = ws.RegRead("HKEY_CLASSES_ROOT\.jpg\")
	'Find the location of TXT settings
	strTXT = ""
	strTXT = ws.RegRead("HKEY_CLASSES_ROOT\.txt\")
	'Will we write or clear values?
	If RightClickEnabled() Then
		'Clear Directory values
		ws.RegDelete "HKEY_CLASSES_ROOT\Directory\shell\" & DIR_RIGHT_CLICK_TEXT & "\command\"
		ws.RegDelete "HKEY_CLASSES_ROOT\Directory\shell\" & DIR_RIGHT_CLICK_TEXT & "\"
		'Clear JPG values
		If strJPG <> "" Then
			ws.RegDelete "HKEY_CLASSES_ROOT\" & strJPG & "\shell\" & JPG_RIGHT_CLICK_TEXT & "\command\"
			ws.RegDelete "HKEY_CLASSES_ROOT\" & strJPG & "\shell\" & JPG_RIGHT_CLICK_TEXT & "\"
		End If
		'Clear TXT values
		If strTXT <> "" Then
			ws.RegDelete "HKEY_CLASSES_ROOT\" & strTXT & "\shell\" & TXT_RIGHT_CLICK_TEXT & "\command\"
			ws.RegDelete "HKEY_CLASSES_ROOT\" & strTXT & "\shell\" & TXT_RIGHT_CLICK_TEXT & "\"
		End If
	Else
		'Write Directory value
		ws.RegWrite "HKEY_CLASSES_ROOT\Directory\shell\" & DIR_RIGHT_CLICK_TEXT & "\command\", "wscript.exe """ & WScript.ScriptFullName & """ ""%1""", "REG_EXPAND_SZ"
		'Write JPG value
		If strJPG <> "" Then
			ws.RegWrite "HKEY_CLASSES_ROOT\" & strJPG & "\shell\" & JPG_RIGHT_CLICK_TEXT & "\command\", "wscript.exe """ & WScript.ScriptFullName & """ ""%1""", "REG_EXPAND_SZ"
		End If
		'Write TXT value
		If strTXT <> "" Then
			ws.RegWrite "HKEY_CLASSES_ROOT\" & strTXT & "\shell\" & TXT_RIGHT_CLICK_TEXT & "\command\", "wscript.exe """ & WScript.ScriptFullName & """ ""%1""", "REG_EXPAND_SZ"
		End If
	End If
	On Error Goto 0
End Sub

Function RightClickStatus()
	If RightClickEnabled() Then
		RightClickStatus = "ENABLED"
	Else
		RightClickStatus = "DISABLED"
	End If
End Function

Function RightClickEnabled()
Dim ws, strValue
	Set ws = CreateObject("Wscript.Shell")
	strValue = ""
	On Error Resume Next
	strValue = ws.RegRead("HKEY_CLASSES_ROOT\Directory\shell\" & DIR_RIGHT_CLICK_TEXT & "\command\")
	On Error Goto 0
	RightClickEnabled = Eval("" <> strValue)
End Function

Sub Status(strMessage)
	If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then
		Wscript.Echo strMessage
	End If
End Sub


'#######################################################################################
'#################   Code below this point is used for ZIP functions   #################
'#######################################################################################

Sub Zip(strFolder)
	Dim fs, strZip, strFileName, strZipEndDirectory
	'Initialize
	strZipFileEntries = ""
	strZipDirectoryEntries = ""
	Set fs = CreateObject("Scripting.FileSystemObject")
	ProcessFolder strFolder, ""
	'Make end directory
	strZipEndDirectory = ZipEndDirectory(strZipFileEntries, strZipDirectoryEntries)
	'Concatenate everything to make a complete zip file
	strZip = strZipFileEntries & strZipDirectoryEntries & strZipEndDirectory
	'Write the zip file
	String2File strZip, fs.BuildPath(fs.GetParentFolderName(strFolder), fs.GetBaseName(strFolder) & ".zip")
End Sub

Sub ProcessFolder(strFolderName, strStoredFolderName)
'The "strFolderName" is the complete path to a folder. 
'The "strStoredFolderName" is the path that will be prefixed to that file (or folder) in the zip file
'This subroutine handles recursion of folders and directs processing of individual files
	Dim fs, fil, fol
	Set fs = CreateObject("Scripting.FileSystemObject")
	If fs.FolderExists(strFolderName) Then
		'Process each file in the folder (and make sure the "mimetype" file is first!)
		For Each fil In fs.GetFolder(strFolderName).Files
			If fil.Name = "mimetype" Then ProcessFile fil.Path, strStoredFolderName
		Next
		For Each fil In fs.GetFolder(strFolderName).Files
			If fil.Name <> "mimetype" Then ProcessFile fil.Path, strStoredFolderName
		Next
		'Recurse folders
		For Each fol In fs.GetFolder(strFolderName).SubFolders
			ProcessFile fol.Path, strStoredFolderName 'We also have to process a folder as if it were a file
			ProcessFolder fol.Path, strStoredFolderName & fs.GetFileName(fol.Name) & "/"
		Next
	End If
End Sub

Sub ProcessFile(strFileName, strStoredFolderName)
'The "strFileName" is the complete path to a file (or folder!). 
'The "strStoredFolderName" is the path that will be prefixed to that file (or folder) in the zip file
'This subroutine appends zip data to the global "strZipFileEntries" and "strZipDirectoryEntries" structures
	Dim fs, strZipFileEntry, strZipDirectoryEntry
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Make file (or folder) zip entry. 
	If fs.FileExists(strFileName) Then
		'Make a file entry
		strZipFileEntry = ZipFileEntry(strFileName, strStoredFolderName & fs.GetFileName(strFileName))
	Elseif fs.FolderExists(strFileName) Then
		'Make a folder entry 
		strZipFileEntry = ZipFileEntry(strFileName, strStoredFolderName & fs.GetFileName(strFileName) & "/")
	Else
		'If it isn't a file or folder, something is very wrong -- don't process it!
		Exit Sub
	End If
	'Make directory entry
	strZipDirectoryEntry = ZipDirectoryEntry(strZipFileEntry, strZipFileEntries)
	'Append file entry
	strZipFileEntries = strZipFileEntries & strZipFileEntry
	'Append directory entry
	strZipDirectoryEntries = strZipDirectoryEntries & strZipDirectoryEntry
End Sub

Function ZipFileEntry(strFileName, strStoredName)
'Create a zip file entry. We need the "StoredName" defined 
'because it can contain paths instead of just a file name.
	Dim fs, dt, strZip, strCRC, strFileData, strFileBaseName, strPart, strExt, blnVFAT, blnPlainText
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Figure out the file last-modified timestamp
	If fs.FileExists(strFileName) Then
		dt = fs.GetFile(strFileName).DateLastModified
	Elseif fs.FolderExists(strFileName) Then
		dt = fs.GetFolder(strFileName).DateLastModified
	Else
		dt = Now()
	End If
	'Figure out the file contents
	blnPlainText = False
	If Instr(fs.GetFileName(strFileName), ".") Then
		For Each strExt In Split(TEXT_EXTENSIONS)
			If Lcase(Right(fs.GetFileName(strFileName), Len(strExt) + 1)) = LCase("." & strExt) Then
				blnPlainText = True
			End If
		Next
	End If
	strFileData = ""
	If fs.FileExists(strFileName) Then 'Ignore folders!
		If blnPlainText Then 
			strFileData = File2String(strFileName)
		Else
			On Error Resume Next 'Security blocking adodb.stream?
			strFileData = ByteArray2Text(ReadByteArray(strFileName))
			On Error Goto 0
			If strFileData = "" Then 
				'Try reading it as text and hope for the best.
				strFileData = File2String(strFileName)
			End If
		End If 
	End If
	'Header
	strZip = "PK" & Chr(3) & Chr(4)
	'Creator Version (10=only files 20=supports folders)
	If InStr(strStoredName, "/") Then
		strZip = strZip & Chr(20)
	Else
		strZip = strZip & Chr(10)
	End If
	'Native File System (0=DOS, 14=VFAT, 20=UNKN)
	blnVFAT = False
	If UCase(strStoredName) <> strStoredName Then blnVFAT = True
	If InStr(strStoredName, " ") <> 0 Then blnVFAT = True
	For Each strPart In Split(strStoredName, "/")
		If Len(strPart) > 12 Then blnVFAT = True
		If ((Len(strPart) > 8) And (InStr(strPart, ".") = 0)) Then blnVFAT = True
		If InStr(strPart, ".") Then
			If Len(strPart) - InStr(strPart, ".") > 3 Then blnVFAT = True
		End If
	Next
	If blnVFAT Then
		'Declare VFAT file system for most things
		strZip = strZip & Chr(14)
	Else
		'Only declare DOS file system for uppercase 8.3 names and paths
		strZip = strZip & Chr(0)
	End If
	'Encryption (0=none) 
	strZip = strZip & TwoByteValue(0)
	'Compression (0=none) 
	strZip = strZip & TwoByteValue(0)
	'Time (MS-DOS format, 2-second resolution) 
	strZip = strZip & TwoByteValue(Cint(Second(dt)/2) + (32*(Minute(dt))) + (2048*(Hour(dt))))
	'Date (MS-DOS format, base year 1980)
	strZip = strZip & TwoByteValue((Day(dt)) + (32*(Month(dt))) + (512*(Year(dt) - 1980)))
	'CRC32 (in that crazy reverse order)
	strCRC = CRC32(strFileData)
	strZip = strZip & Chr("&H" & Mid(strCRC, 7, 2)) & Chr("&H" & Mid(strCRC, 5, 2)) & Chr("&H" & Mid(strCRC, 3, 2)) & Chr("&H" & Mid(strCRC, 1, 2))
	'Compressed size (Same as original size since we aren't compressing)
	strZip = strZip & FourByteValue(Len(strFileData)) 
	'Original size
	strZip = strZip & FourByteValue(Len(strFileData))
	'File name length
	strZip = strZip & TwoByteValue(Len(strStoredName))
	'Extra length
	strZip = strZip & TwoByteValue(0)
	'File name (Include directory name if using paths. Use trailing slash if directory.)
	strZip = strZip & strStoredName
	'File data (contents of file)
	strZip = strZip & strFileData
	ZipFileEntry = strZip
End Function

Function ZipDirectoryEntry(strZipFileEntry, strZipFileEntries)
'You MUST append the strZipFileEntry to strZipFileEntries AFTER this Function
'You MUST append the ZipDirectoryEntry to ZipDirectoryEntries AFTER this function
	Dim strZip, lngFileNameLength, strFileName, blnPlainText, strExt, fs
	Set fs = CreateObject("Scripting.FileSystemObject")
	lngFileNameLength = Asc(Mid(strZipFileEntry, 27, 1)) + (256 * Asc(Mid(strZipFileEntry, 28, 1) ))
	'Extract the file name
	strFileName = Mid(strZipFileEntry, 31, lngFileNameLength)
	'Figure out (again) if this is a binary or text file
	blnPlainText = False
	If Instr(fs.GetFileName(strFileName), ".") <> 0 Then
		For Each strExt In Split(TEXT_EXTENSIONS)
			If Lcase(Right(fs.GetFileName(strFileName), Len(strExt) + 1)) = LCase("." & strExt) Then
				blnPlainText = True
			End If
		Next
	End If
	'Header 
	strZip = "PK" & Chr(1) & Chr(2)
	'Creator Version (10=only files 20=supports folders)
	strZip = strZip & Mid(strZipFileEntry, 5, 2)
	'Extractor version
	strZip = strZip & Mid(strZipFileEntry, 5, 2)
	'General
	strZip = strZip & Mid(strZipFileEntry, 7, 2)
	'Compression
	strZip = strZip & Mid(strZipFileEntry, 9, 2)
	'Time
	strZip = strZip & Mid(strZipFileEntry, 11, 2)
	'Date
	strZip = strZip & Mid(strZipFileEntry, 13, 2)
	'CRC
	strZip = strZip & Mid(strZipFileEntry, 15, 4)
	'Compressed size
	strZip = strZip & Mid(strZipFileEntry, 19, 4)
	'Original size
	strZip = strZip & Mid(strZipFileEntry, 23, 4)
	'File name length
	strZip = strZip & Mid(strZipFileEntry, 27, 2)
	'Extra
	strZip = strZip & TwoByteValue(0)
	'Comment length
	strZip = strZip & TwoByteValue(0)
	'Disk number
	strZip = strZip & TwoByteValue(0)
	'Attributes (0=folder or binary, 1=text)
	If ((Not blnPlainText) Or (Right(strFileName, 1) = "/")) Then
		strZip = strZip & TwoByteValue(0)
	Else
		strZip = strZip & TwoByteValue(1)
	End If	
	'Attributes (0=none, 16=folder, 32=archive bit)
	If Right(strFileName, 1) = "/" Then
		strZip = strZip & FourByteValue(16)
	Else
		strZip = strZip & FourByteValue(0)
	End If
	'Offset 
	strZip = strZip & FourByteValue(Len(strZipFileEntries))
	'File Name
	strZip = strZip & strFileName
	'Return the result
	ZipDirectoryEntry = strZip
End Function

Function ZipEndDirectory(strZipFileEntries, strZipDirectoryEntries)
	Dim strZip, strTemp, lngEntries
	'Header 
	strZip = "PK" & Chr(5) & Chr(6)
	'Disk number
	strZip = strZip & TwoByteValue(0)
	'Starting disk
	strZip = strZip & TwoByteValue(0)
	'Number of records this disk 
	strTemp = strZipDirectoryEntries
	lngEntries = 0
	Do While InStr(strTemp, "PK" & Chr(1) & Chr(2))
		lngEntries = lngEntries + 1
		strTemp = Mid(strTemp, InStr(strTemp, "PK" & Chr(1) & Chr(2)) + 4)
	Loop
	strZip = strZip & TwoByteValue(lngEntries)
	'Total records all disks
	strZip = strZip & TwoByteValue(lngEntries)
	'Directory size
	strZip = strZip & FourByteValue(Len(strZipDirectoryEntries)) 
	'Directory offset start
	strZip = strZip & FourByteValue(Len(strZipFileEntries))
	'Comment length
	strZip = strZip & TwoByteValue(0)
	'Return a value
	ZipEndDirectory = strZip
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

Function ByteArray2Text(varByteArray)
'Convert byte array into a string with ADODB.Recordset
Dim rs
Const adLongVarChar = 201
    Set rs = CreateObject("ADODB.Recordset")
    rs.Fields.Append "temp", adLongVarChar, LenB(varByteArray)
    rs.Open
    rs.AddNew
    rs("temp").AppendChunk varByteArray
    rs.Update
    ByteArray2Text = rs("temp")
    rs.Close
    Set rs = Nothing
End Function

Function FourByteValue(lngNumber)
'Returns little-endian byte order of a number
	Dim strValue
	strValue = ""
	strValue = strValue & Chr(lngNumber And 255)
	strValue = strValue & Chr((lngNumber \ 256) And 255)
	strValue = strValue & Chr((lngNumber \ (256 * 256)) And 255)
	strValue = strValue & Chr((lngNumber \ (256 * 256 * 256)) And 255)
	FourByteValue = strValue
End Function

Function TwoByteValue(lngNumber)
'Returns little-endian byte order of a number
	Dim strValue
	strValue = ""
	strValue = strValue & Chr(lngNumber And 255)
	strValue = strValue & Chr((lngNumber \ 256) And 255)
	TwoByteValue = strValue
End Function

Function CRC32(strData)
	'A major rewrite of CCalcCRC32 class originally from and copyrighted by Dave Rayment 1999 <d_rayme@hotmailnospam.com>
	Dim strCrc, lngCRC, intCount, lngLookup(256)
	strCrc = "0000000077073096EE0E612C990951BA076DC419706AF48FE963A5359E6495A30EDB883279DCB8A4E0D5E91E97D2D98809B64C2B7EB17CBDE7B82D0790BF1D91"
	strCrc = strCrc & "1DB710646AB020F2F3B9714884BE41DE1ADAD47D6DDDE4EBF4D4B55183D385C7136C9856646BA8C0FD62F97A8A65C9EC14015C4F63066CD9FA0F3D638D080DF5"
	strCrc = strCrc & "3B6E20C84C69105ED56041E4A26771723C03E4D14B04D447D20D85FDA50AB56B35B5A8FA42B2986CDBBBC9D6ACBCF94032D86CE345DF5C75DCD60DCFABD13D59"
	strCrc = strCrc & "26D930AC51DE003AC8D75180BFD0611621B4F4B556B3C423CFBA9599B8BDA50F2802B89E5F058808C60CD9B2B10BE9242F6F7C8758684C11C1611DABB6662D3D"
	strCrc = strCrc & "76DC419001DB710698D220BCEFD5102A71B1858906B6B51F9FBFE4A5E8B8D4337807C9A20F00F9349609A88EE10E98187F6A0DBB086D3D2D91646C97E6635C01"
	strCrc = strCrc & "6B6B51F41C6C6162856530D8F262004E6C0695ED1B01A57B8208F4C1F50FC45765B0D9C612B7E9508BBEB8EAFCB9887C62DD1DDF15DA2D498CD37CF3FBD44C65"
	strCrc = strCrc & "4DB261583AB551CEA3BC0074D4BB30E24ADFA5413DD895D7A4D1C46DD3D6F4FB4369E96A346ED9FCAD678846DA60B8D044042D7333031DE5AA0A4C5FDD0D7CC9"
	strCrc = strCrc & "5005713C270241AABE0B1010C90C20865768B525206F85B3B966D409CE61E49F5EDEF90E29D9C998B0D09822C7D7A8B459B33D172EB40D81B7BD5C3BC0BA6CAD"
	strCrc = strCrc & "EDB883209ABFB3B603B6E20C74B1D29AEAD547399DD277AF04DB261573DC1683E3630B1294643B840D6D6A3E7A6A5AA8E40ECF0B9309FF9D0A00AE277D079EB1"
	strCrc = strCrc & "F00F93448708A3D21E01F2686906C2FEF762575D806567CB196C36716E6B06E7FED41B7689D32BE010DA7A5A67DD4ACCF9B9DF6F8EBEEFF917B7BE4360B08ED5"
	strCrc = strCrc & "D6D6A3E8A1D1937E38D8C2C44FDFF252D1BB67F1A6BC57673FB506DD48B2364BD80D2BDAAF0A1B4C36034AF641047A60DF60EFC3A867DF55316E8EEF4669BE79"
	strCrc = strCrc & "CB61B38CBC66831A256FD2A05268E236CC0C7795BB0B4703220216B95505262FC5BA3BBEB2BD0B282BB45A925CB36A04C2D7FFA7B5D0CF312CD99E8B5BDEAE1D"
	strCrc = strCrc & "9B64C2B0EC63F226756AA39C026D930A9C0906A9EB0E363F720767850500571395BF4A82E2B87A147BB12BAE0CB61B3892D28E9BE5D5BE0D7CDCEFB70BDBDF21"
	strCrc = strCrc & "86D3D2D4F1D4E24268DDB3F81FDA836E81BE16CDF6B9265B6FB077E118B7477788085AE6FF0F6A7066063BCA11010B5C8F659EFFF862AE69616BFFD3166CCF45"
	strCrc = strCrc & "A00AE278D70DD2EE4E0483543903B3C2A7672661D06016F74969474D3E6E77DBAED16A4AD9D65ADC40DF0B6637D83BF0A9BCAE53DEBB9EC547B2CF7F30B5FFE9"
	strCrc = strCrc & "BDBDF21CCABAC28A53B3933024B4A3A6BAD03605CDD7069354DE572923D967BFB3667A2EC4614AB85D681B022A6F2B94B40BBE37C30C8EA15A05DF1B2D02EF8D"
	For intCount = 0 To 255
		lngLookup(intCount) = CLng("&H" & Mid(strCrc, (1 + (intCount * 8)), 8))
	Next
	lngCRC = &HFFFFFFFF
	For intCount = 1 To Len(strData)
		lngCRC = (Int(lngCRC / 256) And &HFFFFFF) Xor (lngLookup((lngCRC Xor Asc(Mid(strData, intCount, 1))) And &HFF))
	Next
	CRC32 = Right("00000000" & Hex(Not lngCRC), 8)
End Function