Export content of data editor to XML format v2

 

Download as .sbs Shows as plain text

 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
'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
Related pages

...

Navigate from here