' ===================================
' VDef2SPS Version 1.1 (Oct 19, 2005)
' ===================================

' Prologue:
Sub start
Dim text1 As String

text1 =         "VDef2SPS creates SPSS syntax to define the variables" & vbCrLf
text1 = text1 & "according to definitions of a specific SPSS data file (*.sav)." & vbCrLf & vbCrLf
text1 = text1 & "The script will write into a new syntax window the SPSS" & vbCrLf
text1 = text1 & "syntax needed to define the" & vbCrLf & vbCrLf
text1 = text1 & "- variable labels" & vbCrLf
text1 = text1 & "- value labels" & vbCrLf
text1 = text1 & "- missing values" & vbCrLf & vbCrLf
text1 = text1 & "as they are already defined in the specified SPSS data file." & vbCrLf &vbCrLf
text1 = text1 & "However, the missing value definitions of short string" & vbCrLf
text1 = text1 & "variables and missing value definitions including lowest or " & vbCrLf
text1 = text1 & "highest (like: MISSING VALUES V1 (LO THRU ..) or MISSING VALUES (.. THRU HI)) will not be included!" & vbCrLf & vbCrLf
text1 = text1 & "If the script has finished the user has to save the SPSS" & vbCrLf
text1 = text1 & "syntax (as a .sps-file) by himself." & vbCrLf & vbCrLf
text1 = text1 & "WARNING: Close or save your SPSS data file before running" & vbCrLf
text1 = text1 & "the script because it will not save a current data file" & vbCrLf
text1 = text1 & "and will close it without a warning!" & vbCrLf

Begin Dialog UserDialog 500,378,"VDef2SPS" ' %GRID:10,7,1,1
  Text 40,21,410,14,"SPSS-Script to create syntax of variable definitions",.text0,2
  OKButton 150,336,90,21
  CancelButton 260,336,90,21
  Text 40,42,420,280,text1,.Text1
End Dialog
Dim dlg As UserDialog
Dialog dlg

End Sub
' ----------------------------------------------

' Dialogue to open SPSS file:
Sub BuildDialog

Begin Dialog UserDialog 580,70,"VDev2SPS",.DialogFunc
  Text 40,7,280,21,"SPSS data file to open:",.txtDialogTitle
  TextBox 40,28,340,21,.txtFilename
  OKButton 470,7,100,21,.cmdOK
  CancelButton 470,35,100,21,.cmdCancel
End Dialog
Dim dlg As UserDialog
Dialog dlg

End Sub
' ----------------------------------------------

' Function to open file with filename specified:
Function DialogFunc(strDlgItem As String, intAction As Integer, intSuppValue As Integer) As Boolean
Dim FileDate As Date
Select Case intAction
  Case 1               ' Signal at initialization of dialogue field
    Beep
  Case 2               ' Change of value or click on button
    Select Case strDlgItem
      Case "cmdOK"     ' If click "OK" open file with filename specified:
        strFilename = DlgText("txtFilename")
        Call OpenDataFile(strFilename)
        On Error GoTo Problem
        FileDate = FileDateTime(strFilename)
        If Err > 0 Then
          GoTo Problem
        End If
        DialogFunc = False
      Case "cmdCancel"  ' Close dialogue if user clicks "CANCEL":
        Err = 1
        DialogFunc = False
    End Select
End Select
GoTo Ende
Problem:
  MsgBox("File '" & strFilename & "' not found")
Ende:
End Function
' ----------------------------------------------

' Open data file with filename specified
Sub OpenDataFile(strFilename As Variant)
  Set DataDoc = objSpssApp.OpenDataDoc(strFilename)
End Sub
' ----------------------------------------------

' Convert single quotes to double quotes:
Sub DoubleQuote(S As Variant)
  Dim SDum As Variant
  Dim SArray As Variant
  If InStr(S,"'") > 0 Then
    SArray = Split(S,"'")
    SDum = ""
    For i = 0 To UBound(SArray)
      SDum = SDum + SArray(i)
      If i < UBound(SArray) Then
        SDum = SDum + "''"
      End If
    Next
    S = SDum
  End If
End Sub
' ==============================================

' Main program "VDef2SPS.sbs":

Sub Main

Dim DataDoc As ISpssDataDoc
Dim Document As Variant
Dim fname As String
Dim numVars As Long
Dim numMiss As Long
Dim VarNames As Variant
Dim VarLabels As Variant
Dim VarTypes As Variant
Dim VarLevels As Variant
Dim LabelCounts As Variant
Dim value As Variant
Dim MissingValues As Variant
Dim MissingCounts As Variant
Dim NMissV As Variant
Dim NSpace As Integer
Dim RightFill As String

Dim i,j,k As Integer, Delimiter As String

Call start

' ----------------------------------------------
' Open file via dialogue

Call BuildDialog
If Err > 0 Then
  GoTo ProbMsg
End If

Set DataDoc = objSpssApp.Documents.GetDataDoc(0)
Document = DataDoc.GetDocumentPath

numVars = DataDoc.GetVariableInfo(VarNames, VarLabels, VarTypes, VarLevels, LabelCounts)
numMiss = DataDoc.GetVariableMissingValues(MissingCounts, MissingValues)

' ----------------------------------------------
' Documentation of data file:

Delimiter = "*/" & vbCrLf
Dim FileDate As Date
Dim NCases As Long
Dim FileInfo1 As String, FileInfo2 As String, FileInfo3 As String, FileInfo4 As String
Dim FileInfo As String

FileDate = FileDateTime(Document)
NCases = DataDoc.GetNumberOfCases

FileInfo0a = "/* The variable definitions are based on"
FileInfo0b = "/* "
FileInfo1 = "/* File:      " & Document
FileInfo2 = "/* Created:   " & FileDate
FileInfo3 = "/* Variables: " & numVars
FileInfo4 = "/* Cases:     " & NCases

If Len(FileInfo0a) > Len(FileInfo1) Then
  NSpace = Len(FileInfo0a)
Else
  NSpace = Len(FileInfo1)
End If
For i=Len(FileInfo0a) To NSpace
  FileInfo0a = FileInfo0a & " "
Next
FileInfo0a = FileInfo0a & Delimiter
For i=Len(FileInfo0b) To NSpace
  FileInfo0b = FileInfo0b & " "
Next
FileInfo0b = FileInfo0b & Delimiter
For i=Len(FileInfo1) To NSpace
  FileInfo1 = FileInfo1 & " "
Next
FileInfo1 = FileInfo1 & Delimiter
For i=Len(FileInfo2) To NSpace
  FileInfo2 = FileInfo2 & " "
Next
FileInfo2 = FileInfo2 & Delimiter
For i=Len(FileInfo3) To NSpace
  FileInfo3 = FileInfo3 & " "
Next
FileInfo3 = FileInfo3 & Delimiter
For i=Len(FileInfo4) To NSpace
  FileInfo4 = FileInfo4 & " "
Next
FileInfo4 = FileInfo4 & Delimiter
FileInfo = FileInfo0a & FileInfo0b & FileInfo1 & FileInfo2 & FileInfo3 & FileInfo4 & vbCrLf

' ----------------------------------------------
' Extraction of variable definitions:

Set SyntaxDoc = objSpssApp.NewSyntaxDoc
SyntaxDoc.Visible = True

Delimiter = ""
VarLab = "VARIABLE LABEL "
For i = 0 To numVars-1
  RightFill = ""
  NSpace = Len(VarNames(i))
  For k = NSpace To 7
    RightFill = RightFill + " "
  Next
  DoubleQuote(VarLabels(i))
  VarLab = VarLab & Delimiter & VarNames(i) & RightFill & " '" & VarLabels(i) & "'"
  Delimiter =  vbCrLf & "              /"
Next

Dim NumValueLabels As Long
Dim ValueLabelCounts As Variant
Dim ValueLabels As Variant
Dim STest As String

Delimiter = ""
ValLab = "VALUE LABELS "
For i = 0 To numVars-1
  NumValueLabels = DataDoc.GetVariableValueLabels (i, ValueLabelCounts, ValueLabels)
  RightFill = ""
  NSpace = Len(VarNames(i))
  For k = NSpace To 7
    RightFill = RightFill + " "
  Next
  If NumValueLabels = 0 Then
     ValLab = ValLab & Delimiter & "/* " & VarNames(i) & RightFill & " (no labels defined) */"
  Else
  ValLab = ValLab & Delimiter & VarNames(i) & RightFill
  End If
  Delimiter =  vbCrLf & "            /"
  If NumValueLabels > 0 Then
    For j = 0 To NumValueLabels-1
      value = ValueLabelCounts(j)
      If VarTypes(i) > 0 Then
        value = "'" & value & "'"
      End If
      DoubleQuote(ValueLabels(j))
      ValLab = ValLab & " " & "(" & value & ")" & " '" & ValueLabels(j) & "'"
    Next
  End If
Next

Delimiter = ""
MissVal = "MISSING VALUES "
For i = 0 To numVars-1
'  If VarTypes(i) = 0 Then
'    If MissingCounts(i)-1 > -1 Then
      NMissV = MissingCounts(i)-1
      RightFill = ""
      NSpace = Len(VarNames(i))
      For k = NSpace To 8
        RightFill = RightFill + " "
      Next
      MissVal = MissVal & Delimiter & VarNames(i) & RightFill & "("
      Delimiter = vbCrLf & "              /"
      value = ""
      For j = 0 To MissingCounts(i)-1
         value = value & MissingValues(i,j)
         If j < MissingCounts(i)-1 Then
            value = value & ","
         End If
      Next
      MissVal = MissVal & value & ")"
'    End If
'  End If
Next

' ---------------------------------------------------
' Write syntax:

If VarLab = "VARIABLE LABEL " Then
  VarLab = "/* No variable labels defined */"
End If
If ValLab = "VALUE LABELS " Then
  ValLab = "/* No value labels defined */"
End If
If MissVal = "MISSING VALUES " Then
  MissVal = "/* No missing values defined */"
End If

SyntaxDoc.Text = FileInfo & vbCrLf & VarLab & "." & vbCrLf & ValLab & "." & vbCrLf & MissVal & "." & vbCrLf

' ---------------------------------------------------
' Epilogue:

GoTo Finito
ProbMsg:
  If Err = 1 Then
    MsgBox("Script cancelled by user.",0,"VDef2SPS")
  End If
  Exit Sub
Finito:
  MsgBox("Sript run seems to be OK. Save the SPSS-syntax created!",0,"VDef2SPS")
End Sub