Настройка параметров печати файла выдачи

 

Загрузить как .sbs Показать простым текстом

 

  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
'Begin Description
'Параметры передаются из синтаксиса командой SCRIPT..:
'SCRIPT "PrintOptions.sbs" /("HEADER='верхний колонтитул' "+
'     "FOOTER='нижний колонтитул' ").
'...либо вводятся при запуске скрипта "вручную" - примеч. перев.
'Передаваемые параметры должны иметь следующий вид (покажем на примере параметров HEADER и FOOTER):
'  HEADER="Используем данный верхний колонтитул", FOOTER="...а также следующий нижний колонтитул с номером страницы: стр. &[Page]" .
'Передаваемые параметры должны быть разделены пробелом, запятой, либо кавычками (одинарными или двойными).
'Номер первой страницы может быть установлен с помощью параметра STARTPAGE,
' ориентация страницы (ORIENTATION) может быть установлена  как книжная (PORTRAIT) или альбомная (LANDSCAPE).
'Все установки, которые можно делать в диалоге "Page Setup", могут быть сделаны скриптом.
'Кроме того, из скрипта можно распечатать выдачу или создать новый документ выдачи
' (см. параметры PrintDoc и NewDoc ниже - прим. перев.).
'End Description
'
'Код решения: 100001561
'
'************************************************************
' Чтобы создать собственный скрипт, который работает с параметрами, переданными из синтаксиса,
' внесите нужные исправления в процедуру Main, либо добавьте процедуры, идущие после Main в
' ваш скрипт и посмотрите в Main как их следует использовать
'************************************************************

'Тема: Установка параметров страницы для печати из скрипта (с возможностью передачи параметров через синтаксис)
'Ключевые слова: печать, колонтитул, передача, параметры, синтаксис, скрипт, страница, ориентация.
'Опубликован: ?, перевод: 24.06.2008.
'Автор: ? (корп. SPSS); перевод коммент.: А. Балабанов.
'Размещение: http://www.spsstools.ru/Scripts/Printing/PrintOptions.txt (.sbs)
'Проверено: SPSS 15.0.0.

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 "Необходимо открыть документ выдачи (output) " & _
        '       "перед вызовом скрипта.", vbexclamation
        End
	End If
	
	'strParams = GetParametersFromLog
	strParams = objSpssApp.ScriptParameter(0)
	
	If strParams = "" Then
		strParams = InputBox("Задайте строку параметров: ", "Page Setup: Options", "HEADER=' ', FOOTER=' '")
	End If
	
	'Debug.Print strParams
	
	strParam = GetNamedParameter(strParams, "Header", "=")
	objPrintOpt.HeaderText = strParam
	'по умолчанию верхний колонтитул не задан, так что указание пустой строки ничего не меняет
	
	strParam = GetNamedParameter (strParams, "Footer", "=", Found)
	'если ничего не указано, не меняем установки нижнего колонтитула по умолчанию: Page &[Page]
	If Found Then
        objPrintOpt.FooterText = strParam
	End If
	
	'Для ссылки на параметр ориентации страницы (Orientation) подойдёт краткое Orient
	strParam = GetNamedParameter (strParams, "Orient", "=", Found)
	If Found Then
        strParam = UCase$(Left$(strParam, 4))
        If (InStr(1, strParam, "PORT") > 0) Then
            objPrintOpt.Orientation = 1     'Книжная
        ElseIf (InStr(1, strParam, "LAND") > 0) Then
            objPrintOpt.Orientation = 2     'Альбомная
        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
	
	'Для ссылки на параметр расстояния между объектами (SpaceBetweenItems) подойдёт краткое Space
	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        'как есть
        ElseIf (InStr(1, strParam, "FULL") > 0) Then
            objPrintOpt.PrintedChartSize = 1        'на всю страницу
        ElseIf (InStr(1, strParam, "HALF") > 0) Then
            objPrintOpt.PrintedChartSize = 2        'на половину страницы
        ElseIf (InStr(1, strParam, "QUAR") > 0) Then
            objPrintOpt.PrintedChartSize = 3        'на четверть страницы
        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)       'печать всей видимой выдачи
        ElseIf (InStr(1, strParam, "SELECT") > 0) Then
        	objDocument.PrintRange(1)       'печать выделенной части выдачи
        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


'************************************************************
' Функции разбора переданных параметров
'
' Добавьте данные функции к своему скрипту для того, чтобы иметь возможность разбирать и
' использовать переданные ему параметры из синтаксиса:
'       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
    'Функция ищёт что-либо внутри строки, стоящее между двойными или одинарными кавычками,
    ' пробелами, либо иными разделителями, указанными константой PARAM_DELIMITER
    'Функция предполагает, что ведущие и концевые пробелы из строки параметров удалены

    'в качестве разделителей параметров будет выступать запятая
    Const PARAM_DELIMITER As String = ","
        
    Dim Position As Integer
    Dim FirstChar As String
    FirstChar = Left$(LTrim$(TokenString), 1)
    Select Case FirstChar
        Case Chr$(34), "'"
            'поиск закрывающей кавычки
            Position = InStr(2, TokenString, FirstChar)
            If Position > 0 Then
                GetNextParam = Mid$(TokenString, 2, Position - 2)
                TokenString = Mid$(TokenString, Position + 1)
            Else            'нет закрывающей кавычки, ошибка
                TokenString = ""
                GetNextParam = ""
            End If
        Case Else
	        'первый символ - не кавычка, проверяем прочие разделители: PARAM_DELIMITER, либо пробел
            Position = InStr(UCase$(TokenString), UCase$(PARAM_DELIMITER))
            If Position = 0 Then
                Position = InStr(TokenString, " ")
                If Position = 0 Then  'весь отрезок является единым целым (значением параметра)
                    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
	'ищет именованный параметр, после которого следует разделитель,
	'и возвращает значения параметра, стоящее после разделителя
	' (в данном случае идёт речь не о разделителе параметров (запятой, в данном случае),
	' а о символе, отделяющей имя параметра от его значения (знаке "равно", в данном случае) - примеч. перев.)
    Dim strParamsCopy As String
    Dim strParam As String
    Dim strToken As String
    
    Dim Position As Integer
    
    strParamsCopy = LTrim$(strParams)
    
    Do
        GetNextToken (strParamsCopy, strParamName)
        'если имя не было найдено, длина строки будет нулевой
        Found = (Len(strParamsCopy) > 0)
        
        If Found Then
            'проверка правильности записи строки параметров: значения параметров должны находиться
            'после разделителей без "вкраплений" кавычек перед разделителем
            Position = InStr(1, strParamsCopy, strDelimiter)
            If Position > 0 Then
                'проверка, что часть строки с параметрами не является частью закавыченной строки
                strToken = Left$(strParamsCopy, Position - 1)
                'если между именем параметра и разделителем обнаружены кавычки, переданное значение игнорируется
                Found = ((InStr(1, strToken, "'") = 0) And _
                        (InStr(1, strToken, Chr$(34)) = 0))
            Else
                'если не было разделителя, отвергаем переданное значение
                Found = False
            End If                          
        End If
        
        If Found Then   'удаление части строки, предшествующей разделителю
                strParamsCopy = Trim$(Right$(strParamsCopy, _
                        Len(strParamsCopy) - Position - Len(strDelimiter) + 1))
        End If
        
        'выходим из цикла если найдено имя параметра,
        'либо строка с параметрами полностью обработана
    Loop Until Found Or (Len(strParamsCopy) = 0)
    
    'теперь используем функцию GetNextParameter для поиска
    'закавыченного значения (либо значения, отделённого пробелом или запятой)
    strParam = Trim$(GetNextParam(strParamsCopy))
    
    'удаляем разрывы строк, если такие имеются
    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

'************************************************************
'Конец секции функций разбора переданных параметров
'************************************************************
Related pages

...

Navigate from here