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, strErrorMsg, strExcelFile Dim strFileName, strItemName, strListName, strParentDir, strVersion Dim strWorksheet, strXMLBackup, strXMLFile, strXMLFolder strVersion = "1.10" ' Required objects Set objFSO = CreateObject( "Scripting.FileSystemObject" ) Set objXML = CreateObject( "Microsoft.XMLDOM" ) ' Default values strParentDir = objFSO.GetParentFolderName( WScript.ScriptFullName ) strFileName = objFSO.GetBaseName( WScript.ScriptName ) strErrorMsg = "invalid command line argument(s)" ' Parse optional command line arguments If WScript.Arguments.Unnamed.Count > 0 Then Syntax With WScript.Arguments.Named 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 strErrorMsg = "Specify an integer number with /C switch" Syntax 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 strErrorMsg = "Excel file name required with /E switch" Else If objFSO.FileExists( .Item( "E" ) ) Then strExcelFile = objFSO.GetAbsolutePathName( .Item( "E" ) ) intValidArgs = intValidArgs + 1 Else strErrorMsg = "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 strErrorMsg = "Item name required with /I switch" Syntax 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 strErrorMsg = "Use letters and numbers only for XML item names" Syntax End If Next intValidArgs = intValidArgs + 1 Else strItemName = "Item" End If If .Exists( "L" ) Then strListName = .Item( "L" ) If strListName = "" Then strErrorMsg = "List (XML root tag) name required with /L switch" Syntax 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 strErrorMsg = "Use letters and numbers only for XML list (root tag) name" Syntax 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 strErrorMsg = "Specify an integer number with /R switch" Syntax End If blnRows = True intValidArgs = intValidArgs + 1 Else strErrorMsg = "Specify a number of rows with /R switch" Syntax End If Else blnRows = False End If If .Exists( "W" ) Then strWorksheet = .Item( "W" ) If strWorksheet = "" Then strErrorMsg = "Worksheet name required with /W switch" Syntax End If blnWorksheet = True intValidArgs = intValidArgs + 1 Else strWorksheet = "Sheet1" blnWorksheet = False End If If .Exists( "X" ) Then If .Item( "X" ) = "" Then strErrorMsg = "XML file name required with /X switch" Syntax 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 End With ' Check if the Excel file exists If Not objFSO.FileExists( strExcelFile ) Then strErrorMsg = "Excel file not found" Syntax End If ' 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 strHeader, strRange Const adOpenForwardOnly = 0 Const adOpenKeyset = 1 Const adOpenDynamic = 2 Const adOpenStatic = 3 ' 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" ) objExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _ myExcelFile & ";Extended Properties=""Excel 8.0;" & _ strHeader & """" ' 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 Dim blnTxtMode, strMsg If Right( UCase( WScript.FullName ), 12 ) = "\CSCRIPT.EXE" Then blnTxtMode = True Else blnTxtMode = False End If strMsg = "ERROR: " & strErrorMsg _ & vbCrLf & vbCrLf _ & WScript.ScriptName & ", 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 _ & "[/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 row 0" Else strMsg = strMsg & "/C:columns " & vbTab & "Number of columns to be read" & vbTab & "Up to 1st empty cell in row 0" End If strMsg = strMsg & vbCrLf If blnTxtMode Then strMsg = strMsg & "/R:rows Number of rows to be read Up to 1st empty cell in col 0" Else strMsg = strMsg & "/R:rows " & vbTab & "Number of rows to be read" & vbTab & "Up to 1st empty cell in col 0" End If strMsg = strMsg & vbCrLf If blnTxtMode Then strMsg = strMsg & "/NH Row 0 is NOT a header Row 0 contains XML tag names" Else strMsg = strMsg & "/NH " & vbTab & "Row 0 is NOT a header" & vbTab & "XML tag names in row 0" 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 MsgBox strMsg, , strErrorMsg End If Set objFSO = Nothing Set objXML = Nothing WScript.Quit 1 End Sub