«Обратный» AUTORECODE-2

'* Изначально взято с http://www.spss.com/tech/answer/result.cfm?tech_tan_id=100009245

'-----------------сохраните всё, что ниже, как ReverseAutoRecode10.sbs -------------------------
'Begin Description 
'Данный скрипт работает подобно команде SPSS AUTORECODE (автоперекодирование), но в "обратном" направлении:
'скрипт создаёт новую СТРОКОВУЮ переменную, чьи значения являются метками исходной переменной.
'Это, например, даёт возможность экспортировать файл в другое приложение, сохранив метки.
'Если в открытом редакторе данных нет переменных, либо переменных с метками значений, скрипт информирует об этом пользователя.
'Если перед запуском скрипта пользователь выделил переменную в редакторе данных, в диалоге такая переменная
'оказывается выделенной по умолчанию.
'Если вы хотите локализовать этот скрипт, просто замените содержимое объявленных ниже констант.
' :) - примеч. перев.
'End Description

'Автор: Bernhard Witt, представительство SPSS в Германии

' Перевод: А. Балабанов, 15.11.2008
' Проверено: SPSS 15.0.1.1, есть одно исправление: см. комментарий со значками ###.

'Текстовые константы для взаимодействия с пользователем
'Русскоязычные выражения
Const TextNoVariables = "В редакторе данных отсутствуют переменные."
Const TextNoVarWithLabels = "Отсутствуют переменные с метками значений!"
Const TextTargetAlreadyExist = "Результирующая переменная уже существует. Пожалуйста, укажите другое имя."
Const TextPleaseEnterTarget = "Пожалуйста, укажите имя для результирующей переменной."
Const TextWarning = "Внимание"
Const TextDialogBoxTitle = "Label2String"
Const TextDialogBoxVariable = "Переменная"
Const TextDialogBoxTarget = "Результирующая"
Const TextDialogBoxSource = "Исходная"
Const TextDialogBoxHelp = "Справка"
Const TextHelpText = "Скрипт Label2String создаёт новую строковую переменную, чьими значениями являются" + Chr$(13)+ "метки исходной переменной."+Chr$(13) + Chr$(13)+ "(c) 1997, SPSS Germany - автор: Bernhard Witt"
Const TextHelpTextHead = "Помощь Label2String"
Const TextTargetTooLong = "Имя результирующей переменной слишком длинное (максимум: 8 символов)"

'Англоязычные выражения
'Const TextNoVariables = "There are no variables in the document."
'Const TextNoVarWithLabels = "There are no variables with value labels!"
'Const TextTargetAlreadyExist = "The output variable does already exist. " & _
'"Please enter a new variable name."
'Const TextPleaseEnterTarget = "Please enter a name for the output variable."
'Const TextWarning = "Warning"
'Const TextDialogBoxTitle = "Label to String"
'Const TextDialogBoxVariable = "Variable"
'Const TextDialogBoxTarget = "Output variable"
'Const TextDialogBoxSource = "Input variable"
'Const TextDialogBoxHelp = "Help"
'Const TextHelpText = "Label2String creates a new variable which includes the labels of" + Chr$(13)+ "the input variable as strings."+Chr$(13) + Chr$(13)+ "(c) 1997 by SPSS Germany - Author: Bernhard Witt"
'Const TextHelpTextHead = "Help Label2String"
'Const TextTargetTooLong = "The Output variable is too long (max. 8 characters)"

'Выражения на немецком языке
'Const TextNoVariables = "Es sind keine Variablen vorhanden."
'Const TextNoVarWithLabels = "Es sind keine Variablen mit Wertelabels vorhanden!" 
'Const TextTargetAlreadyExist = "Die Zielvariable ist bereits vorhanden. Bitte geben Sie eine andere Variable an." 
'Const TextPleaseEnterTarget = "Bitte geben Sie eine Zielvariable ein." 
'Const TextWarning = "Achtung" 
'Const TextDialogBoxTitle = "Label2String" 
'Const TextDialogBoxVariable = "Variable" 
'Const TextDialogBoxTarget = "Zielvariable" 
'Const TextDialogBoxSource = "Ausgangsvariable" 
'Const TextDialogBoxHelp = "Hilfe" 
'Const TextHelpText = "Label2String erstellt eine neue Variable," & _ 
' " in der die Labels der" _ 
' + Chr$(13)+ "Ausgangsvariable als String verwendet werden." _ 
' +Chr$(13) + "(Label2String ist somit das Gegenteil von Autorecode)" _ 
' +Chr$(13) + Chr$(13) + "(c) 1997 by SPSS Germany - Autor: Bernhard Witt" 
'Const TextHelpTextHead = "Hilfe zu Label2String" 
'Const TextTargetTooLong = "Die Zielvariable ist lдnger als 8 Zeichen" 

Public dlg 'Объект диалога с пользователем
Public VarLabel$() 'Массив с метками значений выделенной переменной
Public VarWert() 'Массив со значениями выделенной переменной
Public Variablenliste$() 'Массив, включающий все переменные, имеющие, по крайней мере,
'одну метку значения
Public AnzLabVariablen 'число помеченных значений выделенной переменной
Public BigVarliste$() 'массив со всеми переменными файла данных
Public BigVarlistedim 'число элементов массива BigVarListe$(), определённого выше
Public selectedVariable 'порядковый номер выделенной переменной в массиве Variablenliste$(), определённом выше

Sub Main 

Call GetVariablenliste 
If AnzLabVariablen > 0 Then 
Call myDialog 
Else 
MsgBox TextNoVarWithLabels,64,TextWarning 
End If 

End Sub 

'######################################################################### 
Function Label2String (Varnummer, Varneu$) As String 
'######################################################################### 
Dim strCommands As String 
Dim objDataDoc As ISpssDataDoc 

Set objDocuments=objSpssApp.Documents 
Set objDataDoc = objDocuments.GetDataDoc(0) 

Dim i As Integer 
Dim strVarName As String 
Dim lngVarNum As Long 
Dim Variables 

strVarName = Variablenliste$(Varnummer) 
Variables = objDataDoc.GetVariables(False) 
For i = 0 To objDataDoc.GetNumberOfVariables - 1 
If Variables(i) = strVarName Then 
lngVarNum = i 
Exit For 
End If 
Next 

Dim strRecode As String 
Dim strOldVar As String 

strOldVar = Variablenliste$(Varnummer) 
strRecode = BuildRecode(objDataDoc, lngVarNum, strOldVar, Varneu) 
strCommands = strCommands & strRecode & vbCrLf & "Execute ." 

Label2String = strCommands 
End Function 

'######################################################################### 
Sub myDialog 
'Создание диалогового окна
'######################################################################### 
Begin Dialog UserDialog 450,126,TextDialogBoxTitle,.Maskenfunktion 
GroupBox 10,7,320,105,TextDialogBoxVariable,.Variable 
TextBox 20,42,110,21,.Varneu 
ListBox 160,42,140,63,Variablenliste(),.ListBox1 
Text 20,28,150,14,TextDialogBoxTarget,.Text2 
Text 160,28,120,14,TextDialogBoxSource,.Text3 
OKButton 360,7,70,21 
PushButton 360,91,70,21,TextDialogBoxHelp,.Hilfe 
CancelButton 360,63,70,21,.Abbrechen 
PushButton 360,35,70,21,"Paste",.PasteSyntax 
End Dialog 

Dim strCommands As String 
Dim dlg As UserDialog 
dlg.ListBox1 = selectedVariable 
erg=Dialog (dlg) 
If erg = -1 Then 
strCommands = Label2String (dlg.ListBox1,dlg.Varneu) 
objSpssApp.ExecuteCommands strCommands, False 
End If 
If erg = 2 Then 
Dim objSyntax As ISpssSyntaxDoc 
With objSpssApp.Documents 
If .SyntaxDocCount < 1 Then 
Set objSyntax = objSpssApp.NewSyntaxDoc 
Else 
Set objSyntax = objSpssApp.GetDesignatedSyntaxDoc 
End If 
objSyntax.Text = objSyntax.Text & vbCrLf & _
Label2String(dlg.ListBox1, dlg.Varneu) 
objSyntax.Visible = True 
End With 
End If 

End Sub 

'######################################################################### 
Function Maskenfunktion(SteuerelementBez As String, Aktion As Integer , _
ZusatzWert As Integer ) As Boolean 
'######################################################################### 
Select Case Aktion 
Case 1 ' Инициализация
Case 2 ' Активирован элемент управления диалога
Select Case SteuerelementBez 
Case "OK" 
If Len (DlgText$("varneu")) = 0 Then 
MsgBox TextPleaseEnterTarget,64,TextWarning 
DlgFocus "varneu" 
Maskenfunktion=True 
End If 
If Len (DlgText$("varneu")) > 8 Then 
MsgBox TextTargetTooLong,64,TextWarning 
DlgFocus "varneu" 
Maskenfunktion=True 
Else 
			'Проверка, не существует ли уже переменной с именем, определённым пользователем для результирующей переменной.
			'Если так, сообщаем об этом и не покидаем диалог
Valid=1
For count = 0 To BigVarlistedim 
If UCase$(DlgText$("Varneu")) = _
UCase$(BigVarListe$(count)) Then 
valid = 0 
End If 
Next 
If valid = 0 Then 
MsgBox TextTargetAlreadyExist,64,TextWarning 
Maskenfunktion=True 
Else 
Maskenfunktion=False 
End If 
End If 

Case "Hilfe" 
MsgBox TextHelpText, 64, TextHelpTextHead 
Maskenfunktion=True 
Case Else 
Maskenfunktion=False 
End Select 
Case 3 ' Изменилось текстовое поле

Case 4 ' Сменился фокус

Case 5 ' Ничего (не делаем)

Case Else 

End Select 

End Function 

'######################################################################### 
Sub GetVariablenliste 
'Создаёт список всех переменных, имеющих метки значений
'######################################################################### 

Dim objSpssInfo As ISpssInfo 
Dim strVarName As String, strLabel As String 

Set objSpssInfo=objSpssApp.SpssInfo 

'Определение выбранной пользователем в редакторе данных переменной, если такая есть
Dim Anfang As Long, Ende As Long 
Dim Selektiert As Long 
temp = objSpssInfo.GetSelectedVariables (Anfang, Ende) 
Selektiert=Anfang 

Dim AnzVariablen As Integer, countvar As Integer 
AnzVariablen = objSpssInfo.NumVariables 

If AnzVariablen > 0 Then 
	'подсчёт числа переменных, которые используют, по крайней мере, одну метку значения и
	'сохранение списка имён таких переменных
AnzLabVariablen = 0 

ReDim BigVarListe$(AnzVariablen - 1) 
BigVarlisteDim = AnzVariablen - 1 

'подсчёт число переменных, имеющих не менее одной метки значения
For count = 0 To AnzVariablen-1 
BigVarListe$(count) = objSpssInfo.VariableAt(count) 
If objSpssInfo.NumberOfValueLabels(count) >0 Then 
AnzLabVariablen = AnzLabVariablen + 1 
End If 
Next 

'Если есть хотя бы одно переменная с метками значений, строим массив имён таких переменных
If AnzLabVariablen>0 Then 
ReDim Variablenliste$(AnzLabVariablen-1) 

mycount=0 
For count = 0 To AnzVariablen-1 
If objSpssInfo.NumberOfValueLabels(count)>0 Then 
Variablenliste$(mycount) = objSpssInfo.VariableAt(count)
'если текущая переменная выделена пользователем ещё в редакторе данных, делаем её переменной, выделенной в диалоге по умолчанию
If count=Selektiert-1 Then '### добавлено -1, иначе выделяется не та переменная - примеч. перев.
selectedVariable = mycount 
End If 
mycount = mycount+1 
End If 
Next 
End If 
Else 
MsgBox TextNoVariables,64,TextWarning 
End If 

End Sub 

Function BuildRecode(objDataDoc As ISpssDataDoc, lngVar As Long, _
strOldName As String, strNewName As String) As String
' Объявление переменных для хранения информации о метках значений.
Dim numValueLabels As Long 
Dim vntValueLabelCounts As Variant 
Dim vntValueLabels As Variant 
Dim strRecode As String 

Dim MaxLabelLength As Integer 
Dim LabelLength As Integer 

' Для каждой переменной получим число меток значений и сами метки.
numValueLabels = objDataDoc.GetVariableValueLabels (lngVar, _
vntValues, vntValueLabels) 
' Для отладки: распечатаем информацию о метках.
Debug.Print "Переменная: " & lngVar & vbTab & "Метки: " & numValueLabels

' Цикл по меткам, печатаем значение и метку.
Dim i As Long 
' при необходимости ставим кавычки вокруг строковых значений
AddQuotes vntValues 
AddQuotes vntValueLabels 
For i = 0 To numValueLabels - 1 
Debug.Print vntValues(i) & ":" & vntValueLabels(i) 
LabelLength = Len(vntValueLabels(i)) 
If MaxLabelLength < LabelLength Then 
MaxLabelLength = LabelLength 
End If 
strRecode = strRecode & " (" & vntValues(i) & "=" & _
vntValueLabels(i) & ")" & vbCrLf 
Next 

strRecode = "RECODE " & vbCrLf & " " & strOldName & vbCrLf & strRecode 
strRecode = strRecode & " INTO " & strNewName & " ." 

strRecode = "STRING " & strNewName & "(A"+LTrim$(Str$(MaxLabelLength))+")." _
& vbCrLf & strRecode 

BuildRecode = strRecode 
End Function 

Sub AddQuotes(vntArray As Variant) 
' Цикл по массиву, добавление кавычек к строковым значениям.
Dim i As Long 

If VarType(vntArray) = (vbString + vbArray) Then 
Debug.Print "Добавление кавычек к строковым значениям:"
Else 
Exit Sub 
End If 

For i = 0 To UBound(vntArray) 
If VarType(vntArray(i)) = vbString Then 
vntArray(i) = "'" & Trim$(vntArray(i)) & "'" 
End If 
Debug.Print vntArray(i) 
Next 
End Sub