Source code for excel2xml.vbs

```
Option Explicit
```
```
 
```
```
Dim arrSheet, arrHdrRow
```

Dim blnBackup, blnHeader, blnColumns, blnRows, blnWorksheet

```
Dim dtmNow
```

Dim intColumns, intRows, intTest, intValidArgs, i, j

Dim objFSO, objXML, xmlChildNode, xmlNode, xmlRoot

Dim strBackupFile, strDateTime, strExcelFile, strFileName

Dim strItemName, strListName, strParentDir, strVersion

Dim strWorksheet, strXMLBackup, strXMLFile, strXMLFolder

```
 
```
```
strVersion = "1.21"
```
```
 
```
```
' Required objects
```

Set objFSO = CreateObject( "Scripting.FileSystemObject" )

Set objXML = CreateObject( "Microsoft.XMLDOM" )

```
 
```
```
' Default values
```

strParentDir = objFSO.GetParentFolderName( WScript.ScriptFullName )

strFileName  = objFSO.GetBaseName( WScript.ScriptName )

```
 
```
```
' Parse optional command line arguments
```

If WScript.Arguments.Unnamed.Count > 0 Then Syntax

```
With WScript.Arguments.Named
```
```
	If .Count = 0 Then
```
```
		Syntax ""
```
```
	End If
```
```
	intValidArgs = 0
```
```
	If .Exists( "B" ) Then
```
```
		blnBackup    = True
```
```
		dtmNow       = Now
```

		strDateTime  = DatePart( "yyyy", dtmNow ) _

		             & Right( "0" & DatePart( "m", dtmNow ), 2 ) _

		             & Right( "0" & DatePart( "d", dtmNow ), 2 ) _

		             & Right( "0" & DatePart( "h", dtmNow ), 2 ) _

		             & Right( "0" & DatePart( "n", dtmNow ), 2 ) _

		             & Right( "0" & DatePart( "s", dtmNow ), 2 )

```
		intValidArgs = intValidArgs + 1
```
```
	Else
```
```
		blnBackup    = False
```
```
	End If
```
```
	If .Exists( "C" ) Then
```
```
		If IsNumeric( .Item( "C" ) ) Then
```
```
			intColumns   = CInt( .Item( "C" ) )
```

			If intColumns < 1 Or intColumns - .Item( "C" ) <> 0 Then

				Syntax "Specify an integer number with /C switch"

```
			End If
```
```
			blnColumns   = True
```
```
			intValidArgs = intValidArgs + 1
```
```
		Else
```

			strErrorMsg = "Specify a number of columns with /C switch"

```
			Syntax
```
```
		End If
```
```
	Else
```
```
		blnColumns = False
```
```
	End If
```
```
	If .Exists( "E" ) Then
```
```
		If .Item( "E" ) = "" Then
```

			Syntax "Excel file name required with /E switch"

```
		Else
```

			If objFSO.FileExists( .Item( "E" ) ) Then

				strExcelFile = objFSO.GetAbsolutePathName( .Item( "E" ) )

```
				intValidArgs = intValidArgs + 1
```
```
			Else
```

				Syntax "Specified Excel file not found"

```
			End If
```
```
		End If
```
```
	Else
```

		strExcelFile = objFSO.BuildPath( strParentDir, strFileName & ".xls" )

```
	End If
```
```
	If .Exists( "I" ) Then
```
```
		strItemName  = .Item( "I" )
```
```
		If strItemName = "" Then
```

			Syntax "Item name required with /I switch"

```
		End If
```
```
		For i = 1 To Len( strItemName )
```

			intTest = Asc( Mid( UCase( strItemName ), i, 1 ) )

			If intTest < 48 Or intTest > 90 Or ( intTest > 57 And intTest < 65 ) Then

				Syntax "Use letters and numbers only for XML item names"

```
			End If
```
```
		Next
```
```
		intValidArgs = intValidArgs + 1
```
```
	Else
```
```
		strItemName  = "Item"
```
```
	End If
```
```
	If .Exists( "L" ) Then
```
```
		strListName  = .Item( "L" )
```
```
		If strListName = "" Then
```

			Syntax "List (XML root tag) name required with /L switch"

```
		End If
```
```
		For i = 1 To Len( strListName )
```

			intTest = Asc( Mid( UCase( strListName ), i, 1 ) )

			If intTest < 48 Or intTest > 90 Or ( intTest > 57 And intTest < 65 ) Then

				Syntax "Use letters and numbers only for XML list (root tag) name"

```
			End If
```
```
		Next
```
```
		intValidArgs = intValidArgs + 1
```
```
	Else
```
```
		strListName  = "List"
```
```
	End If
```
```
	If .Exists( "NH" ) Then
```
```
		blnHeader    = False
```
```
		intValidArgs = intValidArgs + 1
```
```
	Else
```
```
		blnHeader    = True
```
```
	End If
```
```
	If .Exists( "R" ) Then
```
```
		If IsNumeric( .Item( "R" ) ) Then
```
```
			intRows   = CInt( .Item( "R" ) )
```

			If intRows < 1 Or intRows - .Item( "R" ) <> 0 Then

				Syntax "Specify an integer number with /R switch"

```
			End If
```
```
			blnRows      = True
```
```
			intValidArgs = intValidArgs + 1
```
```
		Else
```

			Syntax "Specify a number of rows with /R switch"

```
		End If
```
```
	Else
```
```
		blnRows = False
```
```
	End If
```
```
	If .Exists( "W" ) Then
```
```
		strWorksheet = .Item( "W" )
```
```
		If strWorksheet = "" Then
```

			Syntax "Worksheet name required with /W switch"

```
		End If
```
```
		blnWorksheet = True
```
```
		intValidArgs = intValidArgs + 1
```
```
	Else
```
```
		strWorksheet = "Sheet1"
```
```
		blnWorksheet = False
```
```
	End If
```
```
	If .Exists( "X" ) Then
```
```
		If .Item( "X" ) = "" Then
```

			Syntax "XML file name required with /X switch"

```
		End If
```

		strXMLFile   = objFSO.GetAbsolutePathName( .Item( "X" ) )

```
		intValidArgs = intValidArgs + 1
```
```
	Else
```

		strXMLFile   = objFSO.BuildPath( objFSO.GetParentFolderName( strExcelFile ), objFSO.GetBaseName( strExcelFile ) & ".xml" )

```
	End If
```

	If .Count <> intValidArgs Then Syntax "Invalid or duplicate command line argument(s)"

```
End With
```
```
 
```
```
' Check if the Excel file exists
```

If Not objFSO.FileExists( strExcelFile ) Then Syntax "Excel file not found"

```
 
```

' Backup an existing XML file if requested with the /B switch

```
With objFSO
```
```
	If blnBackup Then
```
```
		If .FileExists( strXMLFile ) Then
```

			strXMLBackup  = .GetBaseName( strExcelFile ) & "." & strDateTime & ".xls"

			strXMLFolder  = .GetParentFolderName( strExcelFile )

			strBackupFile = .BuildPath( strXMLFolder, strXMLBackup )

```
			On Error Resume Next
```

			.CopyFile strXMLFile, strBackupFile, True

			If Not Err Then .DeleteFile strXMLFile, True

```
			On Error Goto 0
```
```
		End If
```
```
	End If
```

	If Not .FolderExists( .GetParentFolderName( strXMLFile ) ) Then

		.CreateFolder .GetParentFolderName( strXMLFile )

```
	End If
```
```
End With
```
```
 
```

' Determine the number of columns if not specified

```
If Not blnColumns Then
```
```
	On Error Resume Next
```

	' Try reading the first 1000 cells of the first row

	arrHdrRow = ReadExcel( strExcelFile, strWorksheet, "A1", "ALL1", False )

```
	If Err Then
```

		' Try reading the first 100 cells of the first row

		arrHdrRow = ReadExcel( strExcelFile, strWorksheet, "A1", "CV1", False )

```
	End If
```

	intColumns = UBound( arrHdrRow, 1 ) + 1

```
	On Error Goto 0
```
```
End If
```
```
 
```
```
' Read and store the first row
```

arrHdrRow = ReadExcel( strExcelFile, strWorksheet, "A1", ColumnName( intColumns ) & "1", False )

intColumns = Min( UBound( arrHdrRow, 1 ) + 1, intColumns )

```
For i = 0 To intColumns - 1
```

	If Not blnHeader Then arrHdrRow( i, 0 ) = "Col" & i

	WScript.Echo i & vbTab & """" & arrHdrRow( i, 0 ) & """"

```
Next
```
```
 
```

' Determine the number of rows if not specified

```
If Not blnRows Then
```
```
	On Error Resume Next
```

	' Try reading the first 10000 cells of the first column

	arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", "A10000", False )

```
	If Err Then
```

		' Try reading the first 1000 cells of the first column

		arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", "A1000", False )

```
		If Err Then
```

			' Try reading the first 100 cells of the first column

			arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", "A100", False )

```
		End If
```
```
	End If
```
```
	intRows = UBound( arrSheet, 2 ) + 1
```
```
	On Error Goto 0
```
```
End If
```
```
 
```
```
' Read the entire sheet
```

arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", ColumnName( intColumns ) & intRows, blnHeader )

intRows = Min( UBound( arrSheet, 2 ) + 1, intRows )

```
 
```
```
' Start creating the XML tree
```

Set xmlRoot = objXML.createElement( strListName )

```
objXML.appendChild xmlRoot
```
```
For i = 1 To intRows - 1
```

	Set xmlNode = objXML.createElement( strItemName )

```
	xmlRoot.appendChild xmlNode
```
```
	For j = 0 To intColumns - 1
```

		WScript.Echo i & vbTab & j & vbTab & Trim( arrHdrRow( j, 0 ) ) & vbTab & Trim( arrSheet( j, i ) )

```
		' Skip columns without a name
```

		If Not "" & Trim( arrHdrRow( j, 0 ) ) = "" Then

			If Not "" & Trim( arrSheet( j, i ) ) = "" Then

				Set xmlChildNode = objXML.createElement( arrHdrRow( j, 0 ) )

				xmlChildNode.Text = "" & Trim( arrSheet( j, i ) )

```
				xmlNode.appendChild xmlChildNode
```
```
			End If
```
```
		End If
```
```
	Next
```
```
Next
```
```
 
```
```
' Save the XML file
```
```
objXML.save( strXMLFile )
```
```
 
```
```
 
```
```
 
```
```
 
```

' Get an Excel column name for a specified (1 based)

' column number, e.g. A for 1, CV for 100 or ALL for 1000

```
Function ColumnName( myColumn )
```
```
	Dim ColHi, ColLo
```
```
	ColumnName = ""
```
```
	If myColumn < 27 Then
```
```
		ColumnName = Chr( myColumn + 64 )
```
```
		Exit Function
```
```
	End If
```
```
	ColHi = Int( myColumn / 26 )
```
```
	ColLo = myColumn Mod 26
```
```
	If ColLo = 0 Then
```
```
		ColLo = 26
```
```
		ColHi = ColHi - 1
```
```
	End If
```

	ColumnName = ColumnName( ColHi ) & ColumnName( ColLo )

```
End Function
```
```
 
```
```
 
```

' Return the largest of 2 specified numbers

```
Function Max( myFirst, mySecond )
```
```
	If myFirst > mySecond Then
```
```
		Max = myFirst
```
```
	Else
```
```
		Max = mySecond
```
```
	End If
```
```
End Function
```
```
 
```
```
 
```

' Return the smallest of 2 specified numbers

```
Function Min( myFirst, mySecond )
```
```
	If myFirst < mySecond Then
```
```
		Min = myFirst
```
```
	Else
```
```
		Min = mySecond
```
```
	End If
```
```
End Function
```
```
 
```
```
 
```

' This function reads data from an Excel sheet without using MS-Office

```
'
```
```
' Arguments:
```

' myExcelFile [string]   The path and file name of the Excel file

' mySheet     [string]   The name of the worksheet used (e.g. "Sheet1")

' my1stCell   [string]   The index of the first cell to be read (e.g. "A1")

' myLastCell  [string]   The index of the last cell to be read (e.g. "D100")

' blnHeader   [boolean]  True if the first row in the sheet is a header

```
'
```
```
' Returns:
```

' The values read from the Excel sheet are returned in a two-dimensional

' array; the first dimension holds the columns, the second dimension holds

```
' the rows read from the Excel sheet.
```
```
'
```
```
' Written by Rob van der Woude
```
```
' http://www.robvanderwoude.com
```

Function ReadExcel( myExcelFile, mySheet, my1stCell, myLastCell, blnHeader )

```
	Dim arrData( ), i, j
```
```
	Dim objExcel, objRS
```
```
	Dim strExt, strHeader, strRange
```
```
 
```
```
	Const adOpenForwardOnly = 0
```
```
	Const adOpenKeyset      = 1
```
```
	Const adOpenDynamic     = 2
```
```
	Const adOpenStatic      = 3
```
```
 
```

	strExt = LCase( Mid( myExcelFile, InStrRev( myExcelFile, "." ) + 1 ) )

```
 
```

	' Define header parameter string for Excel object

```
	If blnHeader Then
```
```
		strHeader = "HDR=YES;"
```
```
	Else
```
```
		strHeader = "HDR=NO;"
```
```
	End If
```
```
 
```
```
	' Open the object for the Excel file
```

	Set objExcel = CreateObject( "ADODB.Connection" )

	' Select a connection string based on the Excel file's extension.

	' More connection strings can be found at http://www.connectionstrings.com/excel/

```
	If strExt = "xls" Then
```

		' Connect to Excel 2003 sheet in Windows XP

		objExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myExcelFile & ";Extended Properties=""Excel 8.0;" & strHeader & """"

```
	ElseIf strExt = "xlsx" Then
```

		' Connect to Excel 2007 sheet in Windows 7

		objExcel.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myExcelFile & ";Extended Properties=""Excel 12.0 XML;" & strHeader & """"

```
	ElseIf strExt = "xlsm" Then
```

		' Connect to Excel 2007 macro enabled sheet in Windows 7

		objExcel.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myExcelFile & ";Extended Properties=""Excel 12.0 Macro;" & strHeader & """"

```
	Else
```
```
		objExcel.Close
```
```
		Set objExcel = Nothing
```

		Syntax "Invalid file type (extension " & strExt & ")"

```
	End If
```
```
 
```

	' Open a recordset object for the sheet and range

	Set objRS = CreateObject( "ADODB.Recordset" )

	strRange = mySheet & "$" & my1stCell & ":" & myLastCell

	objRS.Open "Select * from [" & strRange & "]", objExcel, adOpenStatic

```
 
```
```
	' Read the data from the Excel sheet
```
```
	i = 0
```
```
	Do Until objRS.EOF
```

		' Stop reading when an empty row is encountered in the Excel sheet

		If Trim( objRS.Fields(0).Value ) = "" Then Exit Do

```
		' Add a new row to the output array
```

		ReDim Preserve arrData( objRS.Fields.Count - 1, i )

		' Copy the Excel sheet's row values to the array "row"

```
		For j = 0 To objRS.Fields.Count - 1
```

			arrData( j, i ) = Trim( objRS.Fields(j).Value )

```
		Next
```
```
		' Move to the next row
```
```
		objRS.MoveNext
```
```
		' Increment the array "row" number
```
```
		i = i + 1
```
```
	Loop
```
```
 
```

	' Close the file and release the objects

```
	objRS.Close
```
```
	objExcel.Close
```
```
	Set objRS    = Nothing
```
```
	Set objExcel = Nothing
```
```
 
```
```
	' Return the results
```
```
	ReadExcel = arrData
```
```
End Function
```
```
 
```
```
 
```
```
Sub Syntax( myErr )
```
```
	Dim blnTxtMode, strMsg
```

	If Right( UCase( WScript.FullName ), 12 ) = "\CSCRIPT.EXE" Then

```
		blnTxtMode = True
```
```
	Else
```
```
		blnTxtMode = False
```
```
	End If
```
```
	If myErr = "" Then
```
```
		strMsg = ""
```
```
	Else
```

		strMsg = "ERROR: " & myErr & vbCrLf & vbCrLf _

```
	End If
```
```
	strMsg = strMsg _
```

	       & strFileName & ", Version  " & strVersion _

```
	       & vbCrLf _
```

	       & "Convert an Excel spreadsheet to XML" _

```
	       & vbCrLf & vbCrLf
```
```
	If blnTxtMode Then
```
```
		strMsg = strMsg _
```
```
		       & "Usage:" _
```
```
		       & vbCrLf _
```
```
		       & "======" _
```
```
	       & vbCrLf _
```
```
	       & strFileName _
```

	       & "  [/E:excelfile]  [/X:xmlfile]  [/W:worksheet]  [/C:columns]" _

```
	       & vbCrLf _
```
```
	       & Space( Len( strFileName ) ) _
```

	       & "  [/R:rows]  [/NH]  [/L:listname]  [/I:itemname]  [/B]"

```
	Else
```
```
		strMsg = strMsg _
```
```
		       & "USAGE:" _
```
```
		       & vbCrLf _
```
```
	       & vbCrLf _
```
```
	       & strFileName _
```
```
	       & vbTab _
```

	       & "[/E:excelfile]  [/X:xmlfile]  [/W:worksheet]  [/C:columns]" _

```
	       & vbCrLf _
```
```
	       & Space( Len( strFileName ) ) _
```
```
	       & vbTab & vbTab _
```

	       & "[/R:rows]  [/NH]  [/L:listname]  [/I:itemname]  [/B]"

```
	End If
```
```
	strMsg = strMsg & vbCrLf & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "Switch:       Purpose:                      Default:" & vbCrLf _

		                & "=======       ========                      ========"

```
	Else
```

		strMsg = strMsg & "SWITCH:      " & vbTab & "PURPOSE:" & vbTab & vbTab & vbTab & "DEFAULT:" & vbCrLf

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/E:excelfile  Excel file to be read         Script name, extension .xls"

```
	Else
```

		strMsg = strMsg & "/E:excelfile " & vbTab & "Excel file to be read    " & vbTab & "Script name, extension .xls"

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/X:xmlfile    XML file to be created        Excel file name, ext .xml"

```
	Else
```

		strMsg = strMsg & "/X:xmlfile  " & vbTab & "XML file to be created" & vbTab & "Excel file name, ext .xml"

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/W:worksheet  Name of worksheet to be used  ""Sheet1"""

```
	Else
```

		strMsg = strMsg & "/W:worksheet" & vbTab & "Name of worksheet to be used" & vbTab & """Sheet1"""

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/C:columns    Number of columns to be read  Up to 1st empty cell in 1st row"

```
	Else
```

		strMsg = strMsg & "/C:columns  " & vbTab & "Number of columns to be read" & vbTab & "Up to 1st empty cell in row 1"

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/R:rows       Number of rows to be read     Up to 1st empty cell in 1st col"

```
	Else
```

		strMsg = strMsg & "/R:rows      " & vbTab & "Number of rows to be read" & vbTab & "Up to 1st empty cell in col A"

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/NH           First row is NOT a header     First row contains XML tag names"

```
	Else
```

		strMsg = strMsg & "/NH            " & vbTab & "First row is NOT a header" & vbTab & "XML tag names in first row"

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/L:listname   Tag name of XML root          ""List"""

```
	Else
```

		strMsg = strMsg & "/L:listname " & vbTab & "Tag name of XML root" & vbTab & """List"""

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/I:itemname   Tag name of child items       ""Item"""

```
	Else
```

		strMsg = strMsg & "/I:itemname " & vbTab & "Tag name of child items" & vbTab & """Item"""

```
	End If
```
```
	strMsg = strMsg & vbCrLf
```
```
	If blnTxtMode Then
```

		strMsg = strMsg & "/B            Backup existing XML file      Overwrite existing XML file"

```
	Else
```

		strMsg = strMsg & "/B               " & vbTab & "Backup existing XML file" & vbTab & "Overwrite existing XML file"

```
	End If
```
```
	strMsg = strMsg & vbCrLf & vbCrLf _
```

	       & "Written by Rob van der Woude" _

```
	       & vbCrLf _
```

	       & "http://www.robvanderwoude.com"

```
	If blnTxtMode Then
```
```
		WScript.Echo strMsg
```
```
	Else
```
```
		If myErr = "" Then
```

			MsgBox strMsg, vbOKOnly + vbApplicationModal, strFileName & ", Version " & strVersion & ", � Rob van der Woude, 2013"

```
		Else
```

			MsgBox strMsg, vbOKOnly + vbApplicationModal, myErr

```
		End If
```
```
	End If
```
```
 
```
```
	Set objFSO = Nothing
```
```
	Set objXML = Nothing
```
```
	WScript.Quit 1
```
```
End Sub
```
```
 
```