Reverse auto recode10

'* This comes from http://www.spss.com/tech/answer/result.cfm?tech_tan_id=100009245

'-----------------save As ReverseAutoRecode10.sbs ------------------------- 
'Begin Description 
'This script works like Autorecode, but in the other direction: 
'The script generates a new string variable which values are equal 
'to the labels of the source variable. 
'So someone can export a variable to other applications with saving 
'his labels. 
'If there are no variables or no variables with labels in the current 
'document, a warning appears. 
'If a variable is selected while entering this script, the variable is selected 
'as default in the dialog box 
'If you like to translate the script into other languages, simple change the text 
'in the following lines 

'End Description 

'Author: Bernhard Witt, SPSS Germany 

'Constants for Textoutput 
'English expressions 
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)" 

'German expressions 
'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 'Dialog box 
Public VarLabel$() 'Array with the actual Valuelabels of the selected variable 
Public VarWert() 'Array with the actual Values of the selected variable 
Public Variablenliste$() 'Array with includes all variables with at least one 
'value label 
Public AnzLabVariablen 'number of valuelabels of the selected variable 
Public BigVarliste$() 'Array with a all variables of the document 
Public BigVarlistedim 'number of elements in BigVarListe$() 
Public selectedVariable 'the number of the selected variable in 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 
'Dim lngVarNum As Long 
'lngVarNum = Varnummer 
strOldVar = Variablenliste$(Varnummer) 
strRecode = BuildRecode(objDataDoc, lngVarNum, strOldVar, VarNeu) 
strCommands = strCommands & strRecode & vbCrLf & "Execute ." 

Label2String = strCommands 
End Function 

'######################################################################### 
Sub myDialog 
'Creates Dialog Box 
'######################################################################### 
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 ' Init 
Case 2 ' A Dialogfield was selected 
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 
'Check, if the new variable name is already in use 
'if so, then msgbox and do not leave dialog box 
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 ' Textfield was changed 

Case 4 ' focus has changed 

Case 5 ' nothing else to do 

Case Else 

End Select 

End Function 

'######################################################################### 
Sub GetVariablenliste 
'creates a list with all variables, which are using labels 
'######################################################################### 

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

Set objSpssInfo=objSpssApp.SpssInfo 

'determine the selected variable, if exist 
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 
'count the variables, which are using at least one label 
'and store all variable names 
AnzLabVariablen = 0 

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

'count variables with at least one label 
For count = 0 To AnzVariablen-1 
BigVarListe$(count) = objSpssInfo.VariableAt(count) 
If objSpssInfo.NumberOfValueLabels(count) >0 Then 
AnzLabVariablen = AnzLabVariablen + 1 
End If 
Next 

'If ther exist at leas one variable with a label, build the varlist- 
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 the aktual variable is selected, 
'then store the index in 
If count=Selektiert Then 
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
' Declare variables to receive the value label information. 
Dim numValueLabels As Long 
Dim vntValueLabelCounts As Variant 
Dim vntValueLabels As Variant 
Dim strRecode As String 

Dim MaxLabelLength As Integer 
Dim LabelLength As Integer 

' For the each variable, get the number of value labels 
' and the value label information. 
numValueLabels = objDataDoc.GetVariableValueLabels (lngVar, _
vntValues, vntValueLabels) 
' Print the number of value labels for the variable. 
Debug.Print "Variable: " & lngVar & vbTab & "Labels: " & numValueLabels 

' Loop through the number of value labels, printing the value and label. 
Dim i As Long 
' put quotes around string values if needed 
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) 
' Loop through the array, adding quotes to string values. 
Dim i As Long 

If VarType(vntArray) = (vbString + vbArray) Then 
Debug.Print "Adding quotes to string values:" 
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