'ConvertCSVtoXML.vbs
'Jeffery Hicks
'v1.0 November 2005
'jhicks@jdhitsolutions.com 
'http://www.jdhitsolutions.com

'Keywords: XML,ADODB,CSV,FileSystemObject,XMLDOM

'Usage: cscript|wscript ConvertCSVtoXML.vbs

'Notes: You will be prompted to find the CSV file to convert and a
'name of an xml file to create.  This script requires Windows XP.

'The script assumes the first line of the csv file is for headings.
'Using ADODB, the script parses out the headings and creates an
'<ITEM> tag for each line of the csv file.  Within each <ITEM>
'tag are child tags for each heading.  If no value is found for
'a heading in a particular line, then the XML text for that heading
'is set to '.'.  Otherwise, the tag doesn't get closed properly.

'The OpenFile dialog box doesn't have a csv filter, but if you
'type in *.csv and click Open, the dialog box will refresh And
'present a filtered view.

On Error Resume Next
'convert CVS file to XML format
Dim objFSO
dim objXML
Dim objRoot
Dim objNode
Dim objAttrib
Dim objChildNode
Dim objConnection, objRecordset,objFields

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001

strSource=OpenFilePath()	'You must return a full filename and path for the source CSV file.
strXMLFile=SaveAs("demo.xml")	'Specify the name of the XML file to create.

Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")

Set objFSO=CreateObject("Scripting.FileSystemObject")

'verify csv file exists just in case someone manually typed in a filename and path.
If objFSO.FileExists(strSource) Then
	tmpArray=Split(GetFilePath(strSource),",")
	strPathtoTextFile = tmpArray(0)
	strFile=tmpArray(1)
	'if path component not defined then exit script
	If strPathtoTextFile=" " Then
		WScript.Echo "Can't determine path to " & strSource & "."
		WScript.Quit
	End If
	
	objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & strPathtoTextFile & ";" & _
          "Extended Properties=""text;HDR=YES;FMT=Delimited"""

	objRecordset.Open "SELECT * FROM " & strFile, _
          objConnection, adOpenStatic, adLockOptimistic, adCmdText

	'Create XML document
	SET objXML = CreateObject("Microsoft.XMLDOM")
	set objRoot=objXML.createNode("element","Main","")
	objXML.appendChild(objRoot)
	set objAttrib=objXML.createAttribute("Created") 
	objXML.documentElement.setAttribute "Created",Now
	set objAttrib=objXML.createAttribute("Source") 
	objXML.documentElement.setAttribute "Source",strSource
	
	Set objFields=objRecordset.Fields
	Do Until objRecordset.EOF
	'Create an "Item" tag for each entry in the file
	Set objNode=objXML.createNode("Element","Item","")
		objRoot.appendChild(objNode)
		
	For z=0 To objFields.Count-1
		strHeading=objFields.Item(z).name 
		'WScript.Echo "Adding element for " & strHeading
		Set objChildNode=objXML.createNode("Element",strHeading,"")
		'if value in CSV is blank 
		If IsNull(objRecordset.Fields(strHeading)) Then 
			strText="." 'we'll use a . so that the tag closes
		Else
			strText=objRecordset.Fields(strHeading)
		End If
		'set the value of the child node
		objChildNode.text=strText
		objNode.appendChild objChildNode
	Next
	objRecordset.MoveNext
	Loop
	objConnection.Close
	'commit XML changes to disk
	objXML.save(strXMLfile)

	'display a summary message
	WScript.Echo "Converted " & strSource & " to " & strXMLFile
Else
	'display error message and quit script
    WScript.Echo "Failed to find " & strSource
	WScript.quit
End If

WScript.Quit

'//////////////////////////////////////////////
'parse filename from path function
'//////////////////////////////////////////////
Function GetFilePath(strFile)
'returns an csv array of path component and file component
On Error Resume Next
strTmp=StrReverse(strFile)
strFileName=Left(strTmp,InStr(strTmp,"\")-1)
strFileName=StrReverse(strFileName)
strPath=Mid(strTmp,InStr(strTmp,"\"))
strPath=StrReverse(strPath)
GetFilePath=strPath & "," & strFileName

End Function

'//////////////////////////////////////////////
'Present OpenFile dialog box and return filename
'with path
'//////////////////////////////////////////////

Function OpenFilePath()

On Error Resume Next
Dim objDialog
Set objDialog=CreateObject("SAFRCFileDlg.FileOpen")

objDialog.OpenFileOpenDlg
srcFile=objDialog.FileName

OpenFilePath=srcFile
End Function

'//////////////////////////////////////////////
'Present the SaveAs dialogbox and return 
'filename with path
'//////////////////////////////////////////////

Function SaveAs(strFile)
'requires Windows XP or later
Dim objDialog
Set objDialog=CreateObject("SAFRCFileDlg.FileSave")

objDialog.filename=strFile
objDialog.OpenFileSaveDlg
SaveAs=objDialog.FileName

End function