Rob van der Woude's Scripting Pages
Powered by GeSHi

Source code for excel2xml.vbs

(view source code of excel2xml.vbs as plain text)

  1. Option Explicit
  2.  
  3. Dim arrSheet, arrHdrRow
  4. Dim blnBackup, blnHeader, blnColumns, blnRows, blnWorksheet
  5. Dim dtmNow
  6. Dim intColumns, intRows, intTest, intValidArgs, i, j
  7. Dim objFSO, objXML, xmlChildNode, xmlNode, xmlRoot
  8. Dim strBackupFile, strDateTime, strExcelFile, strFileName
  9. Dim strItemName, strListName, strParentDir, strVersion
  10. Dim strWorksheet, strXMLBackup, strXMLFile, strXMLFolder
  11.  
  12. strVersion = "1.21"
  13.  
  14. ' Required objects
  15. Set objFSO = CreateObject( "Scripting.FileSystemObject" )
  16. Set objXML = CreateObject( "Microsoft.XMLDOM" )
  17.  
  18. ' Default values
  19. strParentDir = objFSO.GetParentFolderName( WScript.ScriptFullName )
  20. strFileName  = objFSO.GetBaseName( WScript.ScriptName )
  21.  
  22. ' Parse optional command line arguments
  23. If WScript.Arguments.Unnamed.Count > 0 Then Syntax
  24. With WScript.Arguments.Named
  25. 	If .Count = 0 Then
  26. 		Syntax ""
  27. 	End If
  28. 	intValidArgs = 0
  29. 	If .Exists( "B" ) Then
  30. 		blnBackup    = True
  31. 		dtmNow       = Now
  32. 		strDateTime  = DatePart( "yyyy", dtmNow ) _
  33. 		             & Right( "0" & DatePart( "m", dtmNow ), 2 ) _
  34. 		             & Right( "0" & DatePart( "d", dtmNow ), 2 ) _
  35. 		             & Right( "0" & DatePart( "h", dtmNow ), 2 ) _
  36. 		             & Right( "0" & DatePart( "n", dtmNow ), 2 ) _
  37. 		             & Right( "0" & DatePart( "s", dtmNow ), 2 )
  38. 		intValidArgs = intValidArgs + 1
  39. 	Else
  40. 		blnBackup    = False
  41. 	End If
  42. 	If .Exists( "C" ) Then
  43. 		If IsNumeric( .Item( "C" ) ) Then
  44. 			intColumns   = CInt( .Item( "C" ) )
  45. 			If intColumns < 1 Or intColumns - .Item( "C" ) <> 0 Then
  46. 				Syntax "Specify an integer number with /C switch"
  47. 			End If
  48. 			blnColumns   = True
  49. 			intValidArgs = intValidArgs + 1
  50. 		Else
  51. 			strErrorMsg = "Specify a number of columns with /C switch"
  52. 			Syntax
  53. 		End If
  54. 	Else
  55. 		blnColumns = False
  56. 	End If
  57. 	If .Exists( "E" ) Then
  58. 		If .Item( "E" ) = "" Then
  59. 			Syntax "Excel file name required with /E switch"
  60. 		Else
  61. 			If objFSO.FileExists( .Item( "E" ) ) Then
  62. 				strExcelFile = objFSO.GetAbsolutePathName( .Item( "E" ) )
  63. 				intValidArgs = intValidArgs + 1
  64. 			Else
  65. 				Syntax "Specified Excel file not found"
  66. 			End If
  67. 		End If
  68. 	Else
  69. 		strExcelFile = objFSO.BuildPath( strParentDir, strFileName & ".xls" )
  70. 	End If
  71. 	If .Exists( "I" ) Then
  72. 		strItemName  = .Item( "I" )
  73. 		If strItemName = "" Then
  74. 			Syntax "Item name required with /I switch"
  75. 		End If
  76. 		For i = 1 To Len( strItemName )
  77. 			intTest = Asc( Mid( UCase( strItemName ), i, 1 ) )
  78. 			If intTest < 48 Or intTest > 90 Or ( intTest > 57 And intTest < 65 ) Then
  79. 				Syntax "Use letters and numbers only for XML item names"
  80. 			End If
  81. 		Next
  82. 		intValidArgs = intValidArgs + 1
  83. 	Else
  84. 		strItemName  = "Item"
  85. 	End If
  86. 	If .Exists( "L" ) Then
  87. 		strListName  = .Item( "L" )
  88. 		If strListName = "" Then
  89. 			Syntax "List (XML root tag) name required with /L switch"
  90. 		End If
  91. 		For i = 1 To Len( strListName )
  92. 			intTest = Asc( Mid( UCase( strListName ), i, 1 ) )
  93. 			If intTest < 48 Or intTest > 90 Or ( intTest > 57 And intTest < 65 ) Then
  94. 				Syntax "Use letters and numbers only for XML list (root tag) name"
  95. 			End If
  96. 		Next
  97. 		intValidArgs = intValidArgs + 1
  98. 	Else
  99. 		strListName  = "List"
  100. 	End If
  101. 	If .Exists( "NH" ) Then
  102. 		blnHeader    = False
  103. 		intValidArgs = intValidArgs + 1
  104. 	Else
  105. 		blnHeader    = True
  106. 	End If
  107. 	If .Exists( "R" ) Then
  108. 		If IsNumeric( .Item( "R" ) ) Then
  109. 			intRows   = CInt( .Item( "R" ) )
  110. 			If intRows < 1 Or intRows - .Item( "R" ) <> 0 Then
  111. 				Syntax "Specify an integer number with /R switch"
  112. 			End If
  113. 			blnRows      = True
  114. 			intValidArgs = intValidArgs + 1
  115. 		Else
  116. 			Syntax "Specify a number of rows with /R switch"
  117. 		End If
  118. 	Else
  119. 		blnRows = False
  120. 	End If
  121. 	If .Exists( "W" ) Then
  122. 		strWorksheet = .Item( "W" )
  123. 		If strWorksheet = "" Then
  124. 			Syntax "Worksheet name required with /W switch"
  125. 		End If
  126. 		blnWorksheet = True
  127. 		intValidArgs = intValidArgs + 1
  128. 	Else
  129. 		strWorksheet = "Sheet1"
  130. 		blnWorksheet = False
  131. 	End If
  132. 	If .Exists( "X" ) Then
  133. 		If .Item( "X" ) = "" Then
  134. 			Syntax "XML file name required with /X switch"
  135. 		End If
  136. 		strXMLFile   = objFSO.GetAbsolutePathName( .Item( "X" ) )
  137. 		intValidArgs = intValidArgs + 1
  138. 	Else
  139. 		strXMLFile   = objFSO.BuildPath( objFSO.GetParentFolderName( strExcelFile ), objFSO.GetBaseName( strExcelFile ) & ".xml" )
  140. 	End If
  141. 	If .Count <> intValidArgs Then Syntax "Invalid or duplicate command line argument(s)"
  142. End With
  143.  
  144. ' Check if the Excel file exists
  145. If Not objFSO.FileExists( strExcelFile ) Then Syntax "Excel file not found"
  146.  
  147. ' Backup an existing XML file if requested with the /B switch
  148. With objFSO
  149. 	If blnBackup Then
  150. 		If .FileExists( strXMLFile ) Then
  151. 			strXMLBackup  = .GetBaseName( strExcelFile ) & "." & strDateTime & ".xls"
  152. 			strXMLFolder  = .GetParentFolderName( strExcelFile )
  153. 			strBackupFile = .BuildPath( strXMLFolder, strXMLBackup )
  154. 			On Error Resume Next
  155. 			.CopyFile strXMLFile, strBackupFile, True
  156. 			If Not Err Then .DeleteFile strXMLFile, True
  157. 			On Error Goto 0
  158. 		End If
  159. 	End If
  160. 	If Not .FolderExists( .GetParentFolderName( strXMLFile ) ) Then
  161. 		.CreateFolder .GetParentFolderName( strXMLFile )
  162. 	End If
  163. End With
  164.  
  165. ' Determine the number of columns if not specified
  166. If Not blnColumns Then
  167. 	On Error Resume Next
  168. 	' Try reading the first 1000 cells of the first row
  169. 	arrHdrRow = ReadExcel( strExcelFile, strWorksheet, "A1", "ALL1", False )
  170. 	If Err Then
  171. 		' Try reading the first 100 cells of the first row
  172. 		arrHdrRow = ReadExcel( strExcelFile, strWorksheet, "A1", "CV1", False )
  173. 	End If
  174. 	intColumns = UBound( arrHdrRow, 1 ) + 1
  175. 	On Error Goto 0
  176. End If
  177.  
  178. ' Read and store the first row
  179. arrHdrRow = ReadExcel( strExcelFile, strWorksheet, "A1", ColumnName( intColumns ) & "1", False )
  180. intColumns = Min( UBound( arrHdrRow, 1 ) + 1, intColumns )
  181. For i = 0 To intColumns - 1
  182. 	If Not blnHeader Then arrHdrRow( i, 0 ) = "Col" & i
  183. 	WScript.Echo i & vbTab & """" & arrHdrRow( i, 0 ) & """"
  184. Next
  185.  
  186. ' Determine the number of rows if not specified
  187. If Not blnRows Then
  188. 	On Error Resume Next
  189. 	' Try reading the first 10000 cells of the first column
  190. 	arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", "A10000", False )
  191. 	If Err Then
  192. 		' Try reading the first 1000 cells of the first column
  193. 		arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", "A1000", False )
  194. 		If Err Then
  195. 			' Try reading the first 100 cells of the first column
  196. 			arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", "A100", False )
  197. 		End If
  198. 	End If
  199. 	intRows = UBound( arrSheet, 2 ) + 1
  200. 	On Error Goto 0
  201. End If
  202.  
  203. ' Read the entire sheet
  204. arrSheet = ReadExcel( strExcelFile, strWorksheet, "A1", ColumnName( intColumns ) & intRows, blnHeader )
  205. intRows = Min( UBound( arrSheet, 2 ) + 1, intRows )
  206.  
  207. ' Start creating the XML tree
  208. Set xmlRoot = objXML.createElement( strListName )
  209. objXML.appendChild xmlRoot
  210. For i = 1 To intRows - 1
  211. 	Set xmlNode = objXML.createElement( strItemName )
  212. 	xmlRoot.appendChild xmlNode
  213. 	For j = 0 To intColumns - 1
  214. 		WScript.Echo i & vbTab & j & vbTab & Trim( arrHdrRow( j, 0 ) ) & vbTab & Trim( arrSheet( j, i ) )
  215. 		' Skip columns without a name
  216. 		If Not "" & Trim( arrHdrRow( j, 0 ) ) = "" Then
  217. 			If Not "" & Trim( arrSheet( j, i ) ) = "" Then
  218. 				Set xmlChildNode = objXML.createElement( arrHdrRow( j, 0 ) )
  219. 				xmlChildNode.Text = "" & Trim( arrSheet( j, i ) )
  220. 				xmlNode.appendChild xmlChildNode
  221. 			End If
  222. 		End If
  223. 	Next
  224. Next
  225.  
  226. ' Save the XML file
  227. objXML.save( strXMLFile )
  228.  
  229.  
  230.  
  231.  
  232. ' Get an Excel column name for a specified (1 based)
  233. ' column number, e.g. A for 1, CV for 100 or ALL for 1000
  234. Function ColumnName( myColumn )
  235. 	Dim ColHi, ColLo
  236. 	ColumnName = ""
  237. 	If myColumn < 27 Then
  238. 		ColumnName = Chr( myColumn + 64 )
  239. 		Exit Function
  240. 	End If
  241. 	ColHi = Int( myColumn / 26 )
  242. 	ColLo = myColumn Mod 26
  243. 	If ColLo = 0 Then
  244. 		ColLo = 26
  245. 		ColHi = ColHi - 1
  246. 	End If
  247. 	ColumnName = ColumnName( ColHi ) & ColumnName( ColLo )
  248. End Function
  249.  
  250.  
  251. ' Return the largest of 2 specified numbers
  252. Function Max( myFirst, mySecond )
  253. 	If myFirst > mySecond Then
  254. 		Max = myFirst
  255. 	Else
  256. 		Max = mySecond
  257. 	End If
  258. End Function
  259.  
  260.  
  261. ' Return the smallest of 2 specified numbers
  262. Function Min( myFirst, mySecond )
  263. 	If myFirst < mySecond Then
  264. 		Min = myFirst
  265. 	Else
  266. 		Min = mySecond
  267. 	End If
  268. End Function
  269.  
  270.  
  271. ' This function reads data from an Excel sheet without using MS-Office
  272. '
  273. ' Arguments:
  274. ' myExcelFile [string]   The path and file name of the Excel file
  275. ' mySheet     [string]   The name of the worksheet used (e.g. "Sheet1")
  276. ' my1stCell   [string]   The index of the first cell to be read (e.g. "A1")
  277. ' myLastCell  [string]   The index of the last cell to be read (e.g. "D100")
  278. ' blnHeader   [boolean]  True if the first row in the sheet is a header
  279. '
  280. ' Returns:
  281. ' The values read from the Excel sheet are returned in a two-dimensional
  282. ' array; the first dimension holds the columns, the second dimension holds
  283. ' the rows read from the Excel sheet.
  284. '
  285. ' Written by Rob van der Woude
  286. ' http://www.robvanderwoude.com
  287. Function ReadExcel( myExcelFile, mySheet, my1stCell, myLastCell, blnHeader )
  288. 	Dim arrData( ), i, j
  289. 	Dim objExcel, objRS
  290. 	Dim strExt, strHeader, strRange
  291.  
  292. 	Const adOpenForwardOnly = 0
  293. 	Const adOpenKeyset      = 1
  294. 	Const adOpenDynamic     = 2
  295. 	Const adOpenStatic      = 3
  296.  
  297. 	strExt = LCase( Mid( myExcelFile, InStrRev( myExcelFile, "." ) + 1 ) )
  298.  
  299. 	' Define header parameter string for Excel object
  300. 	If blnHeader Then
  301. 		strHeader = "HDR=YES;"
  302. 	Else
  303. 		strHeader = "HDR=NO;"
  304. 	End If
  305.  
  306. 	' Open the object for the Excel file
  307. 	Set objExcel = CreateObject( "ADODB.Connection" )
  308. 	' Select a connection string based on the Excel file's extension.
  309. 	' More connection strings can be found at http://www.connectionstrings.com/excel/
  310. 	If strExt = "xls" Then
  311. 		' Connect to Excel 2003 sheet in Windows XP
  312. 		objExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myExcelFile & ";Extended Properties=""Excel 8.0;" & strHeader & """"
  313. 	ElseIf strExt = "xlsx" Then
  314. 		' Connect to Excel 2007 sheet in Windows 7
  315. 		objExcel.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myExcelFile & ";Extended Properties=""Excel 12.0 XML;" & strHeader & """"
  316. 	ElseIf strExt = "xlsm" Then
  317. 		' Connect to Excel 2007 macro enabled sheet in Windows 7
  318. 		objExcel.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myExcelFile & ";Extended Properties=""Excel 12.0 Macro;" & strHeader & """"
  319. 	Else
  320. 		objExcel.Close
  321. 		Set objExcel = Nothing
  322. 		Syntax "Invalid file type (extension " & strExt & ")"
  323. 	End If
  324.  
  325. 	' Open a recordset object for the sheet and range
  326. 	Set objRS = CreateObject( "ADODB.Recordset" )
  327. 	strRange = mySheet & "$" & my1stCell & ":" & myLastCell
  328. 	objRS.Open "Select * from [" & strRange & "]", objExcel, adOpenStatic
  329.  
  330. 	' Read the data from the Excel sheet
  331. 	i = 0
  332. 	Do Until objRS.EOF
  333. 		' Stop reading when an empty row is encountered in the Excel sheet
  334. 		If Trim( objRS.Fields(0).Value ) = "" Then Exit Do
  335. 		' Add a new row to the output array
  336. 		ReDim Preserve arrData( objRS.Fields.Count - 1, i )
  337. 		' Copy the Excel sheet's row values to the array "row"
  338. 		For j = 0 To objRS.Fields.Count - 1
  339. 			arrData( j, i ) = Trim( objRS.Fields(j).Value )
  340. 		Next
  341. 		' Move to the next row
  342. 		objRS.MoveNext
  343. 		' Increment the array "row" number
  344. 		i = i + 1
  345. 	Loop
  346.  
  347. 	' Close the file and release the objects
  348. 	objRS.Close
  349. 	objExcel.Close
  350. 	Set objRS    = Nothing
  351. 	Set objExcel = Nothing
  352.  
  353. 	' Return the results
  354. 	ReadExcel = arrData
  355. End Function
  356.  
  357.  
  358. Sub Syntax( myErr )
  359. 	Dim blnTxtMode, strMsg
  360. 	If Right( UCase( WScript.FullName ), 12 ) = "\CSCRIPT.EXE" Then
  361. 		blnTxtMode = True
  362. 	Else
  363. 		blnTxtMode = False
  364. 	End If
  365. 	If myErr = "" Then
  366. 		strMsg = ""
  367. 	Else
  368. 		strMsg = "ERROR: " & myErr & vbCrLf & vbCrLf _
  369. 	End If
  370. 	strMsg = strMsg _
  371. 	       & strFileName & ", Version  " & strVersion _
  372. 	       & vbCrLf _
  373. 	       & "Convert an Excel spreadsheet to XML" _
  374. 	       & vbCrLf & vbCrLf
  375. 	If blnTxtMode Then
  376. 		strMsg = strMsg _
  377. 		       & "Usage:" _
  378. 		       & vbCrLf _
  379. 		       & "======" _
  380. 	       & vbCrLf _
  381. 	       & strFileName _
  382. 	       & "  [/E:excelfile]  [/X:xmlfile]  [/W:worksheet]  [/C:columns]" _
  383. 	       & vbCrLf _
  384. 	       & Space( Len( strFileName ) ) _
  385. 	       & "  [/R:rows]  [/NH]  [/L:listname]  [/I:itemname]  [/B]" 
  386. 	Else
  387. 		strMsg = strMsg _
  388. 		       & "USAGE:" _
  389. 		       & vbCrLf _
  390. 	       & vbCrLf _
  391. 	       & strFileName _
  392. 	       & vbTab _
  393. 	       & "[/E:excelfile]  [/X:xmlfile]  [/W:worksheet]  [/C:columns]" _
  394. 	       & vbCrLf _
  395. 	       & Space( Len( strFileName ) ) _
  396. 	       & vbTab & vbTab _
  397. 	       & "[/R:rows]  [/NH]  [/L:listname]  [/I:itemname]  [/B]" 
  398. 	End If
  399. 	strMsg = strMsg & vbCrLf & vbCrLf
  400. 	If blnTxtMode Then
  401. 		strMsg = strMsg & "Switch:       Purpose:                      Default:" & vbCrLf _
  402. 		                & "=======       ========                      ========"
  403. 	Else
  404. 		strMsg = strMsg & "SWITCH:      " & vbTab & "PURPOSE:" & vbTab & vbTab & vbTab & "DEFAULT:" & vbCrLf
  405. 	End If
  406. 	strMsg = strMsg & vbCrLf
  407. 	If blnTxtMode Then
  408. 		strMsg = strMsg & "/E:excelfile  Excel file to be read         Script name, extension .xls"
  409. 	Else
  410. 		strMsg = strMsg & "/E:excelfile " & vbTab & "Excel file to be read    " & vbTab & "Script name, extension .xls"
  411. 	End If
  412. 	strMsg = strMsg & vbCrLf
  413. 	If blnTxtMode Then
  414. 		strMsg = strMsg & "/X:xmlfile    XML file to be created        Excel file name, ext .xml"
  415. 	Else
  416. 		strMsg = strMsg & "/X:xmlfile  " & vbTab & "XML file to be created" & vbTab & "Excel file name, ext .xml"
  417. 	End If
  418. 	strMsg = strMsg & vbCrLf
  419. 	If blnTxtMode Then
  420. 		strMsg = strMsg & "/W:worksheet  Name of worksheet to be used  ""Sheet1"""
  421. 	Else
  422. 		strMsg = strMsg & "/W:worksheet" & vbTab & "Name of worksheet to be used" & vbTab & """Sheet1"""
  423. 	End If
  424. 	strMsg = strMsg & vbCrLf
  425. 	If blnTxtMode Then
  426. 		strMsg = strMsg & "/C:columns    Number of columns to be read  Up to 1st empty cell in 1st row"
  427. 	Else
  428. 		strMsg = strMsg & "/C:columns  " & vbTab & "Number of columns to be read" & vbTab & "Up to 1st empty cell in row 1"
  429. 	End If
  430. 	strMsg = strMsg & vbCrLf
  431. 	If blnTxtMode Then
  432. 		strMsg = strMsg & "/R:rows       Number of rows to be read     Up to 1st empty cell in 1st col"
  433. 	Else
  434. 		strMsg = strMsg & "/R:rows      " & vbTab & "Number of rows to be read" & vbTab & "Up to 1st empty cell in col A"
  435. 	End If
  436. 	strMsg = strMsg & vbCrLf
  437. 	If blnTxtMode Then
  438. 		strMsg = strMsg & "/NH           First row is NOT a header     First row contains XML tag names"
  439. 	Else
  440. 		strMsg = strMsg & "/NH            " & vbTab & "First row is NOT a header" & vbTab & "XML tag names in first row"
  441. 	End If
  442. 	strMsg = strMsg & vbCrLf
  443. 	If blnTxtMode Then
  444. 		strMsg = strMsg & "/L:listname   Tag name of XML root          ""List"""
  445. 	Else
  446. 		strMsg = strMsg & "/L:listname " & vbTab & "Tag name of XML root" & vbTab & """List"""
  447. 	End If
  448. 	strMsg = strMsg & vbCrLf
  449. 	If blnTxtMode Then
  450. 		strMsg = strMsg & "/I:itemname   Tag name of child items       ""Item"""
  451. 	Else
  452. 		strMsg = strMsg & "/I:itemname " & vbTab & "Tag name of child items" & vbTab & """Item"""
  453. 	End If
  454. 	strMsg = strMsg & vbCrLf
  455. 	If blnTxtMode Then
  456. 		strMsg = strMsg & "/B            Backup existing XML file      Overwrite existing XML file"
  457. 	Else
  458. 		strMsg = strMsg & "/B               " & vbTab & "Backup existing XML file" & vbTab & "Overwrite existing XML file"
  459. 	End If
  460. 	strMsg = strMsg & vbCrLf & vbCrLf _
  461. 	       & "Written by Rob van der Woude" _
  462. 	       & vbCrLf _
  463. 	       & "http://www.robvanderwoude.com"
  464. 	If blnTxtMode Then
  465. 		WScript.Echo strMsg
  466. 	Else
  467. 		If myErr = "" Then
  468. 			MsgBox strMsg, vbOKOnly + vbApplicationModal, strFileName & ", Version " & strVersion & ",  Rob van der Woude, 2013"
  469. 		Else
  470. 			MsgBox strMsg, vbOKOnly + vbApplicationModal, myErr
  471. 		End If
  472. 	End If
  473.  
  474. 	Set objFSO = Nothing
  475. 	Set objXML = Nothing
  476. 	WScript.Quit 1
  477. End Sub
  478.  

page last uploaded: 2017-07-06, 12:37