'Begin Description ' This Scripts creates a Triple-S v1.2 XML file and related data ' file from the current SPSS data file, prompting the user ' for where they would like the file created ,the default name being ' _SSS.XML ' Data is exported with the same prefix as the XML file with the suffix .DAT ' A data map is also created as .LST which is then written to the current ' SPSS Output window. ' - alternatively the user can pass a parameter for where you want the XML file created ' for example: SCRIPT 'Export2Triple-S.sbs' ("C:\\My Documents\\output.xml"). 'End Description ' DETAILED USER NOTES ' ' No tests are performed to see if the output files already exist - if they do ' this program will overwrite them with no warning. ' ' This program exports all variables of SPSS type Numeric as either Triple-S single ' or quantity type variables. ' All other spss variable types are exported as Triple-S character variables ' - This includes such types as Comma,Dot,N And Scientific Notation formats ' (which may contain valid numeric data) as these are not accepted as valid quantity ' formats by Triple-S. ' It is up to the user to change the print format of these variables to Numeric type ' (F format) if they wish these to be treated as non-character. ' The last column of the data map indicates the original format of non-string variables ' which have been exported as character variables. ' ' Numeric type variables are exported as Singles if ' Rule 1) The Print Format has no decimal places (i.e. is integer) ' Rule 2) And the variable has any value labels associated with it ' Rule 3) And the variable has all positive (or zero) values associated with each value label or ' All other Numeric Type variables are exported As Triple-S Type Quantity ' ' As a Zero value is not allowed in a Triple-S Single variable definition, Single variables ' with zero values are still exported as Singles, but the zero value element is exported ' as a comment - The log file will indicate this has occurred by adding the text "zero-value" ' in the last column of that single variable. If a potential Single variable has only 1 ' value label which is associated with zero it will be exported as a Quantity variable ' ' If there are value labels associated with a numeric variable which has any decimal places ' in its print format it is still exported as a quantity variable but the text 'labelled' is ' added to the last column of the data map. Triple-S allows for quantity variables to be ' exported with labels associated with particular values. ' Thus it up to the user to ensure that all variables they want exported as singles have a ' print Format with no decimal places and that all possible positive values have an associated ' value label ' ' If weighting is applied to the SPSS file then the weight variable is identified in ' the Triple-S export. This is the only Triple-S version 1.2 feature included in this ' export . To turn off this feature and export as version 1.1 change the value of the ' Constant Tripe_SVersion below to 1.1 ' Triple-S requires weight variables to be exported as quantities so a numeric variable ' which is formated for export as a single which is identified as a weight variable ' will be exported as a labelled quantity variable. If a weight is detected the data map ' will indicate this in the last column ' ' As this is an export implementation the reference to the DOCTYPE is output as a comment ' ' For more infomation about the Triple-S Survey Data Interchange Standard and other ' Standards please visit the Triple-S site at www.triple-s.org ' ' Title : Export2Triple-S ' Version : 1.1 ' Author : Chris Johnson ' Company : Merlinco Ltd, London UK ' Website : www.merlinco.co.uk ' Date : 22nd October 2002 ' Tested with : SPSS v11.0 ' Updates since Version 1.0 (3rd October 2002) ' ' Version 1.1 ' ' 1) Code added to handle Negative and Zero values on Value Labels Sub Main() 'On Error GoTo EndOfSub 'Remove the next two lines when copying into an SPSS script.sbs file - Keep them for Visual Studio 'Dim objSpssApp As spsswin.Application 'Set objSpssApp = GetObject(, "SPSS.Application") 'Declare Variables Const Triple_SVersion As Double =1.2 ' Change this from 1.2 to 1.1 to be compatible with Triple-S version 1.1 Dim bSuccess ' Flag set to true if export successful Dim bUserCancelled ' Flag set to true if user hit cancel when prompted for location Dim sExportTo ' Will hold the desired export location Dim objSpssData As ISpssDataDoc ' Will hold the current SPSS data document Dim objSpssOutputDoc As ISpssOutputDoc ' Will hold the current SPSS Output document Dim Index As Long ' Will hold the index of the current variable Dim NumVars As Long ' Will hold the number of variables Dim NumCases As Long ' Will hold the number of cases Dim pNames As Variant ' A variant array to store the variable names Dim pLabels As Variant ' A variant array to store the variable labels Dim pMsmtLevels As Variant ' A variant array to store the variable measurement levels Dim pLabelCounts As Variant ' A variant array to store the number of value labels for the variable Dim pTypes As Variant ' A variant array to store the variable types Dim pFormats As Variant ' A variant array to store the variable formats Dim pWidths As Variant ' A variant array to store the variable widths Dim pFracs As Variant ' A variant array to store the number of decimal places Dim pColumnWidths As Variant ' A variant array to store the column widths Dim pJust As Variant ' A variant array to store the variable alignment justifications Dim pValLabels As Variant ' A variant array to store the value labels Dim pValues As Variant ' A variant array to store the values associated with variable labels Dim startTime As Date ' Will hold the time the procedure begins Dim stopTime As Date ' Will hold the time the procedure ends Dim currIndent As String ' Will hold current indent (TAB) Dim Options As String ' Will hold various XML Options Dim IsSingle As Boolean ' Will hold whether Variable is Single Dim isCharacter As Boolean ' Will hold whether Variable is Character Dim isQuantity As Boolean ' Will hold whether Variable is Quantity Dim currPos As Long ' Will hold current starting data position Dim WtVar As String ' Will hold name of current weighting variable if any Dim Range_Min As String ' Will hold Min Value for quantity variables Dim Range_Max As String ' Will hold Max Value for quantity variables Dim objOutputItems As ISpssItems Dim objOutputItem As ISpssItem Dim sComment As String ' Will hold SPSS format of Character exported variables Dim WeightVar As Boolean ' Will hold whether a particular variable is being used for weighting Dim NumNeg As Long Dim NegativeValues As Boolean 'Grab current SPSS Data document Set objSpssData = objSpssApp.Documents.GetDataDoc(0) 'If user supplied optional parameter for where to output, then use it; otherwise, prompt user. sExportTo = objSpssApp.ScriptParameter (0) If Len(sExportTo) = 0 Then Dim sDefaultPath As String sDefaultPath = Left(objSpssData.GetDocumentPath,Len(objSpssData.GetDocumentPath)-4) & "_SSS.xml" sExportTo = InputBox("Enter path to export to:","SPSS to Triple-S Exporter",sDefaultPath) 'Verify user didn't hit cancel; if they did exit sub gracefully If Len(sExportTo) = 0 Then bUserCancelled = True GoTo EndOfSub End If End If 'Begin process startTime = Now() ' get output document If objSpssApp.Documents.OutputDocCount = 0 Then ' open new output document Set objSpssOutputDoc=objSpssApp.NewOutputDoc Else ' get the current output window Set objSpssOutputDoc=objSpssApp.Documents.GetOutputDoc(0) End If objSpssOutputDoc.Visible=True Set objOutputItems = objSpssOutputDoc.Items If objOutputItems.Count()=0 Then Set objOutputItem = objOutputItems.GetItem(objOutputItems.Count()) Else Set objOutputItem = objOutputItems.GetItem(objOutputItems.Count()-1) End If objOutputItem.Current=True ' Insert Heading & Title objSpssOutputDoc.InsertHeading("Triple-S v" & Format(Triple_SVersion,"0.0") & " Export") Set objOutputItem = objOutputItems.GetItem(objOutputItems.Count()-1) objOutputItem.Current=True objSpssOutputDoc.Promote objSpssOutputDoc.InsertTitle("Title","Triple-S v" & Format(Triple_SVersion,"0.0") & " Export") 'Load SPSS variable definitions Call objSpssData.GetVariableInfo(pNames, pLabels, pTypes, pMsmtLevels, pLabelCounts) Call objSpssData.GetVariableFormats(pFormats, pWidths, pFracs) 'Determine the number of variables NumVars = objSpssData.GetNumberOfVariables ' check for existence of weight variable If Triple_SVersion >= 1.2 Then ' only test for weighting variable if triple_s version 1.2 or greater WtVar=objSpssData.GetWeightingVariable(False) Else WtVar="" End If ' open xml output Open sExportTo For Output As #1 ' open Log file and write headers Open Left(sExportTo,Len(sExportTo)-4) & ".lst" For Output As #2 Print #2,"Triple-S Export Map for " & Left(sExportTo,Len(sExportTo)-4) & ".DAT" Print #2 Print #2,"VARIABLE" & vbTab & "TYPE" & vbTab & "WIDTH" & vbTab & "START " & vbTab & "FINISH " & vbTab & "FORMAT " & vbTab & "COMMENT " Print #2,"--------" & vbTab & "----" & vbTab & "-----" & vbTab & "----- " & vbTab & "------ " & vbTab & "------ " & vbTab & "------- " ' write sss header info Call WriteSSSHeader(1,Triple_SVersion) ' write out a comment to indicate source data Call writeCommentElement(1,"Triple-S v" & Format(Triple_SVersion,"0.0") & " Export of SPSS data file " & objSpssData.GetDocumentPath,currIndent) ' open survey element Call WriteOpenElement(1,"survey","",currIndent) ' open record element Call WriteOpenElement(1,"record"," ident=""A""",currIndent) ' now start processing variables currPos=1 For i=0 To NumVars-1 'initialise variables WeightVar=False Options="" IsSingle = False isCharacter=False isQuantity=False ' first determine variable type Select Case pFormats(i) Case SpssPrintFormatF ' only treat FormatF Numerics - all other types export as string If pLabelCounts(i) = 0 Then ' if no value labels treat as numeric Options=" ident=""" & Format(i+1,"0") & """ type=""quantity""" isQuantity=True Else ' some value labels exist so type is single IsSingle=True Options=" ident=""" & Format(i+1,"0") & """ type=""single""" ' now parse through the value labels and see if any labels are for non-positive integers ' get all the value labels Call objSpssData.GetVariableValueLabels (i, pValues, pValLabels) ' for each label NumNeg=0 NegativeValues=False For K=0 To pLabelCounts(i)-1 If Len(pValLabels(k))=0 Then pValLabels(k)=Str(pValues(k)) End If ' trap negative values If pValues(k) <=0 Then If pValues(k) <> 0 Then NumNeg=NumNeg+1 End If NegativeValues=True End If Next k If pFracs(i) <> 0 Or (NegativeValues And NumNeg >= 1 ) Or (NegativeValues And pLabelCounts(i)=1) Then ' special case - can't export as a single so export as a quantity ' still treat as single but set type to quantity Options=" ident=""" & Format(i+1,"0") & """ type=""quantity""" isQuantity=True End If End If ' now test for weighting If pNames(i)=WtVar Then ' if this variable is the weight variable then add weight to options Options=" ident=""" & Format(i+1,"0") & """ type=""quantity""" Options=Options & " use=""weight""" ' also this must be exported as a quantity even if single isQuantity=True WeightVar=True End If Case Else ' all other variable types exported as character Options=" ident=""" & Format(i+1,"0") & """ type=""character""" isCharacter = True End Select ' start writing variable element Call WriteOpenElement(1,"variable",Options,currIndent) ' write out name element Call WriteFullElement(1,"name",Trim(pNames(i)),"",currIndent) If pLabels(i)="" Then pLabels(i)=pNames(i) End If ' write out label element Call WriteFullElement(1,"label",Trim(pLabels(i)),"",currIndent) ' now calc position Options=" start=""" & Format(currPos,"0") & """" If pWidths(i) <> 1 Then Options=Options & " finish=""" & Format(currPos+pWidths(i)-1,"0") & """" End If ' write out position element Call WriteFullElementShort(1,"position",Options,currIndent) Options="" If isCharacter Then ' write out data map info for character variables Call WriteLog(2,Format(pNames(i)),"C",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"A" & Format(pWidths(i),"0") ,GetFormats(pFormats(i))) ' write out size element Call WriteFullElement(1,"size",Format(pWidths(i),"0"),"",currIndent) End If If Not isCharacter Then ' open values element Call WriteOpenElement(1,"values","",currIndent) If isQuantity Then' quantity so print range element Call getMin_MaxVal(pWidths(i),pFracs(i),Range_Min,Range_Max) Options=" from=""" & Range_Min & """ to=""" & Range_Max & """" ' write out range element Call WriteFullElementShort(1,"range",Options,currIndent) End If If IsSingle Then ' for each label For K=0 To pLabelCounts(i)-1 fmt="0" If pFracs(i) > 0 Then ' set up the output format for the values fmt="0." & String$(pFracs(i),"0") End If ' Write out each value element ' special case where single but not quantity and only 1 zero label code If pValues(k)=0 And Not isQuantity And NegativeValues Then ' write out comment Call writeCommentElement(1,"value code=""" & Format(pValues(k),fmt) & """ " & pValLabels(k) & " /value",currIndent) Else Call WriteFullElement(1,"value",pValLabels(k)," code=""" & Format(pValues(k),fmt) & """",currIndent) End If Next k End If ' close the values element Call WriteCloseElement(1,"values",currIndent) ' write out data map info for numeric variables If IsSingle And Not isQuantity Then If Not NegativeValues Then Call WriteLog(2,Format(pNames(i)),"S",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") & "." & Format(pFracs(i),"0"),"") Else ' Special case of one zero value Call WriteLog(2,Format(pNames(i)),"S",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") & "." & Format(pFracs(i),"0"),"zero-value") End If End If If IsSingle And isQuantity Then If WeightVar Then Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") & "." & Format(pFracs(i),"0"),"weight-labelled") Else Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") & "." & Format(pFracs(i),"0"),"labelled") End If End If If isQuantity And Not IsSingle Then If WeightVar Then Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") & "." & Format(pFracs(i),"0"),"weight") Else Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") & "." & Format(pFracs(i),"0"),"") End If End If End If ' close the variable element Call WriteCloseElement(1,"variable",currIndent) ' increment the current data column currPos=currPos+pWidths(i) Next i ' close the record element Call WriteCloseElement(1,"record",currIndent) ' close the survey element Call WriteCloseElement(1,"survey",currIndent) ' close the sss element Call WriteCloseElement(1,"sss","") ' finished writing SSS xml ' so now export data using SPSS syntax - Data file is same prefix as XML file with .DAT suffix strCommand="WRITE OUTFILE='" & Left(sExportTo,Len(sExportTo)-4) & ".DAT' NoTable/ all." strcommand=strcommand & vbCrLf & "Execute." ' execute the export command objSpssApp.ExecuteCommands strCommand, False ' uses async processing Do DoEvents Loop Until Not objSpssApp.IsBusy ' handles the async processing (effectively becomes synch) ' End of Process so flag as successful bSuccess = True EndOfSub: 'Release objects from memory and close open files On Error Resume Next Set objSpssApp = Nothing Close #1 Close #2 On Error GoTo 0 If bSuccess = True Then objSpssOutputDoc.Visible=True ' insert data map file into Output Document SendKeys "%IF~" & Left(sExportTo,Len(sExportTo)-4) & ".lst" & "~" ,True ' insert text file stopTime = Now() sMsg = "File successfully exported to " & sExportTo & vbCrLf & "(It took " & Format((stopTime - startTime), "nn:ss") & " to complete)" & vbCrLf & " Data saved to " & Left(sExportTo,Len(sExportTo)-4) & ".DAT" MsgBox sMsg,,"SPSS to Triple-S Exporter" Else If bUserCancelled = False Then MsgBox "There was a problem! Export unsuccessful.",,"SPSS to Triple-S Exporter" End If End Sub Sub WriteSSSHeader(Fn As Integer,Triple_SVersion As Double) ' writes triple-s header information Dim tempIndent As String Print #Fn , "" Print #Fn ' write out doctype element as a comment for this export implementation Call writeCommentElement(Fn,"DOCTYPE sss PUBLIC ""-//triple-s//DTD Survey Interchange v" & Format(Triple_SVersion,"0.0") &"//EN"" ""http://www.triple-s.org/dtd/sss_v" & Format(Triple_SVersion*10,"0") & ".dtd""",tempIndent) ' if you want to perform a valid test then use next line instead of previous - this requires access to the internet ' Call WriteOpenElement(Fn,"!DOCTYPE", "sss PUBLIC ""-//triple-s//DTD Survey Interchange v" & Format(Triple_SVersion,"0.0") &"//EN"" ""http://www.triple-s.org/dtd/sss_v" & Format(Triple_SVersion*10,"0") & ".dtd""",tempIndent) Print #Fn ' SPSS standard naming not same as SSS standard names - almost but SPSS also allows '_.&$#' in variable names ' Call WriteOpenElement(Fn,"sss"," version=""" & format(Triple_SVersion,"0.0") & """ options=""standardnames""",tempIndent) Call WriteOpenElement(Fn,"sss"," version=""" & Format(Triple_SVersion,"0.0")& """",tempIndent) Print #Fn Call WriteFullElement(Fn,"date",Format(Date,"dd-mmmm-yyyy"),"","") Call WriteFullElement(Fn,"time",Format(Time,"hh:nn:ss"),"","") Call WriteFullElement(Fn,"origin","SPSS Script Export2Triple-S v1.1 - SPSS for Windows","","") End Sub Sub WriteFullElement(Fn As Integer,tag As String,contents As String,Options As String,currIndent As String) ' prints a full element on 1 line - Contents are Cleaned using TextClean Function Print #Fn,currIndent & "<" & tag & Options & ">" & TextClean(contents) & "" End Sub Sub WriteFullElementShort(Fn As Integer,tag As String,Options As String,currIndent As String) ' prints a full element with no contents on 1 line Print #Fn,currIndent & "<" & tag & Options & "/>" End Sub Sub WriteOpenElement(Fn As Integer,tag As String,Options As String,currIndent As String) ' prints an open element with options Print #Fn,currIndent & "<" & tag & Options & ">" ' increment the current indent currIndent=currIndent & vbTab End Sub Sub WriteCloseElement(Fn As Integer,tag As String,currIndent As String) ' deincrement by 1 level If Len(currIndent)>0 Then currIndent=Left(currIndent,Len(currIndent)-1) End If ' print a closed element Print #Fn,currIndent & "" End Sub Sub writeCommentElement(Fn As Integer,contents As String,currIndent As String) ' writes a comment element - also removes any occurances of -- in contents (replaces with " ") ' first add white space to comments ending in - If Mid(contents,Len(contents),1)="-" Then contents=contents & " " End If Print #Fn,currIndent & "" ' n.b. contents does not need to go through TextCleaning - xml comments can include any characters except -- End Sub Sub getMin_MaxVal(width As Variant,dp As Variant,Range_Min As String,Range_Max As String) Dim work As String ' finds the maximum and minimum value for a given variable based on the width of ' its output format and the number of decimal places work=String$(width,"9") Range_Max=work If width = 1 Then Range_Min="0" Else Range_Min="-" & Left(work,Len(work)-1) End If If dp > 0 Then Range_Min=Left(Range_Min,width-dp-1) & "." & String$(dp,"9") Range_Max=Left(Range_Max,width-dp-1) & "." & String$(dp,"9") End If End Sub Sub WriteLog(Fn As Integer,string1 As String,string2 As String,string3 As String,string4 As String,string5 As String,string6 As String,string7 As String) ' writes a formatted line to the data map string1= PadtoLen(string1,8) string2= PadtoLen(string2,4) string3= PadtoLen(string3,5) string4= PadtoLen(string4,8) string5= PadtoLen(string5,8) string6= PadtoLen(string6,8) Print #Fn,string1 & vbTab & string2 & vbTab & string3 & vbTab & string4 & vbTab & string5 & vbTab & string6 & vbTab & string7 End Sub Function PadtoLen(InString As String,maxlen As Integer) As String ' turns a variable length string into fixed length Dim i i=Len(InString) If i < maxlen Then PadtoLen=InString & String(maxlen-i," ") Else PadtoLen=Left(InString,maxlen) End If End Function Function GetFormats(FormatCode As Variant) As String ' sets a string to hold the current variable print format for non-string or numeric variable types Select Case FormatCode Case SpssPrintFormatA GetFormats="" ' string format is ok Case SpssPrintFormatAhex GetFormats="hex" Case SpssPrintFormatComma GetFormats="comma" Case SpssPrintFormatDollar GetFormats="dollar" Case SpssPrintFormatF GetFormats="" ' numeric format is ok Case SpssPrintFormatIb GetFormats="binary" Case SpssPrintFormatPibhex GetFormats="binary" Case SpssPrintFormatP GetFormats="binary" Case SpssPrintFormatPib GetFormats="binary" Case SpssPrintFormatPk GetFormats="binary" Case SpssPrintFormatRb GetFormats="binary" Case SpssPrintFormatRbhex GetFormats="binary" Case SpssPrintFormatZ GetFormats="zoned" Case SpssPrintFormatN GetFormats="integer" Case SpssPrintFormatE GetFormats="sci not" Case SpssPrintFormatDate GetFormats="date" Case SpssPrintFormatTime GetFormats="time" Case SpssPrintFormatDatetime GetFormats="datetime" Case SpssPrintFormatAdate GetFormats="date" Case SpssPrintFormatJdate GetFormats="date" Case SpssPrintFormatDtime GetFormats="time" Case SpssPrintFormatWkday GetFormats="date" Case SpssPrintFormatMonth GetFormats="date" Case SpssPrintFormatMoyr GetFormats="date" Case SpssPrintFormatQyr GetFormats="date" Case SpssPrintFormatWkyr GetFormats="date" Case SpssPrintFormatPct GetFormats="percent" Case SpssPrintFormatDot GetFormats="dot" Case SpssPrintFormatCca GetFormats="currency" Case SpssPrintFormatCcb GetFormats="currency" Case SpssPrintFormatCcc GetFormats="currency" Case SpssPrintFormatCcd GetFormats="currency" Case SpssPrintFormatCce GetFormats="currency" Case SpssPrintFormatEdate GetFormats="date" Case SpssPrintFormatSdate GetFormats="date" Case Else ' an unknown format type so just mark as unknown GetFormats="unknown" End Select End Function Function TextClean(InString As String) As String ' cleans up all non 32-127 characters and other special characters Dim i As Long Dim iLen As Long Dim TextVal As Integer TextClean="" iLen=Len(InString) For i=1 To iLen TextVal=Asc(Mid(InString,i,1)) Select Case TextVal Case 0 To 31 TextClean=TextClean & "&#" & Format(TextVal,"0") & ";" Case 34 TextClean=TextClean & """ Case 38 TextClean=TextClean & "&" Case 39 TextClean=TextClean & "'" Case 60 TextClean=TextClean & "<" Case 62 TextClean=TextClean & ">" Case 127 TextClean=TextClean & "
" Case 128 To 255 TextClean=TextClean & "&#" & Format(TextVal,"0") & ";" Case Else ' ok in range 32 to 126 and not any other special character so just append the character TextClean=TextClean & Chr(TextVal) End Select Next i End Function