Set Parameters for Printing via Syntax

'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": 
'**********************************************************************