Option Explicit
'This script will convert an Access query needing a single parameter into a 
'Palm PDB file. Pass it the mdb file, query name, param, and pdb file name.
'This program REQUIRES that the CSV2PDB program be in the path or 
'or current directory. Look for CSV2PDB and the Palm DB program here:
' http://sourceforge.net/projects/pilot-db/
' http://pilot-db.sourceforge.net/
' http://sourceforge.net/projects/palm-db-tools/
' http://www.palmgear.com/software/showsoftware.cfm?sid=11533120000911185647&prodID=5139
' http://www.palmgear.com/software/showsoftware.cfm?sid=11533120000911185647&prodID=2175

Public Const FIRST_COL_WIDTH = "45"
Public Const DEFAULT_COL_WIDTH = "50"

Main

Sub Main
Dim strMdbFile 'As String
Dim strTextFile 'As String
Dim strPdbFile 'As String
Dim strPdbTitle 'As String
Dim strTabFile 'As String
Dim strInfoFile 'As String
Dim strQuery 'As String
Dim strOutput 'As String
Dim strData 'As String
Dim strParameter 'As String
Dim intField 'As Integer
Dim intView 'As Integer
Dim fs 'As Scripting.FileSystemObject
Dim dbeng 'As DAO.DBEngine
Dim db 'As Database
Dim rs 'As Recordset
Dim qry 'As Query
Dim ts 'As Scripting.TextStream
Dim wsh 'As WScript.Shell
Const dbOpenDynaset = 2 'DAO.RecordsetTypeEnum
Const ForWriting = 2
Const TemporaryFolder = 2
Const dbBoolean = 1
Const dbInteger = 3
Const dbLong = 4
Const dbDate = 8
Const dbDouble = 7
Const dbText = 10
Const dbMemo = 12
Const dbNumeric = 19
Const dbTime = 22

	'Create other objects
	Set fs = Wscript.CreateObject("Scripting.FileSystemObject")
	Set wsh = CreateObject("WScript.Shell")

	'Check for arguments
	If Wscript.Arguments.Count < 4 Then
		CreateObject("Wscript.Shell").Popup "This script will export an Access query to Palm PDB format. Pass it the output PDB file name, the PDB document title, mdb file name, query or table name, and optionally a single query parameter.", 10
		Wscript.Quit 1
	End If
	
	'Get output pdb file name
	strPdbFile = Wscript.Arguments(0)
	If strPdbFile = "" Then strPdbFile = FileNameLikeMine("pdb")
	If instr(strPdbFile, ":\") = 0 Then strPdbFile = FileNameInThisDir(strPdbFile)
	'Get Palm DB title
	strPdbTitle = Trim(Left(Trim(Wscript.Arguments(1)), 31))
	'Get database file name
	strMdbFile = Wscript.Arguments(2)
	If strMdbFile = "" Then strMdbFile = Dir("mdb")
	If instr(strMdbFile, ":\") = 0 Then strMdbFile = FileNameInThisDir(strMdbFile)
	'Get query or table name
	strQuery = Wscript.Arguments(3)
	'Get optional parameter value
	If Wscript.Arguments.Count = 5 Then
		If Trim(Wscript.Arguments(4)) <> "" Then
			strParameter = Wscript.Arguments(4)
		Else
			strParameter = ""
		End If
	Else
		strParameter = ""
	End If
	'Get temporary file name for tab-delimited text
	strTabFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), "mdb2pdb.tab")
	'Get temporary file name for info text
	strInfoFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), "mdb2pdb.nfo")

	'Open the database
	Set dbeng = CreateObject("DAO.DBEngine.35")
	Set db = dbeng.OpenDatabase(strMdbFile)
	If strParameter = "" Then
		Set rs = db.OpenRecordset(strQuery, dbOpenDynaset)
	Else
		Set qry = Db.QueryDefs(strQuery)
		Select Case qry.Parameters(0).Type
			Case dbBoolean
				qry.Parameters(0) = CBool(strParameter)
			Case dbInteger
				qry.Parameters(0) = Cint(strParameter)
			Case dbLong
				qry.Parameters(0) = Clng(strParameter)
			Case dbDate
				qry.Parameters(0) = Cdate(strParameter)
			Case dbDouble
				qry.Parameters(0) = Cdbl(strParameter)
			Case dbText
				qry.Parameters(0) = Cstr(strParameter)
			Case dbMemo
				qry.Parameters(0) = Cstr(strParameter)
			Case dbNumeric
				qry.Parameters(0) = Cdbl(strParameter)
			Case dbTime
				qry.Parameters(0) = Cdate(strParameter)
			Case Else
				qry.Parameters(0) = strParameter
		End Select
		Set rs = qry.OpenRecordset(dbOpenDynaset)
	End If
	If rs.EOF And rs.BOF Then
		Exit Sub
	End If
	rs.MoveLast
	rs.MoveFirst
	
	'Open the "Info" text file
	Set ts = fs.OpenTextFile(strInfoFile, ForWriting, True)
	'Write the info file headers
	ts.WriteLine "title " & Chr(34) & strPdbTitle & Chr(34)
	For intField = 0 to rs.Fields.Count - 1
		ts.Write "field " & Chr(34) & Left(rs.Fields(intField).Name, 31) & Chr(34)
		ts.Write " string" & vbCrLf
	Next
	'Create the default info file "View"
	ts.Write "view " & Chr(34) & "All Fields" & Chr(34)
	'Write the first (45-pixel) column
	ts.Write " " & Chr(34) & Left(rs.Fields(0).Name, 31) & Chr(34) & " " & FIRST_COL_WIDTH
	'Write the rest of the columns
	For intField = 1 to rs.Fields.Count - 1
		ts.Write " " & Chr(34) & Left(rs.Fields(intField).Name, 31) & Chr(34) & " " & DEFAULT_COL_WIDTH
	Next
	ts.Write vbCrLf
	'Create all other views (assuming the first column/field always stays first!)
	For intView = 2 to rs.Fields.Count - 1
		ts.Write "view " & Chr(34) & Left(rs.Fields(intView).Name, 31) & Chr(34)
		'The first field
		ts.Write " " & Chr(34) & Left(rs.Fields(0).Name, 31) & Chr(34) & " " & FIRST_COL_WIDTH
		'The "view" field thru to the end
		For intField = intView to rs.Fields.Count - 1
			ts.Write " " & Chr(34) & Left(rs.Fields(intField).Name, 31) & Chr(34) & " " & DEFAULT_COL_WIDTH
		Next
		'Wrapping around, the second field thru to the view field
		For intField = 1 to intView - 1
			ts.Write " " & Chr(34) & Left(rs.Fields(intField).Name, 31) & Chr(34) & " " & DEFAULT_COL_WIDTH
		Next
		ts.Write vbCrLf
	Next
	'Finish the Info file
	ts.WriteLine "option backup false"
	ts.Write "extended on"
	ts.Close
		
	'Open the output tab-formatted text file
	Set ts = fs.OpenTextFile(strTabFile, ForWriting, True)
	Do until rs.EOF
		strData = ""
		'Get table data
		For intField = 0 to rs.Fields.Count - 1
			If Not IsNull(rs.Fields(intField).Value) Then
				If rs.Fields(intField).Value <> "" Then
					strData = strData & DbEscape(rs.Fields(intField).Value)
				End If
			End If
			If intField <> rs.Fields.Count - 1 Then
				strData = strData & Chr(127)
			End If
		Next
		ts.WriteLine strData
		rs.MoveNext
	Loop
	ts.Close
	rs.Close
	db.Close
	
	'Convert the "info" file and "tab" file into DB PDB
	If fs.FileExists(strPdbFile) Then fs.DeleteFile strPdbFile
	wsh.Run "CSV2PDB.EXE -e -s " & Chr(127) & " -i" _
	& " """ & strInfoFile & """" _
	& " """ & strTabFile & """" _
	& " """ & strPdbFile & """", 0, True
	'Delete temp files
	If fs.FileExists(strInfoFile) Then fs.DeleteFile strInfoFile
	If fs.FileExists(strTabFile) Then fs.DeleteFile strTabFile
	'Make sure it ran okay
	If Not fs.FileExists(FileNameLikeMine("pdb")) Then
		Wscript.Quit 1
	End If
End Sub

Function DbEscape(strString) 'As String
'Escape text to make it Palm DB compatible
Dim strData
On Error Resume Next
	strData = strString
	strData = Replace(strData, "\", "\\")
	strData = Replace(strData, Chr(127), " ")
	strData = Replace(strData, vbCrLf, "\n")
	strData = Replace(strData, vbCr, "\n")
	strData = Replace(strData, vbLf, "\n")
	strData = Replace(strData, vbTab, "\t")
	strData = Replace(strData, Chr(34), "\" & Chr(34))
	strData = Replace(strData, "'", "\'")
	DbEscape = strData
End Function

Function FileNameInThisDir(strFileName) 'As String
'Returns the complete path and file name to a file in
'the script directory. For example, "trans.log" might
'return "C:\Program Files\Scripts\Database\trans.log"
'if the script was in the "C:\Program Files\Scripts\Database"
'directory.
Dim fs 'As Object
	Set fs = Wscript.CreateObject("Scripting.FileSystemObject")
	 FileNameInThisDir = fs.GetAbsolutePathName(fs.BuildPath(Wscript.ScriptFullName, "..\" & strFileName))
	''''''''''Clean up
	Set fs = Nothing
End Function

Function FileNameLikeMine(strFileExtension) 'As String
'Returns a file name the same as the script name except
'for the file extension. 
Dim fs 'As Object
Dim strExtension 'As String
	Set fs = Wscript.CreateObject("Scripting.FileSystemObject")
	strExtension = strFileExtension
	If Len(strExtension) < 1 Then strExtension = "txt"
	If strExtension = "." Then strExtension = "txt"
	If Left(strExtension,1) = "." Then strExtension = Mid(strExtension, 2)
	FileNameLikeMine = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & strExtension
	''''''''''Clean up
	Set fs = Nothing
End Function

Function Dir(strFileExtension) 'As String
'Returns the complete path and file name of a file 
'in the script directory with the matching extension
'Dir("mdb") might return "C:\MYDOCU~1\TestFile.mdb"
Dim fs 'As Scripting.FileSystemObject
Dim strDir
Dim fil 'As Scripting.Files
Dim fils 'As Scripting.File
	Set fs = Wscript.CreateObject("Scripting.FileSystemObject")
	Set fils = fs.GetFolder(fs.BuildPath(Wscript.ScriptFullName, "..\")).Files
	For each fil in fils
		If Lcase(Right(fil.name, Len(strFileExtension) + 1)) = "." & Lcase(strFileExtension) Then 
			strDir = fil.Path
		End If
	Next
	Dir = strDir
End Function