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

'BEGIN DESCRIPTION
'Опубликован: ?, перевод: 24.06.2008.
'Автор: ? (корп. SPSS); перевод: А. Балабанов.
'Размещение: http://www.spsstools.ru/Scripts/Printing/ReadScriptParametersFromLogFile.txt (.sbs)
'Проверено: SPSS 15.0.0.

'Код решения:  100001561
'Вид ОС:  WINDOWS
'END DESCRIPTION

'Заголовок:
'Установка параметров печати через файл синтаксиса

'Описание:
'Вопрос.
'Я пользуюсь синтаксисом (иногда - в производственном режиме (Production Mode)) в пакете SPSS Base для Windows.
'Я хотел бы иметь возможность настройки параметров печати, но, кажется, это нельзя сделать иначе, чем в
'диалоговом окне. Конкретнее: есть ли способ указать такие параметры печати, как...
'* Header (верхний колонтитул)
'* Footer (нижний колонтитул)
'* Orientation [ Portrait | Landscape ] (ориентация: книжная/альбомная)
'* Starting Page (начальный номер страницы)
'* Space Between Items (интервал между объектами)
'* Chart Size [ AsIs | Full | Half | Quarter ] (масштабирование графиков: как есть/полная страница/половина/четверть страницы)
'* Paper Size [ Letter | Legal ] (размер бумаги: Letter/Legal)
'* Print Range [ All | Selected ] (диапазон печати: всё/выделенное)
'из файла синтаксиса?

'Я хотел бы использовать разные колонтитулы для разных этапов обработки данных. Кроме того, есть ли способ запросить
'создание нового документа выдачи из синтаксиса? И есть ли способ дать команду на печать выдачи из файла синтаксиса?

'Ответ.
'Да, есть способ сделать всё это.

'В SPSS есть возможность контролировать все параметры печати через скрипты, а скрипт
'можно вызвать из синтаксиса. Так что задача сводится к тому, чтобы передать скрипту нужные параметры
'при вызове его из синтаксиса.
'Скрипт, приведённый здесь, предлагает один из способов решения этой проблемы. Автор файла синтаксиса
'записывает нужные ему параметры печати как комментарии со специальными пометками, после чего
'вызывает скрипт. Скрипт находит переданные ему параметры путём анализа "лога" - журнала команд, в
'котором, кроме прочего, оказываются и комментарии с параметрами печати, после чего делает нужные
'установки параметров печати. Автор синтаксиса должен обеспечить появление комментариев в журнале
'команд. Наиболее надёжный способ сделать этого - использовать команду Set PRINTBACK=LISTING.

'Для блока комментариев (начинаются с символа "*") с параметрами используйте сочетания
'символов @{ для обозначения начала передачи параметров и @} для обозначения окончания передачи параметров.
'Сами параметры (их может быть достаточно много) записываются в отдельных строках внутри этих комбинаций символов.

'Имена параметров нечувствительны к регистру символов. Скрипт будет проверять совпадения начальных фрагментов
'имён параметров при их распознавании, так что для ссылки на один и тот же параметр подойдут обозначения "Space",
'"SpaceB", или "SpaceBetweenItems". Как только будет обнаружено имя очередного существующего параметра, скрипт
'начинает искать символ "равно", после которого - значение параметра. Скрипт не должен сделать неправильных
'назначений параметров при любых ошибках пользователя, так как переданные строки проверяются на соответствие
'определённому формату задания параметров.

'Непосредственно после этих комментариев приводятся команды синтаксиса, иллюстрирующие задание параметров
'и взаимодействие со скриптом. Кроме того, в нём перечислены возможные значения всех параметров. Далее следует
'содержание скрипта, разбирающего параметры и делающего назначения параметров печати. Эти две части примера должны
'быть сохранены в разных файлах как это сказано в инструкциях ниже.

'Сам скрипт следует назвать "ReadScriptParametersFromLogFile.sbs" чтобы синтаксис, приведённый
'ниже сработал без лишних изменений. Если файлы скрипта и синтаксиса будут расположены в разных директориях,
'для команды SCRIPT в синтаксисе потребуется указать полный путь к файлу скрипта.

'********************************************************************** 
'* Сохраните следующее в файле синтаксиса (с расширением .sps). Начните отсюда.
'********************************************************************** 

'* Скрипт ReadScriptParametersFromLogFile.sbs требует включения опции записи команд в "журнал": PrintBack = Listing.
'* Чтобы быть аккуратными, сохраним текущие настройки журналирования перед тем, как изменить их.
'Preserve . 
'Set printback=listing . 

'* Пример установки параметров печати для ReadScriptParametersFromLogFile.sbs: @{
'* Header="Your Favorite Header Here", 
'* Footer="Footer text here ... Page &[Page]", 
'* Orientation = landscape , 
'* StartPage=7 , 
'* NewDocument = True 
'* }@ . 
'script "ReadScriptParametersFromLogFile.sbs" .

'* Примеч.: &[Page] - символ, на место которого SPSS подставляет номер страницы.
'* На место этого набора символов будет подставлен соответствующий номер страницы, начиная с того, который указан в параметре StartPage.

'* Параметры для скрипта ReadScriptParametersFromLogFile.sbs (все возможные параметры): @{
'* Header="Строки могут содержать даже слово 'Footer' (которое является именем параметра) и 'кавычки",
'* Footer='Используйте одинарные кавычки снаружи двойных "double quotes" и наоборот '[&[Page]]',
'* Orientation = landscape , [ Portrait | Landscape ] 
'* StartPage= 17 , [ любое число ]
'* SpaceBetweenItems = 24, [ любое число ]
'* ChartSize = AsIs, [ AsIs | Full | Half | Quarter ] 
'* PaperSize = Letter, [ Letter | Legal ] 
'* PrintRange = All, [ All | Selected ] 
'* PrintDocument = False, [ True | False ] 
'* NewDocument = False, [ True | False ] 
'* }@ . 
'script "ReadScriptParametersFromLogFile.sbs" .

'* Восстановим исходные настройки журналирования, сохранённые командой Preserve выше.
'restore . 

'********************************************************************** 
'* Конец файла синтаксиса..
'********************************************************************** 

'********************************************************************** 
'Сохраните следующее в файле скрипта с именем "ReadScriptParametersFromLogFile.SBS":
'********************************************************************** 

Sub Main 
'Предполагается, что параметры находятся в журнале команд
в блоке комментариев, который начинается с "*@{" и заканчивается на  "}@".
'Передаваемые параметры должны иметь следующий вид (покажем на примере параметров HEADER и FOOTER):
'  *@{HEADER="Используем данный верхний колонтитул", FOOTER="...а также следующий нижний колонтитул с номером страницы: стр. &[Page]" .
'Передаваемые параметры должны быть разделены пробелом, запятой, либо кавычками (одинарными или двойными).
'Начальный номер страницы может быть установлен с помощью параметра STARTPAGE,
' ориентация страницы (ORIENTATION) может быть установлена  как книжная (PORTRAIT) или альбомная (LANDSCAPE).
'Все установки, которые можно делать в диалоге "Page Setup", могут быть сделаны скриптом.

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 

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 

Function GetParametersFromLog() As String 
'поиск параметров среди комментариев, отмеченных значком @
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 

'поиск последнего комментария в журнале, отмеченного символами PARAMS_BEGIN:
Do 
intLastPos = intPos 
intPos = InStr (intLastPos+1, strLog, PARAMS_BEGIN) 
Loop While intPos > 0 

If intLastPos > 0 Then 
'найден блок с искомой пометкой; считываем блок параметров
strParams = Trim$(Mid$ (strLog, intLastPos)) 

'избавляемся от спецсимволов пометки
strParams = Trim$(Mid$ (strParams, Len(PARAMS_BEGIN)+1)) 

'поиск спецсимволов конца блока параметров
If Len(strParams) > 0 Then 
intPos = InStr(1, strParams, PARAMS_END) 
Else 
intPos = 0 
End If 
'избавляемся от спецсимволов конца блока (и всего, что за ним), если есть
If intPos > 0 Then 
strParams = Trim$(Left$(strParams, intPos-1)) 
End If 

Else 
'параметры не были найдены
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 
    'Функция ищёт что-либо внутри строки, стоящее между двойными или одинарными кавычками,
    ' пробелами, либо иными разделителями, указанными константой 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 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 'число объектов в окне выдачи
Dim i As Long 'счётчик для циклов

Set objOutput = objSpssApp.GetDesignatedOutputDoc 
Set objItems = objOutput.Items 
lngCount = objItems.Count 

'отыщем и активируем журнальный блок в выдаче
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 'невозможно найти журнал
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 
	'ищет именованный параметр, после которого следует разделитель,
	'и возвращает значения параметра, стоящее после разделителя
	' (в данном случае идёт речь не о разделителе параметров (запятой, в данном случае),
	' а о символе, отделяющей имя параметра от его значения (знаке "равно", в данном случае) - примеч. перев.)

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 

'********************************************************************** 
'Конец файла скрипта "ReadScriptParametersFromLogFile":
'**********************************************************************