'Begin description ' Script to extract part of the dictionary and write it as SPSS commands into a syntax window. ' Run this script with a datafile opened. ' The script writes the variable and value labels, ' the formats and the missing values as SPSS commands to a syntax window. ' If necessary change below the decimal comma to a decimal point; it is indicated below. ' ' Author unknown; pieces of code by Ondrej Hava and Jan Spousta ' modified and extended by Hans Grüner (http://userpage.fu-berlin.de/~gruener/), ' March 29th, 2007 'End description Option Explicit Sub Main() Dim objSPSSInfo As ISpssInfo Dim objDataDoc As ISpssDataDoc Dim NumVars, NbVariables As Long Dim NumVals, NbVals As Long Dim D, K, I, J, L, M, N, O, P As Long Dim vrtVarType, vrtVarWidth, vrtVarFract As Variant Dim vrtMissingCounts, vrtMissingValues As Variant Dim vrtNames, vrtLabels, vrtTypes, vrtMsmtLevels, vrtLabelCounts, vrtJust As Variant Dim VarName, VarName2, VName As String Dim VarLabel As String Dim ValName, ValLabel As String Dim Value() As String Dim VarStorage As String Dim ValStorage As String Dim FormatStorage As String Dim MissStorage As String Dim MLevelStorage As String Dim AlignStorage As String Dim WeightStorage As String Dim SyntaxText As String Dim SyntaxWindow As ISpssSyntaxDoc Dim Infos As String Dim LenValStorage As Long Dim LenVarStorage As Long Dim LenMissStorage As Long Dim LenForStorage As Long Dim LenMLevelStorage As Long Dim LenAlignStorage As Long Dim LenWeightStorage As Long Dim c1, c2, c3, c4, c5, c6, c7 As Integer Set objSPSSInfo = objSpssApp.SpssInfo Set objDataDoc = objSpssApp.Documents.GetDataDoc(0) objDataDoc.GetVariableFormats(vrtVarType, vrtVarWidth, vrtVarFract) 'Variable Formats objDataDoc.GetVariableMissingValues(vrtMissingCounts, vrtMissingValues) 'Missing values objDataDoc.GetVariableInfo (vrtNames, vrtLabels, vrtTypes, vrtMsmtLevels, vrtLabelCounts) objDataDoc.GetVariableJustification (vrtJust) NumVars=objSPSSInfo.NumVariables-1 NbVariables = objSPSSInfo.NumVariables If NbVariables < 1 Then Beep MsgBox("Please open a data file first!" & vbCrLf & "Bitte zuerst eine Datendatei öffnen!",0,"Error/Fehler") End End If ' English Texts in User Dialog 'Begin Dialog UserDialog 400,290,"Dictionary Syntax Generator",.dlgFunction ' %GRID:10,7,1,1 ' Text 40,14,290,14,"Which commands should the syntax contain?",.Text1 ' CheckBox 40,49,150,14,"Variable labels",.CheckBox1 ' CheckBox 40,77,120,14,"Value labels",.CheckBox2 ' CheckBox 40,105,170,14,"Formats of variables",.CheckBox3 ' CheckBox 40,133,140,14,"Missing values",.CheckBox4 ' CheckBox 40,161,170,14,"Measurement levels",.CheckBox5 ' CheckBox 40,189,185,14,"Alignment of variables",.CheckBox6 ' CheckBox 40,243,180,14,"Weighting of the data",.CheckBox7 ' OKButton 280,49,90,21 ' CancelButton 280,79,90,21 ' PushButton 280,120,90,21,"All",.PushButton1 ' PushButton 280,150,90,21,"None",.PushButton2 'End Dialog ' Deutsche Texte im Nutzerdialog Begin Dialog UserDialog 400,290,"Lexikon (Dictionary) - Syntaxgenerierung",.dlgFunction ' %GRID:10,7,1,1 Text 40,14,290,14,"Auswahl der zu schreibenden Anweisungen!",.Text1 CheckBox 40,49,150,14,"Variablenlabel",.CheckBox1 CheckBox 40,77,120,14,"Wertelabel",.CheckBox2 CheckBox 40,105,170,14,"Formate der Variablen",.CheckBox3 CheckBox 40,133,140,14,"Fehlende Werte",.CheckBox4 CheckBox 40,161,170,14,"Messniveau",.CheckBox5 CheckBox 40,189,185,14,"Ausrichtung der Variablen",.CheckBox6 CheckBox 40,243,180,14,"Gewichtung der Daten",.CheckBox7 OKButton 280,49,90,21 CancelButton 280,79,90,21 PushButton 280,120,90,21,"Alle",.PushButton1 PushButton 280,150,90,21,"Keine",.PushButton2 End Dialog Dim dlg As UserDialog On Error GoTo out Dialog dlg c1 = dlg.CheckBox1 c2 = dlg.CheckBox2 c3 = dlg.CheckBox3 c4 = dlg.CheckBox4 c5 = dlg.CheckBox5 c6 = dlg.CheckBox6 c7 = dlg.CheckBox7 Set SyntaxWindow = objSpssApp.NewSyntaxDoc SyntaxWindow.Visible = True Infos = "**********************************************************************" & vbCrLf Infos = Infos & "* Dictionary Information as SPSS Commands" & vbCrLf Infos = Infos & "* (as selected)" & vbCrLf Infos = Infos & "**********************************************************************." & vbCrLf & vbCrLf Infos = Infos & "* Date: " & Now & "." & vbCrLf & vbCrLf VarStorage = "" ValStorage = "" FormatStorage = "" MissStorage = "" MLevelStorage = "" AlignStorage = "" WeightStorage = "" ' the VARIABLE LABELS command If c1 = 1 Then VarStorage = VarStorage & "Variable Labels" & vbCrLf For I=0 To NumVars VarName= objSPSSInfo.VariableAt(I) VarLabel= objSPSSInfo.VariableLabelAt(I) If Len(VarLabel)=0 Then GoTo nextI End If VarStorage = VarStorage & " " & VarName & " " & "'" & VarLabel & "'" & vbCrLf nextI: Next I VarStorage = VarStorage & "." & vbCrLf & vbCrLf End If ' the VALUE LABELS command If c2 = 1 Then ValStorage = ValStorage & "Value Labels" & vbCrLf For L=0 To NumVars VarName2= objSPSSInfo.VariableAt(L) NumVals= objSPSSInfo.NumberOfValueLabels(L)-1 NbVals= objSPSSInfo.NumberOfValueLabels(L) If NbVals>0 And (vrtVarType(L)=1 Or vrtVarType(L)=5) Then ValStorage = ValStorage & " /" & VarName2 & vbCrLf End If For K=0 To NumVals ValName= objSPSSInfo.ValueAt(L,K) VName= objSPSSInfo.ValueAt(L,K) ValLabel= objSPSSInfo.ValueLabelAt(L,K) If Len(ValLabel)=0 Then ValLabel=ValName End If If vrtVarType(L)=1 Then ValStorage = ValStorage & " " & " " & "'" & ValName & "'" & " " & "'" & ValLabel & "'" & vbCrLf GoTo nextK End If If vrtVarType(L)<>5 Then GoTo nextL End If Value= Split(ValName, ".") ' Change "." here to "," (Decimal Comma), if necessary!!! ValName = Value(0) If Value(1)<> "000000" Then ValName=VName End If ValStorage = ValStorage & " " & " " & ValName & " " & "'" & ValLabel & "'" & vbCrLf nextK: Next K nextL: Next L ValStorage = ValStorage & "." & vbCrLf End If ' the FORMATS command If c3 = 1 Then FormatStorage = FormatStorage & vbCrLf & "Formats" & vbCrLf For M=0 To NumVars VarName= objSPSSInfo.VariableAt(M) Select Case vrtVarType(M) Case 1 'SpssPrintFormatA FormatStorage = FormatStorage & " " & VarName & " (A" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 2 'SpssPrintFormatAhex FormatStorage = FormatStorage & " " & VarName & " (AHEX" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 3 'SpssPrintFormatComma FormatStorage = FormatStorage & " " & VarName & " (COMMA" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 4 'SpssPrintFormatDollar FormatStorage = FormatStorage & " " & VarName & " (DOLLAR" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 5 'SpssPrintFormatF FormatStorage = FormatStorage & " " & VarName & " (F" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 6 'SpssPrintFormatIb FormatStorage = FormatStorage & " " & VarName & " (IB" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 7 'SpssPrintFormatPibhex FormatStorage = FormatStorage & " " & VarName & " (PIBHEX" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 8 'SpssPrintFormatP FormatStorage = FormatStorage & " " & VarName & " (P" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 9 'SpssPrintFormatPib FormatStorage = FormatStorage & " " & VarName & " (PIB" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 10 'SpssPrintFormatPk FormatStorage = FormatStorage & " " & VarName & " (PK" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 11 'SpssPrintFormatRb FormatStorage = FormatStorage & " " & VarName & " (RB" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 12 'SpssPrintFormatRbhex FormatStorage = FormatStorage & " " & VarName & " (RBHEX" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 15 'SpssPrintFormatZ FormatStorage = FormatStorage & " " & VarName & " (Z" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 16 'SpssPrintFormatN FormatStorage = FormatStorage & " " & VarName & " (N" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 17 'SpssPrintFormatE FormatStorage = FormatStorage & " " & VarName & " (E" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 20 'SpssPrintFormatDate FormatStorage = FormatStorage & " " & VarName & " (DATE" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 21 'SpssPrintFormatTime FormatStorage = FormatStorage & " " & VarName & " (TIME" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 22 'SpssPrintFormatDatetime FormatStorage = FormatStorage & " " & VarName & " (DATETIME" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 23 'SpssPrintFormatAdate FormatStorage = FormatStorage & " " & VarName & " (ADATE" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 24 'SpssPrintFormatJdate FormatStorage = FormatStorage & " " & VarName & " (JDATE" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 25 'SpssPrintFormatDtime FormatStorage = FormatStorage & " " & VarName & " (DTIME" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 26 'SpssPrintFormatWkday FormatStorage = FormatStorage & " " & VarName & " (WKDAY" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 27 'SpssPrintFormatMonth FormatStorage = FormatStorage & " " & VarName & " (MONTH" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 28 'SpssPrintFormatMoyr FormatStorage = FormatStorage & " " & VarName & " (MOYR" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 29 'SpssPrintFormatQyr FormatStorage = FormatStorage & " " & VarName & " (QYR" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 30 'SpssPrintFormatWkyr FormatStorage = FormatStorage & " " & VarName & " (WKYR" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 31 'SpssPrintFormatPct FormatStorage = FormatStorage & " " & VarName & " (PCT" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 32 'SpssPrintFormatDot FormatStorage = FormatStorage & " " & VarName & " (DOT" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & vbCrLf Case 33 'SpssPrintFormatCca FormatStorage = FormatStorage & " " & VarName & " (CCA" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & " ' nur Ausgabeformat/Output Format Only!" & vbCrLf Case 34 'SpssPrintFormatCcb FormatStorage = FormatStorage & " " & VarName & " (CCB" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & " ' nur Ausgabeformat/Output Format Only!" & vbCrLf Case 35 'SpssPrintFormatCcc FormatStorage = FormatStorage & " " & VarName & " (CCC" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & " ' nur Ausgabeformat/Output Format Only!" & vbCrLf Case 36 'SpssPrintFormatCcd FormatStorage = FormatStorage & " " & VarName & " (CCD" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & " ' nur Ausgabeformat/Output Format Only!" & vbCrLf Case 37 'SpssPrintFormatCce FormatStorage = FormatStorage & " " & VarName & " (CCE" & CStr(vrtVarWidth(M)) & "." & CStr(vrtVarFract(M)) & ")" & " ' nur Ausgabeformat/Output Format Only!" & vbCrLf Case 38 'SpssPrintFormatEdate FormatStorage = FormatStorage & " " & VarName & " (EDATE" & CStr(vrtVarWidth(M)) & ")" & vbCrLf Case 39 'SpssPrintFormatSdate FormatStorage = FormatStorage & " " & VarName & " (SDATE" & CStr(vrtVarWidth(M)) & ")" & vbCrLf End Select Next M FormatStorage = FormatStorage & "." & vbCrLf End If ' the MISSING VALUES command If c4 = 1 Then MissStorage = MissStorage & vbCrLf & "Missing Values" & vbCrLf For N=0 To NumVars VarName= objSPSSInfo.VariableAt(N) If vrtVarType(N)=5 And vrtMissingCounts(N)=1 Then MissStorage = MissStorage & " " & "/" & VarName & "(" & CStr(vrtMissingValues(N,0)) & ")" & vbCrLf ElseIf vrtVarType(N)=5 And vrtMissingCounts(N)=2 Then MissStorage = MissStorage & " " & "/" & VarName & "(" & CStr(vrtMissingValues(N,0)) & "," & CStr(vrtMissingValues(N,1)) & ")" & vbCrLf ElseIf vrtVarType(N)=5 And vrtMissingCounts(N)=3 Then MissStorage = MissStorage & " " & "/" & VarName & "(" & CStr(vrtMissingValues(N,0)) & "," & CStr(vrtMissingValues(N,1)) & "," & CStr(vrtMissingValues(N,2)) & ")" & vbCrLf ElseIf vrtVarType(N)=5 And vrtMissingCounts(N)=-2 Then MissStorage = MissStorage & " " & "/" & VarName & "(" & CStr(vrtMissingValues(N,0)) & " to " & CStr(vrtMissingValues(N,1)) & ")" & vbCrLf ElseIf vrtVarType(N)=5 And vrtMissingCounts(N)=-3 Then MissStorage = MissStorage & " " & "/" & VarName & "(" & CStr(vrtMissingValues(N,0)) & " to " & CStr(vrtMissingValues(N,1)) & "," & CStr(vrtMissingValues(N,2)) & ")" & vbCrLf End If Next N MissStorage = MissStorage & "." & vbCrLf End If ' the MEASUREMENT LEVEL command If c5 = 1 Then MLevelStorage = MLevelStorage & vbCrLf & "Variable Level" & vbCrLf For O=0 To NumVars VarName= objSPSSInfo.VariableAt(O) Select Case vrtMsmtLevels(O) Case 1 'nominal MLevelStorage = MLevelStorage & " " & "/" & VarName & "(NOMINAL)" + vbCrLf Case 2 'ordinal MLevelStorage = MLevelStorage & " " & "/" & VarName & "(ORDINAL)" + vbCrLf Case 3 'scale MLevelStorage = MLevelStorage & " " & "/" & VarName & "(SCALE)" + vbCrLf End Select Next O MLevelStorage = MLevelStorage & "." & vbCrLf End If ' the ALIGNMENT command If c6 = 1 Then AlignStorage = AlignStorage & vbCrLf & "Variable Alignment" & vbCrLf For P=0 To NumVars VarName= objSPSSInfo.VariableAt(P) Select Case vrtJust(P) Case 0 'left AlignStorage = AlignStorage & " " & "/" & VarName & "(Left)" + vbCrLf Case 1 'right AlignStorage = AlignStorage & " " & "/" & VarName & "(Right)" + vbCrLf Case 2 'center AlignStorage = AlignStorage & " " & "/" & VarName & "(Center)" + vbCrLf End Select Next P AlignStorage = AlignStorage & "." & vbCrLf End If ' the WEIGHT command If c7 = 1 And objDataDoc.GetWeightingVariable(False) <> "" Then WeightStorage = WeightStorage & vbCrLf & "WEIGHT BY " & objDataDoc.GetWeightingVariable(False) & "." & vbCrLf ElseIf c7 = 1 And objDataDoc.GetWeightingVariable(False) = "" Then WeightStorage = WeightStorage & vbCrLf & "WEIGHT OFF." & vbCrLf End If LenVarStorage = Len(VarStorage) If LenVarStorage<25 Then VarStorage="* No Variable Labels defined or not asked for." & vbCrLf End If LenValStorage = Len(ValStorage) If LenValStorage<23 Then ValStorage="* No Value Labels defined or not asked for." & vbCrLf End If LenForStorage = Len(FormatStorage) If LenForStorage<23 Then FormatStorage="* Not asked for Formats." & vbCrLf End If LenMissStorage = Len(MissStorage) If LenMissStorage<22 Then MissStorage="* No Missing Values defined or not asked for." & vbCrLf End If LenMLevelStorage = Len(MLevelStorage) If LenMLevelStorage<10 Then MLevelStorage="* Not asked for Measurement Level." & vbCrLf End If LenAlignStorage = Len(AlignStorage) If LenAlignStorage<10 Then AlignStorage="* Not asked for Alignment." & vbCrLf End If LenWeightStorage = Len(WeightStorage) If LenWeightStorage=0 Then WeightStorage="* Not asked for Weight." & vbCrLf End If SyntaxText = Infos & VarStorage & ValStorage & FormatStorage & MissStorage & MLevelStorage & AlignStorage & WeightStorage SyntaxWindow.Text = SyntaxText out: End Sub Private Function dlgFunction(DlgItem$, Action%, SuppValue%) As Boolean Select Case Action% Case 1 ' Dialog box initialization DlgValue "CheckBox1" , 1 DlgValue "CheckBox2" , 1 Case 2 ' Value changing or button pressed Rem dlgFunction = True ' Prevent button press from closing the dialog box Select Case DlgItem$ Case "PushButton1" 'All DlgValue "CheckBox1" , 1 DlgValue "CheckBox2" , 1 DlgValue "CheckBox3" , 1 DlgValue "CheckBox4" , 1 DlgValue "CheckBox5" , 1 DlgValue "CheckBox6" , 1 DlgValue "CheckBox7" , 1 dlgFunction = True Case "PushButton2" 'None DlgValue "CheckBox1" , 0 DlgValue "CheckBox2" , 0 DlgValue "CheckBox3" , 0 DlgValue "CheckBox4" , 0 DlgValue "CheckBox5" , 0 DlgValue "CheckBox6" , 0 DlgValue "CheckBox7" , 0 dlgFunction = True End Select Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem dlgFunction = True ' Continue getting idle actions End Select End Function