'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, Антон Ба