'Begin Description 'This script takes creates an XML file out of the current SPSS data file, prompting the user for 'where they would like the file created at. Alternatively, you can pass a parameter for where you 'want the XML file created (for example: SCRIPT td_ExportAsXML.sbs ("C:\\Windows\\Desktop\\output.xml") 'End Description 'Author: Tom Dierickx 'Created: 7/15/2001 'Small change made by Raynald Levesque on 2002/07/26 so that code would work with SPSS 11. 'see ### below Sub Main() On Error GoTo EndOfSub 'Remove the next two lines when copying into an SPSS script.sbs file 'Dim objSpssApp As spsswin.Application 'Set objSpssApp = GetObject(, "SPSS.Application") 'Declare Variables Dim bSuccess ' Flag set to true if export successful Dim bUserCancelled ' Flag set to true if user hit cancel when prompted for location Dim sExportTo ' Will hold the desired export location Dim objSpssData As ISpssDataDoc ' Will hold the current SPSS data document Dim Index As Long ' Will hold the index of the current variable Dim NumVars As Long ' Will hold the number of variables Dim NumCases As Long ' Will hold the number of cases Dim SpssData As Variant ' A variant array that will hold the matrix of SPSS data Dim pNames As Variant ' A variant array to store the variable names Dim pLabels As Variant ' A variant array to store the variable labels Dim pMsmtLevels As Variant ' A variant array to store the variable measurement levels Dim pLabelCounts As Variant ' A variant array to store the number of value labels for the variable Dim pTypes As Variant ' A variant array to store the variable types Dim pFormats As Variant ' A variant array to store the variable formats Dim pWidths As Variant ' A variant array to store the variable widths Dim pFracs As Variant ' A variant array to store the number of decimal places Dim pColumnWidths As Variant ' A variant array to store the column widths Dim pJust As Variant ' A variant array to store the variable alignment justifications Dim xmlDoc 'As MSXML2.DOMDocument30 ' Will hold the XML output document Dim xmlRoot 'As MSXML2.IXMLDOMElement ' Will hold the XML's root element Dim xmlPI 'As MSXML2.IXMLDOMProcessingInstruction 'Will hold the XML version info Dim xmlInfo 'As MSXML2.IXMLDOMNode ' Will hold global info about the SPSS document Dim xmlVars 'As MSXML2.IXMLDOMNode ' Will hold the variables section Dim xmlLabels 'As MSXML2.IXMLDOMNode ' Will hold the labels section Dim xmlData 'As MSXML2.IXMLDOMNode ' Will hold the data section Dim xmlElement 'As MSXML2.IXMLDOMElement ' Will hold the various output elements Dim startTime As Date ' Will hold the time the procedure begins Dim stopTime As Date ' Will hold the time the procedure ends 'Grab current SPSS Data document and create a new XML document in memory Set objSpssData = objSpssApp.Documents.GetDataDoc(0) Set xmlDoc = CreateObject("Msxml2.DOMDocument.3.0") 'If user supplied optional parameter for where to output, then use it; otherwise, prompt user. sExportTo = objSpssApp.ScriptParameter (0) If Len(sExportTo) = 0 Then Dim sDefaultPath As String sDefaultPath = Left(objSpssData.GetDocumentPath,Len(objSpssData.GetDocumentPath)-4) & ".xml" sExportTo = InputBox("Enter path to export to:",,sDefaultPath) 'Verify user didn't hit cancel; if they did exit sub gracefully If Len(sExportTo) = 0 Then bUserCancelled = True GoTo EndOfSub End If End If 'Begin process startTime = Now() 'Load SPSS variable definitions Call objSpssData.GetVariableInfo(pNames, pLabels, pTypes, pMsmtLevels, pLabelCounts) Call objSpssData.GetVariableFormats(pFormats, pWidths, pFracs) Call objSpssData.GetVariableColumnWidths(pColumnWidths) Call objSpssData.GetVariableJustification(pJust) 'Determine the number of variables and cases NumVars = objSpssData.GetNumberOfVariables NumCases = objSpssData.GetNumberOfCases SpssData = objSpssData.GetTextData(pNames(0), pNames(NumVars - 1), 1, NumCases) 'Create XML root element Set xmlRoot = xmlDoc.createElement("sav_file") xmlDoc.appendChild xmlRoot 'Add XML version info Set xmlPI = xmlDoc.createProcessingInstruction("xml", "version=""1.0""") xmlDoc.InsertBefore xmlPI, xmlRoot 'Add Global Info Section Set xmlInfo = xmlDoc.createElement("info") xmlRoot.appendChild xmlInfo 'Add Variable Section Set xmlVars = xmlDoc.createElement("variables") xmlRoot.appendChild xmlVars 'Add Data Section Set xmlData = xmlDoc.createElement("data") xmlRoot.appendChild xmlData 'Update Global Info Section Set xmlElement = xmlDoc.createElement("printed") xmlElement.Text = Now() xmlInfo.appendChild xmlElement Set xmlElement = xmlDoc.createElement("path") xmlElement.Text = objSpssData.GetDocumentPath xmlInfo.appendChild xmlElement Set xmlElement = xmlDoc.createElement("num_vars") xmlElement.Text = NumVars xmlInfo.appendChild xmlElement Set xmlElement = xmlDoc.createElement("num_cases") xmlElement.Text = NumCases xmlInfo.appendChild xmlElement 'Update Variable Info Section For Index = 0 To (NumVars - 1) Set xmlElement = xmlDoc.createElement("spss_var") xmlElement.setAttribute "name", pNames(Index) 'Write out Data Type Select Case pFormats(Index) Case 1 To 2 xmlElement.setAttribute "type", "String" Case 3 To 19 xmlElement.setAttribute "type", "Numeric" Case 20 To 39 xmlElement.setAttribute "type", "DateTime" End Select 'Write out Variable Widths xmlElement.setAttribute "width", pWidths(Index) 'Write out Number of Decimal Places xmlElement.setAttribute "decimals", pFracs(Index) 'Write out the Variable's Format Dim sFormat As String Select Case pFormats(Index) Case 1 sFormat = "A" Case 2 sFormat = "AHEX" Case 3 sFormat = "COMMA" Case 4 sFormat = "DOLLAR" Case 5 sFormat = "F" Case 6 sFormat = "IB" Case 7 sFormat = "PIBHEX" Case 8 sFormat = "P" Case 9 sFormat = "PIB" Case 10 sFormat = "PK" Case 11 sFormat = "RB" Case 12 sFormat = "RBHEX" Case 15 sFormat = "Z" Case 16 sFormat = "N" Case 17 sFormat = "E" Case 20 sFormat = "DATE" Case 21 sFormat = "TIME" Case 22 sFormat = "DATETIME" Case 23 sFormat = "ADATE" Case 24 sFormat = "JDATE" Case 25 sFormat = "DTIME" Case 26 sFormat = "WKDAY" Case 27 sFormat = "MONTH" Case 28 sFormat = "MOYR" Case 29 sFormat = "QYR" Case 30 sFormat = "WKYR" Case 31 sFormat = "PCT" Case 32 sFormat = "DOT" Case 33 sFormat = "CCA" Case 34 sFormat = "CCB" Case 35 sFormat = "CCC" Case 36 sFormat = "CCD" Case 37 sFormat = "CCE" Case 38 sFormat = "EDATE" Case 39 sFormat = "SDATE" End Select If pFracs(Index) > 0 Then xmlElement.setAttribute "format", sFormat & pWidths(Index) & "." & pFracs(Index) Else xmlElement.setAttribute "format", sFormat & pWidths(Index) End If 'Write out column widths xmlElement.setAttribute "columns", pColumnWidths(Index) 'Write out column alignments Select Case pJust(Index) Case 0 xmlElement.setAttribute "align", "Left" Case 1 xmlElement.setAttribute "align", "Right" Case 2 xmlElement.setAttribute "align", "Center" End Select 'Write out Measurement Level ### Case values below were changed 'from strings to numeric (to work with version 11 and up) RL Select Case pMsmtLevels(Index) Case 1 xmlElement.setAttribute "measure", "Nominal" Case 2 xmlElement.setAttribute "measure", "Ordinal" Case 3 xmlElement.setAttribute "measure", "Scale" End Select 'Go ahead and create variable element xmlVars.appendChild xmlElement 'Now append any labels Set xmlLabels = xmlDoc.createElement("labels") xmlElement.appendChild xmlLabels 'Variable label Dim xmlVarLabel 'As IXMLDOMElement Set xmlVarLabel = xmlDoc.createElement("variable") xmlVarLabel.Text = pLabels(Index) xmlLabels.appendChild xmlVarLabel 'Value Labels Dim xmlValueLabel 'As IXMLDOMElement Dim NumValueLabels As Long, i As Long Dim pValues As Variant, pValueLabels As Variant NumValueLabels = objSpssData.GetVariableValueLabels(Index, pValues, pValueLabels) For i = 1 To NumValueLabels Set xmlValueLabel = xmlDoc.createElement("value") xmlValueLabel.setAttribute "id", pValues(i - 1) xmlValueLabel.Text = pValueLabels(i - 1) xmlLabels.appendChild xmlValueLabel Next i Next Index 'Begin writing out data Dim recno As Long, varno As Long Dim xmlDataCell 'As IXMLDOMElement For recno = 1 To NumCases Set xmlElement = xmlDoc.createElement("case") xmlElement.setAttribute "casenum", recno xmlData.appendChild xmlElement For varno = 1 To NumVars Set xmlDataCell = xmlDoc.createElement("spss_var") xmlDataCell.setAttribute "name", pNames(varno - 1) xmlDataCell.Text = SpssData(varno - 1, recno - 1) xmlElement.appendChild xmlDataCell Next varno Next recno 'Save out XML document and then view it! xmlDoc.save sExportTo bSuccess = True EndOfSub: 'Release objects from memory On Error Resume Next Set xmlDoc = Nothing Set objSpssData = Nothing Set objSpssApp = Nothing On Error GoTo 0 If bSuccess = True Then stopTime = Now() sMsg = "File successfully exported to " & sExportTo & Chr(13) & Chr(10) & "(It took " & Format((stopTime - startTime), "nn:ss") & " to complete)" MsgBox sMsg Else If bUserCancelled = False Then MsgBox "There was a problem! Export unsuccessful." End If End Sub