1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
'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
'************************************************************