'Solution ID: 100001561
'Version: O/S: WINDOWS
'Title:
'Setting Print options from a syntax file
Description:
'Q.
'I am running an SPSS Syntax (Or Production Mode) job using SPSS Base For Windows.
'I would Like To be able To Set the Print options, but I can't seem to
'Do that without using a Dialog box. Is there Any way that I can Set
'* Header
'* Footer
'* Orientation [ Portrait | Landscape ]
'* Starting Page
'* Space Between Items
'* Chart Size [ AsIs | Full | Half | Quarter ]
'* Paper Size [ Letter | Legal ]
'* Print Range [ All | Selected ]
'from a syntax file?
'I would Like To be able To use different headers And footers For
'different portions of my syntax job. Is there Any way I can request
'a New document?
'Is there Any way I can Print the document from a syntax file?
'A.
'Yes there Is a way To Do this.
'It Is possible To control All Print options through Scripting, And To
'trigger a Script from a syntax job. What Is awkward Is passing
'information from the syntax job To the script. The script below uses
'one solution To the problem. The creator of the syntax file writes
'parameters As comments With special markers, Then triggers the script.
'The script parses the parameters out of the SPSS Log, Then makes the
'requested changes To the Print Options Dialog. The author of the
'syntax file should ensure that commands will be displayed In the Log.
'The safest way To Do this Is With Set PRINTBACK=LISTING.
'Within a block of comments (which Begin With asterisks), use @{
'To mark the beginning of your parameters. Continue naming
'parameters And their values For As many comment lines As needed,
'being sure To Begin Each Line With an asterisk. Mark the End of
'the parameter block With }@.
'The parameter names are Not Case sensitive. The script will look
'at the first portion of most parameter names, so that "Space",
'"SpaceB", Or "SpaceBetweenItems" will All match. Once a parameter
'Name has been located, the script will look For an equal sign, Then
'try To find a value To assign. It should never make an illegal
'assignment, As the script checks the values before changing the Print
'options.
'A syntax job which illustrates the use of the script And documents
'the available options follows immediately below. The script follows
'the syntax job; the two need To be saved into separate files As
'directed by the comments below.
'The script itself should be named "PrintOptions.SBS" In order For
'the syntax below To work unaltered. Use a fully-qualified path Name
'On the SCRIPT Command If the syntax And script file will be placed
'In different directories.
'**********************************************************************
'* Save this portion As a syntax (.sps) file. Begin here.
'**********************************************************************
'* PrintOptions script requires PrintBack = Listing.
'* To be polite, save current settings before making the change.
'Preserve .
'Set printback=listing .
'* Parameters For PrintOptions script: @{
'* Header="Your Favorite Header Here",
'* Footer="Footer text here ... Page &[Page]",
'* Orientation = landscape ,
'* StartPage=7 ,
'* NewDocument = True
'* }@ .
'script "PrintOptions.sbs" .
'* Note: &[Page] is the page number symbol.
'* It will be replaced by the correct number On Each page, beginning With
'StartPage.
'* Parameters For PrintOptions script, illustrating All parameters: @{
'* Header="Strings can even have 'Footer' (which is a parameter name) and
'quotes",
'* Footer='Use single quotes around "double quotes" and vice versa
'[&[Page]]',
'* Orientation = landscape , [ Portrait | Landscape ]
'* StartPage= 17 , [ any number ]
'* SpaceBetweenItems = 24, [ any number ]
'* ChartSize = AsIs, [ AsIs | Full | Half | Quarter ]
'* PaperSize = Letter, [ Letter | Legal ]
'* PrintRange = All, [ All | Selected ]
'* PrintDocument = False, [ True | False ]
'* NewDocument = False, [ True | False ]
'* }@ .
'script "PrintOptions.sbs" .
'* Restore the options saved by the Preserve Command .
'restore .
'**********************************************************************
'* Save this portion As a syntax (.sps) file. End here.
'**********************************************************************
'**********************************************************************
'Save the following to a script named "PrintOptions.SBS":
'**********************************************************************
Sub Main
'parameters are presumed to be in the log
'use a comment marked by "*@{" and ending with "}@"
'supply named parameters HEADER and FOOTER, in a syntax file
' *@{HEADER="Use this Header", FOOTER="and this footer. Page &[Page]"
'The starting page number can also be set with STARTPAGE
' and the ORIENTATION may be set to PORTRAIT or LANDSCAPE.
'Everything which can be controlled from the Print Options dialog
' can be set using this script.
Dim strParams As String
Dim strParam As String
Dim Found As Variant
Dim lngPage As Long
Dim objDocument As ISpssOutputDoc
Dim objPrintOpt As ISpssPrintOptions
If objSpssApp.Documents.OutputDocCount > 0 Then
Set objDocument = objSpssApp.GetDesignatedOutputDoc
Set objPrintOpt = objDocument.PrintOptions
Else
'msgbox "Please open an output document " & _
' "before running this script.", vbexclamation
End
End If
strParams = GetParametersFromLog
strParam = GetNamedParameter(strParams, "Header", "=")
objPrintOpt.HeaderText = strParam
'no header by default, so setting it to an empty string hurts nothing
strParam = GetNamedParameter (strParams, "Footer", "=", Found)
'don't clobber the default footer (Page &[Page]) if none specified
If Found Then
objPrintOpt.FooterText = strParam
End If
'any portion of Orientation which includes Orient is acceptable
strParam = GetNamedParameter (strParams, "Orient", "=", Found)
If Found Then
strParam = UCase$(Left$(strParam, 4))
If (InStr(1, strParam, "PORT") > 0) Then
objPrintOpt.Orientation = 1 'Portrait
ElseIf (InStr(1, strParam, "LAND") > 0) Then
objPrintOpt.Orientation = 2 'Landscape
End If
End If
strParam = GetNamedParameter (strParams, "StartPage", "=", Found)
If Found Then
lngValue = Val(strParam)
If lngValue > 0 Then
objPrintOpt.StartingPageNumber = lngValue
End If
End If
'any portion of SpaceBetweenItems which includes Space is acceptable
strParam = GetNamedParameter (strParams, "Space", "=", Found)
If Found Then
lngValue = Val(strParam)
If lngValue > 0 Then
objPrintOpt.SpaceBetweenItems = lngValue
End If
End If
strParam = GetNamedParameter (strParams, "ChartSize", "=", Found)
If Found Then
strParam = UCase$(Left$(strParam, 4))
If (InStr(1, strParam, "ASIS") > 0) Then
objPrintOpt.PrintedChartSize = 0 'As is
ElseIf (InStr(1, strParam, "FULL") > 0) Then
objPrintOpt.PrintedChartSize = 1 'full page
ElseIf (InStr(1, strParam, "HALF") > 0) Then
objPrintOpt.PrintedChartSize = 2 'half page
ElseIf (InStr(1, strParam, "QUAR") > 0) Then
objPrintOpt.PrintedChartSize = 3 'quarter page
End If
End If
strParam = GetNamedParameter (strParams, "PaperSize", "=", Found)
If Found Then
strParam = UCase$(strParam)
If (InStr(1, strParam, "LETTER") > 0) Then
objPrintOpt.PaperSize = 1 'Letter
ElseIf (InStr(1, strParam, "LEGAL") > 0) Then
objPrintOpt.PaperSize = 5 'Legal
End If
End If
strParam = GetNamedParameter (strParams, "PrintRange", "=", Found)
If Found Then
strParam = UCase$(strParam)
If (InStr(1, strParam, "ALL") > 0) Then
objDocument.PrintRange(0) 'All Expanded Output
ElseIf (InStr(1, strParam, "SELECT") > 0) Then
objDocument.PrintRange(1) 'Selection
End If
End If
strParam = GetNamedParameter (strParams, "PrintDoc", "=", Found)
If Found Then
If (InStr(1, UCase$(Left$(strParam, 4)), "TRUE") > 0) Then
objDocument.PrintDoc
End If
End If
strParam = GetNamedParameter (strParams, "NewDoc", "=", Found)
If Found Then
If (InStr(1, UCase$(Left$(strParam, 4)), "TRUE") > 0) Then
objSpssApp.NewOutputDoc
End If
End If
End Sub
Function GetParametersFromLog() As String
'check for parameters in comments marked with @
Const PARAMS_BEGIN As String = "@{"
Const PARAMS_END As String = "}@"
Dim strLog As String
Dim strParams As String
Dim strToken As String
strLog = GetLogText()
strParams = strLog
'look In the Log For the last comment which begins With PARAMS_BEGIN:
Do
intLastPos = intPos
intPos = InStr (intLastPos+1, strLog, PARAMS_BEGIN)
Loop While intPos > 0
If intLastPos > 0 Then
'found a comment marked with the designator
'set up the parameter string
strParams = Trim$(Mid$ (strLog, intLastPos))
'discard the designator
strParams = Trim$(Mid$ (strParams, Len(PARAMS_BEGIN)+1))
'check for a final designator
If Len(strParams) > 0 Then
intPos = InStr(1, strParams, PARAMS_END)
Else
intPos = 0
End If
'discard final designator (and beyond), if present
If intPos > 0 Then
strParams = Trim$(Left$(strParams, intPos-1))
End If
Else
'no parameters were found
strParams = ""
End If
Debug.Print strParams
GetParametersFromLog = strParams
End Function
Function GetNextToken(TokenString As String, Delimiter As String) As
String
Dim Position As Integer
Position = InStr(UCase$(TokenString), UCase$(Delimiter))
If Position = 0 Then
GetNextToken$ = Trim$(TokenString)
TokenString = ""
Else
GetNextToken$ = Trim$(Left$(TokenString, Position - 1))
TokenString = Right$(TokenString, _
Len(TokenString) - Position - Len(Delimiter) + 1)
End If
End Function
Function GetNextParam(TokenString As String) As String
'Look for something inside either double or single quotes
' or for Space or PARAM_DELIMITER as delimiter
'Function assumes blanks have been trimmed from both ends
'separate parameters with commas
Const PARAM_DELIMITER As String = ","
Dim Position As Integer
Dim FirstChar As String
FirstChar = Left$(LTrim$(TokenString), 1)
Select Case FirstChar
Case Chr$(34), "'"
'look for matching quote
Position = InStr(2, TokenString, FirstChar)
If Position > 0 Then
GetNextParam = Mid$(TokenString, 2, Position - 2)
TokenString = Mid$(TokenString, Position + 1)
Else 'No matching token, error
TokenString = ""
GetNextParam = ""
End If
Case Else
'First char is not a quote, look for either
'PARAM_DELIMITER or space as delimiter
Position = InStr(UCase$(TokenString), _
UCase$(PARAM_DELIMITER))
If Position = 0 Then
Position = InStr(TokenString, " ")
If Position = 0 Then 'whole thing must be the token
GetNextParam = TokenString
TokenString = ""
Else
GetNextParam = Mid$(TokenString, 1, Position)
TokenString = Mid$(TokenString, _
Position + Len(PARAM_DELIMITER))
End If
Else
GetNextParam = Mid$(TokenString, 1, Position - 1)
TokenString = Mid$(TokenString, _
Position + Len(PARAM_DELIMITER))
End If
End Select
End Function
Function GetLogText() As String
Dim objOutput As ISpssOutputDoc
Dim objItems As ISpssItems
Dim objitem As ISpssItem
Dim objLog As ISpssrtf
Dim strLog As String
Dim lngCount As Long 'number of items in the navigator
Dim i As Long 'for-loop index
Set objOutput = objSpssApp.GetDesignatedOutputDoc
Set objItems = objOutput.Items
lngCount = objItems.Count
'find and activate the log
For i = lngCount - 1 To 0 Step -1
Set objItem = objItems.GetItem(i)
If objItem.SPSSType = SPSSLog Then
Set objLog = objItem.ActivateText
Exit For
End If
Next
If objLog Is Nothing Then 'couldn't find the log
GetLogText = ""
Exit Function
End If
strLog = objLog.Text
objItem.Deactivate
'Debug.Print "SPSS Log: " & vbCrLf & strLog
GetLogText = strLog
End Function
Function GetNamedParameter(ByVal strParams As String, _
ByVal strParamName As String, _
ByVal strDelimiter As String, _
Optional Found As Variant) As String
'searches for a parameter name, followed by the specified delimiter,
'and returns the parameter value after the delimiter
Dim strParamsCopy As String
Dim strParam As String
Dim strToken As String
Dim Position As Integer
strParamsCopy = LTrim$(strParams)
Do
GetNextToken (strParamsCopy, strParamName)
'if the name wasn't found, the length will be zero
Found = (Len(strParamsCopy) > 0)
If Found Then
'enforce syntax rules: must be paired with delimiter,
' without intervening quotes, to be legal
Position = InStr(1, strParamsCopy, strDelimiter)
If Position > 0 Then
'make sure that it isn't part of a quoted string
strToken = Left$(strParamsCopy, Position - 1)
'if quotes are between the parameter name
'and the delimiter, reject it
Found = ((InStr(1, strToken, "'") = 0) And _
(InStr(1, strToken, Chr$(34)) = 0))
Else
'it wasn't paired with the delimiter, reject it
Found = False
End If
End If
If Found Then 'remove the portion preceding the delimiter
strParamsCopy = Trim$(Right$(strParamsCopy, _
Len(strParamsCopy) - Position - Len(strDelimiter) + 1))
End If
'exit the loop when a name has been found
'or the parameters have been exhausted
Loop Until Found Or (Len(strParamsCopy) = 0)
'now use GetNextParameter to find a
'quoted, space- or comma-delimited value
strParam = Trim$(GetNextParam(strParamsCopy))
'remove line breaks if present
Position = InStr(1, strParam, vbCrLf)
If Position > 1 Then
strParam = Trim$(Left$(strParam, Position - 1))
End If
Debug.Print "GetNamedParameter: " & strParam
GetNamedParameter = strParam
End Function
'**********************************************************************
'Save the preceding to a script named "PrintOptions.SBS":
'**********************************************************************