Вставка текстового блока в редактор выдачи SPSS Viewer

'Begin Description
'Вставка текстового объекта (текстового блока) в окно результатов SPSS через
'метод SendKeys (эмуляция нажатия клавиш), вызовом меню Insert>Text.
'End Description

' Проверено: SPSS 15.0.0. В английской версии. Скрипт должен запускаться при включенной английской
' раскладке; пока скрипт работает - мышью не двигать (можно потерять фокус окна) - специфика работы SendKeys - примеч. перев.
Sub Main
	Dim objOutput As ISpssOutputDoc

	If objSpssApp.Documents.OutputDocCount = 0 Then 
		objSpssApp.NewOutputDoc
	End If
	
	Set objOutput = objSpssApp.GetDesignatedOutputDoc
	
	'******************************************
	'демонстрация работы процедур InsertText и SetCurrentItem
	
	Call SetCurrentItem (objOutput, objOutput.Items.Count - 1)
	InsertText objOutput, "Это первый вновь вставленный блок текста."
	
	Call SetCurrentItem (objOutput, objOutput.Items.Count - 1)
	InsertText objOutput, "Это второй вновь вставленный блок текста."
	
	Call SetCurrentItem (objOutput, 1)
	InsertText objOutput, "Это третий блок, вставленный после блока № 1."
	
	'Заметьте, что вызов процедуры SetCurrentItem с недопустимым аргументом приведёт к тому, что текущим будет объявлен последний (или первый) объект.
	Call SetCurrentItem (objOutput, objOutput.Items.Count + 1)
	InsertText objOutput, "Текстовый блок будет вставлен в конец документа " & vbCrLf _
		& "из-за ошибочного аргумента.  " & vbCrLf _
		& "Заметьте, что текстовый блок с несколькими строками может не  " & vbCrLf _
		& "отображаться полностью, пока не будет отмасштабирован. "
		
	Dim i As Long

	'если текстовый блок включает более одной строки, может потребоваться масштабирование.
	i = GetCurrentItem(objOutput)
	If i >= 0 Then
		With objOutput.Items.GetItem(i)
			'если это не текстовый объект, то этот не тот объект, что мы только что вставили (см. код выше)...
			If .SPSSType = SPSSText Then
				'умножим исходную высоту блока на число строк
				.Height = 4 * .Height	'можно использовать константу, разумеется
			End If
		End With
	End If
End Sub


'Добавляет новый текстовый блок после текущего (выделенного) объекта выдачи
'Требует: наличия процедуры SetCurrentItem и функции GetCurrentItem
Sub InsertText(objOutput As ISpssOutputDoc, strText As String)
	
	'******************************************
	'Используйте SetCurrentItem для позиционирования вставляемого блока текста.
	'Эта процедура делает нужный объект текущим.
	'InsertText вставляет текст после текущего объекта.
	'Чтобы гарантированно делать текущим последний объект в выдаче, снимите комментарий со следующей строки:
	'Call SetCurrentItem (objOutput, objOutput.Items.Count - 1)
	
	'******************************************
	'Добавление нового текстового блока
	
	'Установка видимости окна результатов приводит также к тому, что окно выходит на передний план
	' (получает фокус), так что передаваемые SendKeys клавиши будут "нажиматься" в нужном окне.
	objOutput.Visible = True

	'Отсылка клавиш для использования меню Insert>Text
	SendKeys "%IX"	'в версии 7.5.2 используйте use "%IX~"
	
	'******************************************
	'Добавление текста в созданный блок
	
	'Вставленный объект получит статус текущего... если немного подождать.
	Wait 1	'Дадим программе одну секунду, прежде, чем обращаться к текущему объекту
	i = GetCurrentItem(objOutput)
	If i >= 0 Then
		Set objItem = objOutput.Items.GetItem(i)
		If objItem.SPSSType = SPSSText Then
			Set objText = objItem.ActivateText
			'Если в блоке уже есть текст, значит, мы обратились не к тому объекту: проверим.
			If objText.Text = "" Then
				objText.Text = strText
			End If
			objItem.Deactivate
		End If
	End If
End Sub


'парная процедура для GetCurrentItem
Sub SetCurrentItem(objOutput As ISpssOutputDoc, ByVal lngItem As Long)
	
	On Error Resume Next
	'игнорируем ошибки
	
	Dim objItems As ISpssItems
	Dim lngCount As Long
	Dim i As Long

	Set objItems = objOutput.Items
	lngCount = objItems.Count
	
	'В случае проблем с переданным аргументом, приводим его к допустимому значению:
	'устанавливаем указатель на первый или последний объект. Эту часть процедуры можно
	'модифицировать, если в случае ошибки требуется какое-то другое поведение скрипта.
	i = lngItem
	If (i >= lngCount) Then i = lngCount - 1
	If (i < 0) Then i = 0
	
	objItems.GetItem(i).Current = True
	'Debug.Print "Номер объекта: " & lngItem
End Sub


'парная функция для SetCurrentItem
Function GetCurrentItem(objOutput As ISpssOutputDoc) As Long
	'функция возвращает номер текущего объекта
	'возвращается отрицательно число в случае, если объектов не найдено, либо возникла иная ошибка
	'процедура, вызывающая функцию, должна убедиться, что результат функции валидный (>= 0) перед дальнейшим
	'использованием результатов
	
	On Error GoTo ErrorHandler
	
	Dim objItems As ISpssItems
	Dim objItem As ISpssItem
	Dim i As Long
	
	Set objItems = objOutput.Items
	'высока вероятность, что текущий объект будет последним, поэтому поиск текущего начинаем с конца
	For i = objItems.Count - 1 To 0 Step -1
		If objItems.GetItem(i).Current Then
			GetCurrentItem = i
			Exit Function
		End If
	Next
	
ErrorHandler:	
	'не нашли объекты, или какая-то другая проблема возникла
	GetCurrentItem = -1
	
End Function