Экспорт файла данных SPSS в XML-файл

 

Загрузить как .sbs Показать простым текстом

 

  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
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
'Begin Description
'Данный скрипт создаёт XML-файл из файла данных SPSS (из первого открытого набора данных в версиях SPSS после 14.0 - прим. перев.).
'Скрипт запрашивает у пользователя
'путь и имя XML-файла, который будет содержать экспорт. В качестве альтернативы можно вызывать
'скрипт из синтаксиса и передавать ему имя файла в качестве параметра
'(например: SCRIPT td_ExportAsXML.sbs ("C:\\Windows\\Desktop\\output.xml").
'End Description

'Автор:  Tom Dierickx
'Создан: 15.07.2001


'ВНИМАНИЕ! При использовании скрипта с версиями SPSS от 11.0 и далее, см. изменения, предложенные Рейналем Левек
 26.07.2002 (после метки ### в коде).


'Перевод: А.Балабанов, 10.11.2008.
'Проверено: SPSS 15.0.1.1.

'Для работы скрипта необходимо установить обработчик кода XML: Microsoft XML parser, не ниже версии 3.0.
' (скачивается с сайта Microsoft: http://msdn2.microsoft.com/en-us/xml/default.aspx)
'На ноябрь 2008 г. это приложение называлось MS XML Core Services (MSXML) 6.0 - примеч. перев.

Sub Main()
On Error GoTo EndOfSub
   
'Закомментируйте следующую строку, если скрипт выполняется непосредственно из-под SPSS как .sbs-файл.
'Снимите комментарий, если скрипт выполняется из-под внешней программы (например, из MS Word).
'Эта строка создаёт ссылку на приложение SPSS, которая не нужна, если скрипт выполняется непосредственно из этого приложения - примеч. перев.
   'Set objSpssApp = GetObject(, "SPSS.Application")
   
'Объявление переменных
   Dim bSuccess                              ' True, если экспорт прошёл удачно
   Dim bUserCancelled                        ' True, если пользователь нажал Cancel (Отмена) при запросе имени файла
   Dim sExportTo                             ' Будет хранить место назначения экспорта (путь, имя файла)
   
   Dim objSpssData As Variant           	 ' Ссылка на активный файл данных SPSS (первый открытый набор данных)
   Dim Index As Long                         ' Индекс текущей переменной
   Dim NumVars As Long                       ' Хранит число переменных
   Dim NumCases As Long                      ' Хранит число наблюдений
   Dim SpssData As Variant                   ' Массив с матрицей для данных SPSS
   Dim pNames As Variant                     ' Массив для хранения имен переменных
   Dim pLabels As Variant                    ' Массив для хранения меток переменных
   Dim pMsmtLevels As Variant                ' Массив для хранения шкал переменных
   Dim pLabelCounts As Variant               ' A variant array to store the number of value labels for the variable
   Dim pTypes As Variant                     ' Массив для хранения типов переменных
   Dim pFormats As Variant                   ' Массив для хранения форматов переменных
   Dim pWidths As Variant                    ' Массив для хранения числа знаков для каждой переменной
   Dim pFracs As Variant                     ' Массив для хранения числа знаков после запятой для каждой переменной
   Dim pColumnWidths As Variant              ' Массив для хранения ширины видимой колонки каждой переменной
   Dim pJust As Variant                      ' Массив для хранения выключки переменных (лево/право/центр)
   
   Dim xmlDoc 'As MSXML2.DOMDocument30        ' Хранит ссылку на XML-документ экспорта
   Dim xmlRoot 'As MSXML2.IXMLDOMElement      ' Хранит ссылку на корневой элемент XML
   Dim xmlPI 'As MSXML2.IXMLDOMProcessingInstruction   'Хранит информацию о версии XML
   Dim xmlInfo 'As MSXML2.IXMLDOMNode         ' Хранит ссылку на раздел с общей информацией о документе SPSS
   Dim xmlVars 'As MSXML2.IXMLDOMNode         ' Хранит ссылку на раздел описания переменных
   Dim xmlLabels 'As MSXML2.IXMLDOMNode       ' Хранит ссылку на раздел меток
   Dim xmlData 'As MSXML2.IXMLDOMNode         ' Хранит ссылку на раздел данных
   Dim xmlElement 'As MSXML2.IXMLDOMElement   ' Используется для ссылки на различные элементы XML-документа

   Dim startTime As Date                     ' Хранит время начала процедуры экспорта
   Dim stopTime As Date                      ' Хранит время завершения процедуры экспорта


'Устанавливаем ссылку на активный SPSS Data-документ и создаём новый XML-документ в памяти
   Set objSpssData = objSpssApp.Documents.GetDataDoc(0)
   Set xmlDoc = CreateObject("Msxml2.DOMDocument.3.0")

'Если пользователь передал (через синтаксис) необязательный параметр с путём и именем файла экспорта,
'используем переданное, иначе - запрашиваем пользователя.
   sExportTo = objSpssApp.ScriptParameter (0)	
   If Len(sExportTo) = 0 Then 
      Dim sDefaultPath As String
      sDefaultPath = Left(objSpssData.GetDocumentPath,Len(objSpssData.GetDocumentPath)-4) & ".xml"
      sExportTo = InputBox("Укажите путь к файлу экспорта:",,sDefaultPath)
      
      'Проверяем, не отменил ли пользователь экспорт. Если отменил - аккуратно выходим из процедуры
      If Len(sExportTo) = 0 Then 
      	bUserCancelled = True
      	GoTo EndOfSub
      End If
   End If
   
'Начало экспорта. Фиксируем время.
   startTime = Now()

'Получаем информацию о переменных SPSS
   Call objSpssData.GetVariableInfo(pNames, pLabels, pTypes, pMsmtLevels, pLabelCounts)
   Call objSpssData.GetVariableFormats(pFormats, pWidths, pFracs)
   Call objSpssData.GetVariableColumnWidths(pColumnWidths)
   Call objSpssData.GetVariableJustification(pJust)
   
'Определяем число переменных и наблюдений
   NumVars = objSpssData.GetNumberOfVariables
   NumCases = objSpssData.GetNumberOfCases
   SpssData = objSpssData.GetTextData(pNames(0), pNames(NumVars - 1), 1, NumCases)

'Создаём корневой элемент XML
   Set xmlRoot = xmlDoc.createElement("sav_file")
   xmlDoc.appendChild xmlRoot
   
'Добавляем информацию о версии XML
   Set xmlPI = xmlDoc.createProcessingInstruction("xml", "version=""1.0""")
   xmlDoc.InsertBefore xmlPI, xmlRoot
   
'Добавляем секцию с общей информацией о файле
   Set xmlInfo = xmlDoc.createElement("info")
   xmlRoot.appendChild xmlInfo
   
'Добавляем секцию с информацией о переменных
   Set xmlVars = xmlDoc.createElement("variables")
   xmlRoot.appendChild xmlVars
   
'Добавляем секцию данных
   Set xmlData = xmlDoc.createElement("data")
   xmlRoot.appendChild xmlData
   
'Обновляем секцию с общей информацией о файле
   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
   
'Обновляем секцию с информацией о переменных
   For Index = 0 To (NumVars - 1)
      Set xmlElement = xmlDoc.createElement("spss_var")
      xmlElement.setAttribute "name", pNames(Index)
      
      'Записываем тип переменной
      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
            
      'Записываем число знаков переменной
      xmlElement.setAttribute "width", pWidths(Index)
      
      'Записываем число знаков после запятой
      xmlElement.setAttribute "decimals", pFracs(Index)
            
      'Записываем формат переменной
      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
            
      'Записываем ширину видимой колонки
      xmlElement.setAttribute "columns", pColumnWidths(Index)
            
      'Записываем выключку переменной
      Select Case pJust(Index)
      Case 0
         xmlElement.setAttribute "align", "Left"
      Case 1
         xmlElement.setAttribute "align", "Right"
      Case 2
         xmlElement.setAttribute "align", "Center"
      End Select
      
      'Записываем тип шкалы переменной
      '### При работе с SPSS версий от 11.0 и далее, снимите с меток случаев (Case) кавычки.
      'В позднейших версиях SPSS они имеют числовой, а не строковый тип - Raynald Levesque.
      Select Case pMsmtLevels(Index)
      Case "1"
         xmlElement.setAttribute "measure", "Nominal"
      Case "2"
         xmlElement.setAttribute "measure", "Ordinal"
      Case "3"
         xmlElement.setAttribute "measure", "Scale"
      End Select
      
      'Обновляем весь элемент с информацией о переменной
      xmlVars.appendChild xmlElement
      
      'Теперь добавляем информацию о метках
      Set xmlLabels = xmlDoc.createElement("labels")
      xmlElement.appendChild xmlLabels
      
         'Метака переменной
         Dim xmlVarLabel 'As IXMLDOMElement
         
         Set xmlVarLabel = xmlDoc.createElement("variable")
         xmlVarLabel.Text = pLabels(Index)
         xmlLabels.appendChild xmlVarLabel
         
         'Мети значений
         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

'Начало записи данных
   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

'Сохраняем созданный XML-документ
   xmlDoc.save sExportTo
   bSuccess = True
      
EndOfSub:
   'Освобождаем память от созданных объектов
   On Error Resume Next
    Set xmlDoc = Nothing
    Set objSpssData = Nothing
    Set objSpssApp = Nothing
   On Error GoTo 0
   
   If bSuccess = True Then
   	stopTime = Now()
   	sMsg = "Файл успешно экспортирован в " & sExportTo & Chr(13) & Chr(10) & "(Время экспорта: " & Format((stopTime - startTime), "nn:ss") & " мин:сек)"
   	MsgBox sMsg
   Else
   	If bUserCancelled = False Then MsgBox "Возникли проблемы! Экспорт не выполнен."
   End If
End Sub

© Raynald Levesque 2001—09, Антон Ба
Related pages

...

Navigate from here