'Begin Description
' There are syncronization problems when scripts are called from syntax: they don't execute
' where they are supposed to do. Scripts are executed after SPSS has finished running all
' the syntax, and not at the point where they are called in the syntax.
' This script tries to solve this problem, by reading the syntax in the active syntax window
' and sending it to SPSS for execution. When it encounters a SCRIPT command, it is
' immediately executed.
' The organization of the entire job is given to this script, not to SPSS, therefore the
' execution of a syntax containing script calls need to be invoked by launching this script.
' INCLUDE commands are also handled by the script by loading the syntax file to include,
' and executing it in the same way of the syntax in the syntax window. When the include
' syntax file terminates, the commands following the INCLUDE command are executed. Nested
' include files are supported, and the allowed number of nesting levels depends from the
' script's available free memory.
' In this way, SCRIPT commands also found in an included syntax file, are handled and
' immediately executed.
' This script acts as an interpreter: it reads every syntax line, and when either the SCRIPT
' or INCLUDE command has been recognized, it performs the appropriate action.
' Every not recognized command is sent to the SPSS processor.
'End Description
'ASSUMPTIONS
'A syntax window needs to be opened. The script executes only the code into the
'designated syntax window.
'Parameters passed with the SCRIPT command will be sent to the script to execute, but
'the script invoked by this command can read the parameters by using the Command$
'function, instead of the objSpssApp.ScriptParameter() method as usual.
'Either SCRIPT and INCLUDE commands, when placed in a macro definition (that is,
'within DEFINE - !ENDDEFINE) are ignored, and they won't be executed. Other commands
'in a macro definition will be executed as usual.
'EFFECTS
'Allows syncronization between scripts and syntax: now a script called with the
'SCRIPT command is immediately executed.
'SPSS 7.5 (tested only with SPSS version 10)
'Author: Fabrizio Arosio (spss-scripts@go.to)
' http://go.to/spss-scripts
Option Explicit
Const CMD_TERMINATOR="."
Const MIN_CHARS_ID=3
Const CMD_SCRIPT="SCR", CMD_INCLUDE="INC", CMD_DEF1="DEF", CMD_DEF2="!DEF", CMD_ENDDEFINE="!ENDDEFINE"
Function FileExists(ByVal FileName As String) As Boolean
'DESCRIPTION
' Determines whether a file exists or not
'PARAMETERS
' FileName (Input): File name to check the existance
'RETURN
' True if the file whose name is specified by FileName exists; False otherwise
Dim d As Date
On Error Resume Next
d=FileDateTime(FileName)
FileExists= (Err=0)
On Error GoTo 0
End Function
Sub GetTokens(ByVal Txt As String, ByVal TokSep As String, ByRef Tokens() As String, _
ByRef TokensPos() As Integer)
'DESCRIPTION
' Retrieves from the Txt string all tokens and put them into the Tokens array (0-based).
' A token is a block of text surrounded by any character contained in the TokSep string.
' A token does not contain any character listed in the TokSep parameter.
'
'PARAMETERS
' Txt (Input) : The text string from which extract tokens.
' TokSep (Input) : A string containing token-separating characters.
' Tokens() (Output) : A 0-based array of strings containing all found tokens.
' The first array element is of index 1.
' TokensPos() (Output) : A 0-based array of integers containing, for each element, the
' starting positionin the Txt string of the corresponding token
' element in Tokens() array (having the same index)
Dim i As Integer, Ch As String*1
Dim NewToken As Boolean, NTokens As Integer
Erase Tokens, TokensPos
NewToken=True
NTokens=-1
For i=1 To Len(Txt)
Ch=Mid(Txt,i,1)
If InStr(TokSep,Ch)=0 Then
If NewToken Then
NTokens=NTokens+1
ReDim Preserve Tokens(0 To NTokens) As String
ReDim Preserve TokensPos(0 To NTokens) As Integer
NewToken=False
TokensPos(NTokens)=i
End If
Tokens(NTokens)=Tokens(NTokens)+Ch
Else
NewToken=True
End If
Next i
End Sub
Function GetUnquotedText(ByVal Txt As String) As String
'DESCRIPTION
' Returns the text contained in the Txt parameter but without the surrounding
' quotes/Double-quotes.
' If text isn't correctly enclosed in quotes or double-quotes, an empty string
' will be returned.
'PARAMETERS
' Txt (Input): string containing the text enclosed in quotes or double-quotes.
' The first character must be a quote or double-quote.
'RETURN
' The text contained in the Txt parameter but without the surrounding quotes/double-quotes.
' An empty string if the text isn't correctly enclosed in quotes or double-quotes.
' If the quoted text contains duplicated charactes equal to the quoting character (" or '),
' it will be returned without this duplicated char.
' For example:
' Txt | returned string | comment
' "There's a "quoted"" test" | There's a "quoted" test | enclosed between " "" -> "
' 'There's a "quoted"" test' | There's a "quoted"" test | enclosed between ' '' -> '
' 'There''s a "quoted"" test' | There's a "quoted"" test | enclosed between ' '' -> '
Dim Quote As String*1
Dim i As Integer, Out As String
Select Case Left(Txt,1)
Case """"
Quote=""""
Case "'"
Quote="'"
Case Else
GetUnquotedText=""
Exit Function
End Select
If Right(Txt,1)=Quote Then
Out=""
i=2
Do
If Mid(Txt,i,2)=String(2,Quote) Then 'duplicated quote char
Out=Out+Quote 'returns only one quote char
i=i+2
Else
Out=Out+Mid(Txt,i,1)
i=i+1
End If
Loop Until i>(Len(Txt)-1)
GetUnquotedText=Out
Else
GetUnquotedText=""
Exit Function
End If
End Function
Function GetUnquotedTextLines(Lines() As String)
'DESCRIPTION
' Returns the text lines contained in Lines() parameter in a single string but without
' the surrounding quotes/double-quotes.
' If any text element (line) of the Lines() parameter isn't correctly enclosed in quotes
' or double-quotes, an empty string will be returned.
' Each line (except last one) must end with the + character, in order to specify that the
' quoted text continues in the next line. If not, an empty string will be returned.
' Empty lines are ignored.
'PARAMETERS
' Lines() (Input): 0-based string array containing in every element the text enclosed in
' quotes or double-quotes. Empty lines are ignored.
'RETURN
' All text lines in the Lines() parameter put together in a single line, without surrounding
' quotes/double-quotes.
' For more information, look at the GetUnquotedText function.
' An empty string if any Lines() text element isn't correctly enclosed in quotes or
' double-quotes OR there isn't the string-continuation character + at the end of each
' element, except the last one.
Dim i As Integer, N As Integer
Dim Txt As String, Out As String
N=UBound(Lines)
Out=""
For i=0 To N
Txt=TabTrim(Lines(i))
If Txt<>"" Then
If i"+" Then
GetUnquotedTextLines=""
Exit Function
End If
'remove the + char
Txt=Trim(Left(Txt,Len(Txt)-1))
End If
Txt=GetUnquotedText(Txt)
If Txt="" Then Exit Function
Out=Out+Txt
End If
Next i
GetUnquotedTextLines=Out
End Function
Function TrimEx(ByVal Txt As String, ByVal CharsToRemove As String) As String
'DESCRIPTION
' Returns the Txt string removed, both on the left and the right side, of any of
' the characters contained in the CharsToRemoved parameter string.
' Extends the standard Trim function by also acting on other characters (CharsToRemove)
' beside space.
'
'PARAMETERS
' Txt (Input): string to be returned without both preceeding and trailing
' characters
' CharsToRemove (Input): string containing the characters to be removed
'RETURN
' Txt string without any of both preceeding and trailing characters contained in the
' CharsToRemove parameter.
Dim i As Integer, CharToTrash As String*1
Dim Out As String, AnyRemoved As Boolean, Removed As Boolean
Out=Txt
Do
AnyRemoved=False
For i=1 To Len(CharsToRemove)
CharToTrash=Mid(CharsToRemove,i,1)
If CharToTrash<>" " Then
'delete all string's leading and trailing characters contained in CharToTrash
Do
Removed=False
'delete the string first/last CharToTrash character if present
If Left(Out,1)=CharToTrash Then
Removed=True
Out=Mid(Out,2)
End If
If Right(Out,1)=CharToTrash Then
Removed=True
Out=Left(Out,Len(Out)-1)
End If
AnyRemoved=AnyRemoved Or Removed
Loop While Removed 'loop until there is no preceeding/trailing CharToTrash
Else
'remove preceeding/trailing spaces
Txt=Trim(Out)
AnyRemoved=AnyRemoved Or Txt<>Out
Out=Txt
End If
Next i
Loop While AnyRemoved 'loop until no characters has been removed in the loop
TrimEx=Out
End Function
Function TabTrim (ByVal Txt As String) As String
'DESCRIPTION
' Returns the Txt string without the spaces and tabs both on the left and the right side.
' Extends the standard Trim functions by acting also on tabs.
'PARAMETERS
' Txt (Input): string to be returned without both preceeding and trailing spaces/tabs
'RETURN
' The Txt string without both preceeding and trailing spaces/tabs
TabTrim=TrimEx(Txt," "+vbTab)
End Function
Function ExtractLine(ByRef Txt As String) As String
'DESCRIPTION
' Extracts a line of text from the Txt string.
'PARAMETERS
' Txt (Input/Output): string from which extract a line of text. The resulting string has
' no left spaces and tabs.
'RETURN
' The extracted line without left and right spaces
Dim Pos As Long, TxtLen As Long
TxtLen=Len(Txt)
Pos=InStr(Txt,vbCr) 'find the first CR character
If Pos=0 Then 'no CR found
ExtractLine=TabTrim(Txt)
Txt=""
Else
If Pos"" Then
NLines=NLines+1
ReDim Preserve CmdCode(0 To NLines) As String
CmdCode(NLines)=TxtLine
End If
Loop Until Terminated
If TxtLine<>"" Then 'terminated with command terminator
'removes command terminator
CmdCode(NLines)=Left(CmdCode(NLines),Len(CmdCode(NLines))-Len(CMD_TERMINATOR))
End If
End Sub
Sub CodeLinesToTokens(CmdCode() As String, ByVal TokSep As String, _
Tokens() As String, Indexes() As Integer, TokensPos() As Integer)
'DESCRIPTION
' Converts the lines of code contained in the CmdCode 0-based array into an array of tokens.
' A token is a block of text surrounded by any character contained in the TokSep string.
' A token does not contain any character listed in the TokSep parameter.
'
'PARAMETERS
' CmdCode() (Input) : 0-based array of strings representing code lines.
' TokSep (Input) : string containing token-separating characters.
' Tokens() (Output): 0-based array of strings containing all command tokens.
' Indexes() (Output): 0-based array of integers with as many elements as the Tokens array,
' with each element containing the index of CmdCode array for the
' corresponding Tokens() element.
' TokensPos() (Output): A 0-based array of integers containing, for each element, the
' starting position in the CmdCode() string of the corresponding token
' element in Tokens() array (having the same index)
Dim NToks As Integer, TotToks As Integer
Dim t As Integer, i As Integer
Dim Toks() As String, ToksPos() As Integer
Erase Tokens
TotToks=-1
For i=0 To UBound(CmdCode)
GetTokens CmdCode(i),TokSep,Toks,ToksPos
NToks=UBound(Toks)
ReDim Preserve Tokens(0 To TotToks+NToks+1) As String
ReDim Preserve Indexes(0 To TotToks+NToks+1) As Integer
ReDim Preserve TokensPos(0 To TotToks+NToks+1) As Integer
For t=0 To NToks
Tokens(TotToks+t+1)=Toks(t)
Indexes(TotToks+t+1)=i
TokensPos(TotToks+t+1)=ToksPos(t)
Next t
TotToks=TotToks+NToks+1
Next i
End Sub
Sub SendCommand(Cmd() As String)
'DESCRIPTION
' Sends a syntax command to SPSS to execute. It doesn't wait for the command/procedure
' to finish.
'PARAMETERS
' Cmd() (Input): 0-based string array whose elements represent the lines of the
' command to send to SPSS.
Dim i As Integer, Txt As String, N As Integer
Txt=""
N=UBound(Cmd)
For i=0 To N
Txt=Txt+Cmd(i)
If i<>N Then
Txt=Txt+vbCrLf
End If
Next i
objSpssApp.ExecuteCommands Txt,False
End Sub
Sub ProcessScript(Cmd() As String, Tokens() As String, _
LIndexes() As Integer, TokensPos() As Integer)
'DESCRIPTION
' Executes the SCRIPT command specified by parameters.
'PARAMETERS
' Cmd() (Input): 0-based array of strings representing code lines.
' Tokens() (Input): 0-based array of strings containing all command tokens.
' LIndexes() (Input): 0-based array of integers with as many elements as the Tokens array,
' with each element containing the index of Cmd array for the
' corresponding Tokens() element.
' TokensPos() (Input): A 0-based array of integers containing, for each element, the
' starting position in the Cmd() string of the corresponding token
' element in Tokens() array (having the same index)
Dim MacroName As String, Param As String, FullTxt As String
Dim tok As Integer, NTokens As Integer, i As Integer, pidx As Integer
Dim ParamLines() As String, Txt As String
'waits for SPSS to finish the execution of all commands
objSpssApp.ExecuteCommands "Execute.",False
Do While objSpssApp.IsBusy
Loop
NTokens=UBound(Tokens)
If NTokens<1 Then
CmdErr Cmd,"SCRIPT file name missing"
End If
'get script file name
FullTxt=""
'start from 1 (2nd token): skip the SCRIPT command-name token
For tok=1 To NTokens
FullTxt=FullTxt+Tokens(tok)
MacroName=GetUnquotedText(FullTxt)
If MacroName<>"" Then
Exit For
End If
Next tok
If tok>NTokens Then 'no macro enclosed in quotes
CmdErr Cmd,"Script file name not correctly enclosed in quotes"
End If
If LIndexes(tok)<>LIndexes(1) Then 'if script name is not on one line
CmdErr Cmd,"Script file name on more than one line"
End If
MacroName=GetUnquotedText(Mid(Cmd(LIndexes(1)),TokensPos(1),TokensPos(tok)+Len(Tokens(tok))-TokensPos(1)))
If MacroName="" Then 'no macro name specified
CmdErr Cmd,"No script file name specified or script file name not correctly enclosed in quotes"
End If
'get script parameter
FullTxt=""
If tok")" Then
CmdErr Cmd,""")"" missing in script parameter"
End If
If Left(Tokens(tok+1),1)<>"(" Then
CmdErr Cmd,"""("" missing in script parameter"
End If
tok=tok+1 'next token
ReDim ParamLines(0 To LIndexes(NTokens)-LIndexes(tok)) As String
For i=LIndexes(tok) To LIndexes(NTokens)
pidx=i-LIndexes(tok)
Txt=TabTrim(Cmd(i))
If pidx=0 Then 'first parameter line
ParamLines(pidx)=Mid(Txt,TokensPos(tok)+1) 'remove the '(' char
Else
ParamLines(pidx)=Txt
End If
If i=LIndexes(NTokens) Then 'last parameter line
'remove the ')' char
ParamLines(pidx)= Left(ParamLines(pidx),Len(ParamLines(pidx))-1)
End If
Next i
Param=GetUnquotedTextLines(ParamLines)
If Param="" Then
CmdErr Cmd,"Empty ""()"" or badly quoted string in script parameter"
End If
End If
If Not FileExists(MacroName) Then
CmdErr Cmd,"Script file name '"+MacroName+"' does not exist"
End If
On Error Resume Next
MacroRun MacroName,Param
If Err<>0 Then
MsgBox "Script """+MacroName+""" contains errors."+vbCr+ _
"Parameters sent"+IIf(Param=""," none",": "+Param)+vbCr+ _
"Check the script. Syntax execution stopped.",vbOkOnly Or vbCritical,"SyntaxScript: Script execution error"
Exit All
End If
On Error GoTo 0
End Sub
Function ProcessInclude(Cmd() As String, Tokens() As String, _
LIndexes() As Integer, TokensPos() As Integer) As String
'DESCRIPTION
' Returns the syntax specified in the INCLUDE command.
'PARAMETERS
' Cmd() (Input): 0-based array of strings representing code lines.
' Tokens() (Input): 0-based array of strings containing all command tokens.
' LIndexes() (Input): 0-based array of integers with as many elements as the Tokens array,
' with each element containing the index of Cmd array for the
' corresponding Tokens() element.
' TokensPos() (Input): A 0-based array of integers containing, for each element, the
' starting position in the Cmd() string of the corresponding token
' element in Tokens() array (having the same index)
'RETURN
' A string containing all syntax stored in the file to include.
Const CMD_FILE="FIL"
Dim NTokens As Integer, tok As Integer, i As Integer, Pos As Integer
Dim FileName As String, FullTxt As String, Lines() As String
NTokens=UBound(Tokens)
If NTokens<1 Then
CmdErr Cmd,"INCLUDE file name missing"
End If
'INCLUDE [FILE][=] filename
If UCase(Left(Tokens(1),3))=CMD_FILE Then 'skip the INCLUDE token (having index=0)
'INCLUDE FILE [=] filename
Pos=InStr(Tokens(1),"=")
If Pos>0 And Pos0 Then
CmdErr Cmd,"Include file name not correctly enclosed in quotes"
Else 'file name not enclosed in quotes
FileName=FullTxt
End If
End If
If Not FileExists(FileName) Then
CmdErr Cmd,"Include file name '"+FileName+"' does not exist"
End If
'read the include file syntax
FullTxt=""
i=FreeFile
Open FileName For Input As #i
Do While Not EOF(i)
Line Input #i, FileName
If FullTxt<>"" Then
FullTxt=FullTxt+vbCrLf
End If
FullTxt=FullTxt+FileName
Loop
Close #i
ProcessInclude=FullTxt
End Function
Sub CmdErr (Cmd() As String, ByVal ErrDescr As String)
'DESCRIPTION
' Interrupts the syntax execution for the error described in the ErrDescr parameter,
' caused by the command whose lines are contained in the Cmd array.
' Writes the error message to the current output window.
'PARAMETERS
' Cmd() (Input): 0-based array of strings representing code lines.
' ErrDescr (Input): string containing the error description
Const ERR_STR="SyntaxScript ERROR."
Dim i As Integer, n As Integer, e As String, RTF As String, LogStr As String
Dim OutDoc As ISpssOutputDoc, objItem As ISpssItem
With objSpssApp
If .Documents.OutputDocCount=0 Then
Set OutDoc = objSpssApp.NewOutputDoc
OutDoc.Visible=True
Else
Set OutDoc=.GetDesignatedOutputDoc
End If
End With
e="> SyntaxScript ERROR:"+vbCr+"> "+ErrDescr+vbCr
e=e+"> in command:"+vbCr+"> """
For i=0 To UBound(Cmd)
e=e+Cmd(i)
If i "
End If
Next i
e=e+""""
'objSpssApp.ExecuteCommands "!SyntaxScript Error!",True 'generates an error in a new Log object
With OutDoc
.ClearSelection
.Items.GetItem(.Items.Count-1).Current=True 'set navigator's last item as the current item
.InsertTitle "SyntaxScript ERROR", e 'insert the error message
'search for a log text object
i=.Items.Count-1
Do
Set objItem=.Items.GetItem(i)
If objItem.SPSSType=SPSSLog Then
Exit Do
Else
i=i-1
End If
Loop Until i<0
If i<0 Then 'log obj not found
'invoke an error in order to generate a log text obj
objSpssApp.ExecuteCommands ERR_STR,True
'get the log text object
i=.Items.Count-1
Do
Set objItem=.Items.GetItem(i)
If objItem.SPSSType=SPSSLog Then
Exit Do
Else
i=i-1
End If
Loop Until i<0
End If
With objItem 'log text obj item
With .ActivateText
LogStr=.Text 'preserve log text
.Text="" 'clear string
RTF=.RTFText 'store RTF code for empty string
.Text=LogStr 'restore log text
End With
.Deactivate
If i=(OutDoc.Items.Count-1) Then 'not log continuation
OutDoc.ClearSelection
.Selected=True
OutDoc.Delete
End If
End With
Set objItem=.Items.GetItem(.Items.Count-1) 'inserted title element
With objItem
With .ActivateText
.RTFText=RTF 'set same formatting of log text element
.Text=e 'write the error message with the new format
End With
.Deactivate
'count number of lines (n) in error message
i=1
n=1
Do
i=InStr(i,e,vbCr)
If i>0 Then
n=n+1
i=i+1
End If
Loop Until i=0
'set error message height
.Height=.Height*n
End With
End With
Exit All
End Sub
Sub RunSyntax(ByVal Syntax As String)
'DESCRIPTION
' Executes the syntax contained in the Syntax string parameter.
' Identifies the SCRIPT command in order to execute it in the right place.
'PARAMETERS
' Syntax (Input): a string containing the syntax commands to execute.
Dim Cmd() As String, Tokens() As String, LineIndexes() As Integer, TokensPos() As Integer
Dim InDefine As Boolean
InDefine=False
Do While Syntax<>""
ExtractCmdCode Syntax,Cmd
CodeLinesToTokens Cmd," "+vbTab,Tokens,LineIndexes,TokensPos
'select commands to act
Select Case UCase(Left(Tokens(0),MIN_CHARS_ID))
Case CMD_DEF1,CMD_DEF2
InDefine=True
SendCommand Cmd
Case IIf(UCase(Left(Tokens(0),Len(CMD_ENDDEFINE)))=CMD_ENDDEFINE,Left(CMD_ENDDEFINE,MIN_CHARS_ID),"")
InDefine=False
SendCommand Cmd
Case CMD_SCRIPT
If Not InDefine Then 'script calls within a macro are ignored
ProcessScript Cmd,Tokens,LineIndexes,TokensPos
End If
Case CMD_INCLUDE
If Not InDefine Then 'include file commands within a macro are ignored
'recursive RunSyntax
RunSyntax ProcessInclude(Cmd,Tokens,LineIndexes,TokensPos)
End If
Case Else
SendCommand Cmd
End Select
Loop
End Sub
Sub Main
With objSpssApp
If .Documents.SyntaxDocCount>0 Then
RunSyntax .GetDesignatedSyntaxDoc.Text
Else
MsgBox "No syntax window opened.",vbOkOnly Or vbCritical,"SyntaxScript.Sbs"
End If
End With
End Sub