' SPSS-SCRIPT TO CONVERT AN SPSS DATA FILE INTO A STATA/SE FILE ' Version 2.1 (Enzmann, July 2009) ' 1. Start SPSS and run script ' 2. Save SPSS syntax (for your documentation) ' 3. Save DO-file ' 4. Run DO-file with Stata ' Utility functions: Function memsize (x) As Variant Dim fsize As Long x = Left(x,Len(x)-3) & "dt8" fsize = FileLen(x) memsize = Round(fsize/1000000)+10 End Function Function Umlaute(x) As String x = Replace(x,"ä","ae") x = Replace(x,"Ä","Ae") x = Replace(x,"ö","oe") x = Replace(x,"Ö","Oe") x = Replace(x,"ü","ue") x = Replace(x,"Ü","Ue") x = Replace(x,"ß","ss") x = Replace(x,Chr(34),"'") Umlaute = x End Function Function ReVarNam(x) As String x = Replace(x,"ä","ae") x = Replace(x,"Ä","Ae") x = Replace(x,"ö","oe") x = Replace(x,"Ö","Oe") x = Replace(x,"ü","ue") x = Replace(x,"Ü","Ue") x = Replace(x,"ß","ss") x = Replace(x," ","_") x = Replace(x,"$","d") ReVarNam = x End Function Function CodeMV (x) As Variant Dim outstr As String outstr = x If Len(outstr) = 12 Then x = x-21916 outstr = x If Mid(outstr,1,6)="230530" Then outstr = outstr & "=.b" ElseIf Mid(outstr,1,6)="230549" Then outstr = outstr & "=.b" ElseIf Mid(outstr,1,6)="265580" Then outstr = outstr & "=.b" Else outstr = outstr & "=.a" End If Else If Mid(outstr,Len(outstr),1) = "9" Then outstr = outstr & "=.a" ElseIf Mid(outstr,Len(outstr),1) = "8" Then outstr = outstr & "=.b" ElseIf Mid(outstr,Len(outstr),1) = "7" Then outstr = outstr & "=.c" Else outstr = outstr & "=.d" End If End If CodeMV = outstr End Function ' Start window: Sub start Dim text1 As String text1 = "spss2stata creates Stata syntax to convert an SPSS data file" & vbCrLf text1 = text1 & "(.sav) into a Stata/SE data file (.dta). The script" & vbCrLf & vbCrLf text1 = text1 & "- will ask for an SPSS data file to be converted," & vbCrLf text1 = text1 & "- will convert the SPSS file into a Version 8 Stata file (.dt8)" & vbCrLf text1 = text1 & " (saved into the same directory as the SPSS file)" & vbCrLf text1 = text1 & "- will write into a new syntax window the SPSS-syntax used to" & vbCrLf text1 = text1 & " convert the SPSS-file," & vbCrLf text1 = text1 & "- will write into a new syntax window the Stata syntax needed" & vbCrLf text1 = text1 & " to read the Stata-file and to define the value labels and" & vbCrLf text1 = text1 & " missing values according to the variable definitions of the" & vbCrLf text1 = text1 & " SPSS-file." & vbCrLf & vbCrLf text1 = text1 & "The script now supports variable names longer than 8 characters." & vbCrLf text1 = text1 & "Nevertheless, you may find the Stata ado -usespss- useful, too." & vbCrLf text1 = text1 & "It can be installed from within Stata by -ssc install usespss-." & vbCrLf text1 = text1 & "However, in contrast to this script and similar to StatTransfer" & vbCrLf text1 = text1 & "-usespss- does not convert labels of missing values." & vbCrLf & vbCrLf text1 = text1 & "If the script has finished the user has to save the SPSS syntax" & vbCrLf text1 = text1 & "(as a .sps-file) and the Stata syntax (as a .do-file) by himself." & vbCrLf & vbCrLf text1 = text1 & "Do not save the SPSS data file if asked by SPSS because some" & vbCrLf text1 = text1 & "variable names might have been changed by the script (as" & vbCrLf text1 = text1 & "indicated in the SPSS-syntax created)!" & vbCrLf & vbCrLf text1 = text1 & "WARNING: Close or save your SPSS data file before running the" & vbCrLf text1 = text1 & "script because it will not save a current data file and will" & vbCrLf text1 = text1 & "close it without a warning!" & vbCrLf Begin Dialog UserDialog 500,448,"spss2stata" ' %GRID:10,7,1,1 Text 40,21,410,14,"SPSS-Script to Convert an SPSS-File into a Stata/SE-File",.text0,2 OKButton 150,413,90,21 CancelButton 260,413,90,21 Text 40,42,420,357,text1,.Text1 End Dialog Dim dlg As UserDialog Dialog dlg End Sub ' Dialog to open SPSS file: Sub BuildDialog Begin Dialog UserDialog 580,70,"spss2stata",.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 ' Dialogue function to open files with file name specified: Function DialogFunc(strDlgItem As String, intAction As Integer, intSuppValue As Integer) As Boolean Dim FileDate As Date Select Case intAction Case 1 ' Signal when initializing dialogue field: Beep Case 2 ' Change of value or click on button: Select Case strDlgItem Case "cmdOK" ' Open file specified if click on OK 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 click on CANCEL: Err = 1 DialogFunc = False End Select End Select GoTo Ende Problem: MsgBox("File '" & strFilename & "' not found") Ende: End Function ' Open data file with file name specified: Sub OpenDataFile(strFilename As Variant) Set DataDoc = objSpssApp.OpenDataDoc(strFilename) End Sub ' Main program "spss2stata": 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 Integer Dim NSpace As Integer Dim RightFill As String Dim i,j,k As Integer, Delimiter As String Call start ' ---------------------------------------------- ' Open file using 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) ' ---------------------------------------------- ' Check of variable names and rename if necessary: Dim renvars As String Dim notes As String Dim varneu As String renvars = "" notes = vbCrLf For i = 0 To numVars-1 varneu = VarNames(i) varneu = ReVarNam(varneu) If varneu <> VarNames(i) Then renvars = renvars & "rename variables (" & VarNames(i) & " = " & varneu & ")." & vbCrLf notes = notes & "notes " & varneu & ": Variable '" & VarNames(i) & "' was renamed to '" & varneu & "'" & vbCrLf End If Next ' ========================================================= ' Export SPSS data file into Version 8 Stata/SE file (.dt8) ' plus documentation of job in SPSS command file (commands ' should be saved as .sps file): Dim spss2dt8 As String spss2dt8 = "" If renvars <> "" Then spss2dt8 = spss2dt8 & renvars & vbCrLf End If spss2dt8 = spss2dt8 & "SAVE TRANSLATE OUTFILE='" & Left(Document,Len(Document)-3) & "dt8" & "'" & vbCrLf spss2dt8 = spss2dt8 & " /Type=STATA" & vbCrLf spss2dt8 = spss2dt8 & " /VERSION=8" & vbCrLf spss2dt8 = spss2dt8 & " /EDITION=SE" & vbCrLf spss2dt8 = spss2dt8 & " /MAP" & vbCrLf spss2dt8 = spss2dt8 & " /Replace ." & vbCrLf objSpssApp.ExecuteCommands spss2dt8, True spss2dt8 = "Get FILE='" & Document & "'." & vbCrLf & vbCrLf & spss2dt8 spss2dt8 = "set message on." & vbCrLf & spss2dt8 spss2dt8 = spss2dt8 & "set message off." & vbCrLf & vbCrLf spss2dt8 = spss2dt8 & "/* Script: Wait until Stata syntax appears in a new window! */" & vbCrLf Set spssjob = objSpssApp.NewSyntaxDoc spssjob.Visible = True spssjob.Text = spss2dt8 If renvars <> "" Then numVars = DataDoc.GetVariableInfo(VarNames, VarLabels, VarTypes, VarLevels, LabelCounts) numMiss = DataDoc.GetVariableMissingValues(MissingCounts, MissingValues) End If ' ======================================================= ' Create Stata DO file: ' ---------------------------------------------- ' 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 Dim LabelData As String FileDate = FileDateTime(Document) NCases = DataDoc.GetNumberOfCases FileInfo1 = "/* File: " & Document FileInfo2 = "/* Created: " & FileDate FileInfo3 = "/* Variables: " & numVars FileInfo4 = "/* Cases: " & NCases fname = Split(Document,"\")(UBound(Split(Document,"\"))) LabelData = "label data " & Chr(34) & "Created from '" & fname & "' (" & FileDate & ")" & Chr(34) If Len(FileInfo1) > Len(FileInfo2) Then NSpace = Len(FileInfo1) Else NSpace = Len(FileInfo2) End If 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 = FileInfo1 & FileInfo2 & FileInfo3 & FileInfo4 & vbCrLf ' ---------------------------------------------- ' Prefix of DO file: Dim preface As String fname = Split(Document,"\")(UBound(Split(Document,"\"))) fname = Left(fname,Len(fname)-4) preface = "" preface = "set more off" & vbCrLf & "capture log close" & vbCrLf preface = preface & "log using " & fname & ".log, replace text" & vbCrLf & vbCrLf preface = preface & "set mem " & memsize(Document) & "m" & vbCrLf preface = preface & "clear" & vbCrLf & vbCrLf ' ---------------------------------------------- ' Read data (*.dt8 file): Dim do1 As String do1 = "use " & Chr(34) & Left(Document,Len(Document)-3) & "dt8" & Chr(34) & vbCrLf do1 = do1 & "compress" & vbCrLf do1 = do1 & LabelData & vbCrLf do1 = do1 & "save " & fname & ", replace" & vbCrLf do1 = do1 & "use " & fname & ", clear" & vbCrLf do1 = do1 & vbCrLf & "* -----------------------------------------------" & vbCrLf ' ---------------------------------------------- ' Define variable labels: Dim LabVar As String Delimiter = vbCrLf & "label variable " LabVar = "" For i = 0 To numVars-1 If VarLabels(i) <> "" Then RightFill = " " NSpace = Len(VarNames(i)) For k = NSpace To 7 RightFill = RightFill + " " Next LabVar = LabVar & Delimiter & VarNames(i) & RightFill & Chr(34) & Umlaute(VarLabels(i)) & Chr(34) End If Next LabVar = LabVar & vbCrLf ' ---------------------------------------------- ' Define value labels: Dim NumValueLabels As Long Dim ValueLabelCounts As Variant Dim ValueLabels As Variant Dim delimit2 As String Dim LabDef As String Dim LabVal As String Dim LabDefTmp As String Dim LabValTmp As String Dim ValueOK As Boolean Dim IntVarOK As Boolean Dim NIntVars As Integer Dim MV As Variant delimit2 = vbCrLf & "label define " Delimiter = vbCrLf & "label values " LabDef = "" LabVal = "" For i = 0 To numVars-1 NumValueLabels = DataDoc.GetVariableValueLabels (i, ValueLabelCounts, ValueLabels) If NumValueLabels > -1 Then If VarTypes(i) = 0 Then ValueOK = True NIntVars = NumValueLabels LabDefTmp = "" LabValTmp = "" RightFill = " " NSpace = Len(VarNames(i)) For k = NSpace To 7 RightFill = RightFill + " " Next LabDefTmp = delimit2 & VarNames(i) & RightFill LabValTmp = Delimiter & VarNames(i) & RightFill & VarNames(i) For j = 0 To NumValueLabels-1 IntVarOK = True value = ValueLabelCounts(j) If Abs(value - Round(value)) > 0 Then notes = notes & "notes " & VarNames(i) & ": Value label '" & value & " = " & ValueLabels(j) & "' could not be assigned." & vbCrLf IntVarOK = False NIntVars = NIntVars - 1 End If If value > 1e+10 Then ValueOK = False End If NMissV = MissingCounts(i) If NMissV > 0 Then For k = 0 To NMissV-1 MV = MissingValues(i,k) If value = MV Then value = Right(CodeMV(MV),2) Exit For End If Next ElseIf NMissV < 0 Then NMissV = Abs(NMissV) For k = 0 To NMissV-1 MV = MissingValues(i,k) If (value = MV) Or (value > MissingValues(i,0) And value < MissingValues(i,1)) Then value = Right(CodeMV(value),2) Exit For End If Next End If If IntVarOK Then If j > 0 Then LabDefTmp = LabDefTmp & " " End If If ValueLabels(j) = "" Then LabDefTmp = LabDefTmp & value & " " & Chr(34) & "(no label)" & Chr(34) Else LabDefTmp = LabDefTmp & value & " " & Chr(34) & Umlaute(ValueLabels(j)) & Chr(34) End If End If Next If ValueOK And NIntVars > 0 Then LabDef = LabDef & LabDefTmp LabVal = LabVal & LabValTmp End If ElseIf VarTypes(i) = 1 Then For j = 0 To NumValueLabels-1 value = ValueLabelCounts(j) notes = notes & "notes " & VarNames(i) & ": is a string variable, value label '" & value & "' = '" & ValueLabels(j) & "' could not be assigned." & vbCrLf Next Else For j = 0 To NumValueLabels-1 value = ValueLabelCounts(j) notes = notes & "notes " & VarNames(i) & ": Value label '" & value & "' = '" & ValueLabels(j) & "' could not be assigned." & vbCrLf Next End If End If Next LabDef = vbCrLf & "label drop _all" & vbCrLf & LabDef & vbCrLf LabVal = LabVal & vbCrLf ' ---------------------------------------------- ' Define (recode to) missing values: Dim MissVal As String Dim MissLo As Boolean Dim MissHi As Boolean Dim Extreme As Double Delimiter = vbCrLf & "recode " MissVal = "" Extreme = 1.79E308 For i = 0 To numVars-1 If VarTypes(i) = 0 Then NMissV = MissingCounts(i) If NMissV <> 0 Then RightFill = " " NSpace = Len(VarNames(i)) For k = NSpace To 7 RightFill = RightFill + " " Next MissVal = MissVal & Delimiter & VarNames(i) & RightFill End If If NMissV > 0 Then For j = 0 To NMissV-1 value = CodeMV(MissingValues(i,j)) If j < NMissV-1 Then value = value & " " End If MissVal = MissVal & value Next ElseIf NMissV < 0 Then MissLo = ((-1)*Extreme > MissingValues(i,0)) MissHi = (Extreme < MissingValues(i,1)) If Not(MissLo) And Not(MissHi) Then value = MissingValues(i,0) & "/" & MissingValues(i,1) & "=." ' if value label: CodeMV(MissingValues(i,1)) notes = notes & "notes " & VarNames(i) & ": Missing values defined as a range of values could not be labeled, compare label " & VarNames(i) & "." & vbCrLf ElseIf MissHi Then value = MissingValues(i,0) & "/max" & "=." ' if value label: Right(CodeMV(MissingValues(i,1)),3) notes = notes & "notes " & VarNames(i) & ": Missing values defined as a range of values could not be labeled, compare label " & VarNames(i) & "." & vbCrLf Else value = "min/" & MissingValues(i,1) & "=." ' if value label: CodeMV(MissingValues(i,0)) notes = notes & "notes " & VarNames(i) & ": Missing values defined as a range of values could not be labeled, compare label " & VarNames(i) & "." & vbCrLf End If If NMissV = -3 Then MissVal = MissVal & value & " " value = CodeMV(MissingValues(i,2)) End If MissVal = MissVal & value End If End If Next MissVal = MissVal & vbCrLf & vbCrLf ' ---------------------------------------------- ' Trailer of DO file: Dim do2 As String do2 = "* -----------------------------------------------" & vbCrLf & vbCrLf do2 = do2 & "compress" & vbCrLf do2 = do2 & "save " & fname & ", replace" & vbCrLf do2 = do2 & "use " & fname & ", clear" & vbCrLf do2 = do2 & "notes" & vbCrLf do2 = do2 & "describe, short" & vbCrLf do2 = do2 & "* summarize" & vbCrLf do2 = do2 & "log close" & vbCrLf do2 = do2 & "exit, clear" & vbCrLf ' ---------------------------------------------- ' Write DO file into SPSS syntax window (has to ' be saved as *.do file): Set dofile = objSpssApp.NewSyntaxDoc dofile.Visible = True dofile.Text = "/* DO-file created by spss2stata (" & Now & ") */" & vbCrLf & vbCrLf dofile.Text = dofile.Text & preface & FileInfo & do1 & notes & LabVar & LabDef & LabVal & MissVal & do2 GoTo Finito ProbMsg: If Err = 1 Then MsgBox("Script cancelled by user.") End If Exit Sub Finito: MsgBox("Sript run seems to be OK. Save DO-syntax as DO-file and SPSS-syntax as SPS-file.") End Sub