Rob van der Woude's Scripting Pages
Powered by GeSHi

Source code for xl2xml.vbs

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

page last uploaded: 2017-08-21, 14:26