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
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
'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": 
'**********************************************************************