'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 '************************************************************ 'Конец секции функций разбора переданных параметров '************************************************************