'Converts text files to uncompressed .PDB format
'Usage:
'[cscript.exe|wscript.exe] makedoc.vbs [-c#] <text-file> [pdb-file] [story-name]
'  -c# option marks the data for category # (0...15) default:0
'  pdb-file default is same as text-file except with .pdb
'  story-name default is root name of text-file
'  pdb-file will be overwritten if it already exists.

Option Explicit

Main

Sub Main
Dim fs
Dim strPlainText, strPdbText, strMessage
Dim strPlainFile, strPdbFile, strTitle
Dim intArg, intCategory
	If WScript.Arguments.Count < 1 Then
		Help
		WScript.Quit
	End If
	'Set initial values
	intCategory = 0
	strPlainFile = ""
	strPdbFile = ""
	strTitle = ""
	'Check all arguments for the category argument
	For intArg = 0 To WScript.Arguments.Count - 1
		If Lcase(Left(WScript.Arguments(intArg), 2)) = "-c" Then
			If Len(WScript.Arguments(intArg)) > 2 And Len(WScript.Arguments(intArg)) < 5 Then
				If IsNumeric(Mid(WScript.Arguments(intArg), 3)) Then
					intCategory = Cint(Mid(WScript.Arguments(intArg), 3))
				End If
			End If
		End If
	Next
	'Check the category
	If intCategory < 0 Or intCategory > 15 Then
		Help
		WScript.Quit
	End If
	'Get the main arguments
	For intArg = 0 To WScript.Arguments.Count - 1
		If Lcase(Left(WScript.Arguments(intArg), 2)) = "-c" Then
			If Len(WScript.Arguments(intArg)) > 2 And Len(WScript.Arguments(intArg)) < 5 Then
				If Not(IsNumeric(Mid(WScript.Arguments(intArg), 3))) Then
					If strPlainFile = "" Then 
						strPlainFile = WScript.Arguments(intArg)
					ElseIf strPdbFile = "" Then 
						strPdbFile = WScript.Arguments(intArg)
					ElseIf strTitle = "" Then
						strTitle = WScript.Arguments(intArg)
					End If
				End If
			Else
				If strPlainFile = "" Then 
					strPlainFile = WScript.Arguments(intArg)
				ElseIf strPdbFile = "" Then 
					strPdbFile = WScript.Arguments(intArg)
				ElseIf strTitle = "" Then
					strTitle = WScript.Arguments(intArg)
				End If
			End If
		Else
			If strPlainFile = "" Then 
				strPlainFile = WScript.Arguments(intArg)
			ElseIf strPdbFile = "" Then 
				strPdbFile = WScript.Arguments(intArg)
			ElseIf strTitle = "" Then
				strTitle = WScript.Arguments(intArg)
			End If
		End If
	Next
	'Check the plain file
	If strPlainFile = "" Then
		Help
		WScript.Quit
	End If
	Set fs = CreateObject("Scripting.FileSystemObject")
	If InStr(strPlainFile, ":\") = 0 Then
		strPlainFile = FileNameInCurDir(strPlainFile)
	End If
	If Not fs.FileExists(strPlainFile) Then 
		WScript.Echo """" & strPlainFile & """ doesn't exist"
		WScript.Quit
	End If
	'Check the pdb file
	If strPdbFile = "" Then
		If Len(strPlainFile) - InStrRev(strPlainFile, ".") < 4 Then
			strPdbFile = Left(strPlainFile, InStrRev(strPlainFile, ".")) & "pdb"
		Else
			strPdbFile = strPlainFile & ".pdb"
		End If
	End If
	If InStr(strPdbFile, ":\") = 0 Then
		strPdbFile = FileNameInCurDir(strPdbFile)
	End If
	If fs.FileExists(strPdbFile) Then
			fs.DeleteFile strPdbFile
	End If
	'Check the title
	If strTitle = "" Then
		strTitle = Mid(strPlainFile, InStrRev(strPlainFile, "\") + 1)
		If InStr(strTitle, ".") > 3 Then strTitle = Left(strTitle, InStr(strTitle, ".") - 1)
	End If
	If Len(strTitle) > 31 Then strTitle = Left(strTitle, 31)
	'Run the conversion routine
	Status ""
	Status Ucase(WScript.ScriptName) & " Version 1.1"
	Status "http://www.ericphelps.com"
	Status "Source Code Released to Public Domain -- No Warranty" 
	Status "Saving to """ & strPdbFile & """"
	Status "Saving as <" & strTitle & ">, uncompressed, category <" & intCategory & ">."
	strPlainText = File2String(strPlainFile)
	strPdbText = Txt2Pdb(strPlainText, strTitle, intCategory)
	String2File strPdbText, strPdbFile
	Status "Converted " & (Len(strPlainText) \ 4096) + 2 & " records."
	'Give a finished message to people using WSCRIPT
	If Lcase(Right(Wscript.FullName, 12)) = "\wscript.exe" Then
		strMessage = Ucase(WScript.ScriptName) & " Version 1"
		strMessage = strMessage & vbCrLf & "http://www.ericphelps.com"
		strMessage = strMessage & vbCrLf & "Source Code Released to Public Domain -- No Warranty" 
		strMessage = strMessage & vbCrLf & "Saved to """ & strPdbFile & """"
		strMessage = strMessage & vbCrLf & "Saved as <" & strTitle & ">, uncompressed, category <" & intCategory & ">."
		strMessage = strMessage & vbCrLf & "Converted " & (Len(strPlainText) \ 4096) + 2 & " records."
		CreateObject("Wscript.Shell").Popup strMessage, 15, "Finished"
	End If
End Sub

Sub Help
Dim strHelp
	strHelp = WScript.ScriptName & " converts text files to uncompressed .PDB format" & vbCrLf
	strHelp = strHelp & "[cscript.exe|wscript.exe] " & WScript.ScriptName 
	strHelp = strHelp & " [-c#] <text-file> [pdb-file] [story-name]" & vbCrLf
	strHelp = strHelp & "	  -c# option marks the data for category # (0...15) default:0" & vbCrLf
	strHelp = strHelp & "	  pdb-file default is same as text-file except with .pdb" & vbCrLf
	strHelp = strHelp & "	  story-name default is root name of text-file" & vbCrLf
	strHelp = strHelp & "	  pdb-file will be overwritten if it already exists."
	WScript.Echo strHelp
End Sub


Function Txt2Pdb(ByRef strText, strTitle, intCategory)
Dim strIn, strOut
Dim intRecords, intCounter
Dim dblSize, dblRecordOffset, dblTime
'Simplified PDB DOC format:
'Pdb Title				32
'Pdb Header			   48
'Record Offset 1		   8
'Record Offset 2		   8
'Record Offset N		   8
'Padding				   2
'Record 1 Doc Header	  16
'Record 2 Doc Data 1	4096
'Record N Doc Data N-1  4096
	strIn = strText
	'Title (Offset 0, Length 32)
	strOut = Left(strTitle, 31) & String(32 - Len(Left(strTitle, 31)), Chr(0))
	'Attributes (Offset 32) &H2=Read only &H8=Backup &H10=install over existing &H20=reset after install
	strOut = strOut & String(2, Chr(0))
	'Version (Offset 34)
	strOut = strOut & String(2, Chr(0))
	'Create Time (Offset 36) 'Seconds since Jan 1, 1970
	strOut = strOut & FourBytes(Round((Now - #1/1/1970#) * 24 * 60 * 60, 0))
	'Modify Time (Offset 40) 'Seconds since Jan 1, 1970
	strOut = strOut & FourBytes(Round((Now - #1/1/1970#) * 24 * 60 * 60, 0))
	'Backup Time (Offset 44) 'Zero if never backed up
	strOut = strOut & String(4, Chr(0))
	'Modification Number (Offset 48)
	strOut = strOut & String(4, Chr(0))
	'App Info ID (Offset 52)
	strOut = strOut & String(4, Chr(0))
	'Sort Info ID (Offset 56)
	strOut = strOut & String(4, Chr(0))
	'Type (Offset 60)
	strOut = strOut & "TEXt"
	'Creator (Offset 64)
	strOut = strOut & "REAd"
	'ID Seed (Offset 68)
	strOut = strOut & String(4, Chr(0))
	'Next Record List (Offset 72)
	strOut = strOut & String(4, Chr(0))
	'Number of Records (Offset 76)
	intRecords = (Len(strIn) \ 4096) + 2
	strOut = strOut & TwoBytes(intRecords)
	'Record List (Offset 78) 8 bytes describing each record
	For intCounter = 1 To intRecords
		'The first record is a 16-byte DOC header
		dblRecordOffset = 78 + 2 + (intRecords * 8)
		If intCounter > 1 Then
			'Records 2 thru N are data records
			dblRecordOffset = dblRecordOffset + 16 + (intCounter - 2) * 4096
		End If
		strOut = strOut & FourBytes(dblRecordOffset) 'Record offset
		strOut = strOut & Chr(64 Or intCategory) 'delete dirty busy secret category
		strOut = strOut & "o" & TwoBytes((intCounter - 1) Or 32768) 'Unique ID
	Next
	'Two-byte padding
	strOut = strOut & String(2, Chr(0))
	'---------- RECORD 1 (DOC HEADER) ----------
	'Version
	strOut = strOut & Chr(0) & Chr(1) '1=plain, 2=compressed
	'Reserved1	
	strOut = strOut & Chr(0) & Chr(0)
	'Document Size (uncompressed)
	strOut = strOut & FourBytes(Len(strText))
	'Number of Records
	strOut = strOut & TwoBytes(intRecords - 1)
	'Record Size
	strOut = strOut & TwoBytes(4096) '4096
	'Reserved
	strOut = strOut & String(4, Chr(0))
	'---------- THE DOCUMENT ----------
	strOut = strOut & strText
	Txt2Pdb = strOut
End Function

Function FourBytes(dblNumber) 'As String
Dim strOut
	strOut = Chr(dblNumber \ 16777216)
	strOut = strOut & Chr((dblNumber And 16711680) \ 65536)
	strOut = strOut & Chr((dblNumber And 65280) \ 256)
	strOut = strOut & Chr(dblNumber And 255)
	FourBytes = strOut
End Function

Function TwoBytes(lngNumber) 'As String
Dim strOut
	strOut = Chr((lngNumber And 65280) \ 256)
	strOut = strOut & Chr(lngNumber And 255)
	TwoBytes = strOut
End Function

Sub String2File(strData, strFileName)
'Writes a string to a file
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Const ForWriting = 2
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set ts = fs.OpenTextFile(strFileName, ForWriting, True)
	ts.Write(strData)
	'Clean up
	ts.Close
	Set ts = Nothing
	Set fs = Nothing
End Sub

Function File2String(strFile) 'As String
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Const ForReading = 1
	Set fs = CreateObject("Scripting.FileSystemObject")
	If fs.FileExists(strFile) Then
		Set ts = fs.OpenTextFile(strFile, ForReading, True)
		If ts.AtEndOfStream Then
			File2String =""
		Else
			File2String = ts.ReadAll
		End If
		ts.Close
	Else
		File2String = ""
	End If
End Function

Function FileNameInCurDir(strFileName) 'As String
'Returns the complete path and file name to a file in
'the current directory. For example, "trans.log" might
'return "C:\Windows\Desktop\trans.log"
'if the current directory was "C:\Windows\Desktop"
Dim fs 'As Object
	Set fs = Wscript.CreateObject("Scripting.FileSystemObject")
	 FileNameInCurDir = fs.GetAbsolutePathName(fs.BuildPath(fs.GetFolder(".").Path, strFileName))
	''''''''''Clean up
	Set fs = Nothing
End Function

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