Print options | Raynald's SPSS Tools

'Begin Description
'Parameters are passed in from a SCRIPT command:
'SCRIPT "PrintOptions.sbs" /("HEADER='Header from script' "+
'     "FOOTER='Footer from script' ") .
'Supply named parameters e.g. HEADER and FOOTER:
'  HEADER="Use this Header", FOOTER="and this footer.  Page &[Page]" }@ .
'Values may be space-delimited, comma-delimited, or quoted (single or double).
'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.
'Moreover, it can print the output or request a new output document.
'End Description
'
'Solution ID: 100001561 
'
'************************************************************
' To build your own script which parses parameters from the log:
' Customize Sub Main, or add the routines following Sub Main 
' to your script, and study Sub Main for examples of how to 
' use them.
'************************************************************

Sub Main

	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
	strParams = objSpssApp.ScriptParameter(0)
	
	If strParams = "" Then
		strParams = InputBox("Enter the parameter string: ", "Print Options", "HEADER=' ', FOOTER=' '")
	End If
	
	'Debug.Print strParams
	
	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


'************************************************************
' PARSING ENGINE
'
' Add the following to a script to allow syntax files to 
' parse parameters passed to the script 
'
'       GetNextParam
'       GetNextToken
'       GetNamedParameter
'
'************************************************************

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 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

'************************************************************
'END PARSING ENGINE
'************************************************************
...
Navigate from here