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