'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

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