'* 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