Экспорт сводных таблиц в Word

'Begin Description
'Экспорт таблиц выдачи SPSS в Word с форматированием RTF.
'Скрипт экспортирует таблицы SPSS 8.0 в редактор MS Word 97 как таблицы с RTF-форматированием.
'Если экспорт будет осуществляться в редактор Word 95 (т.е. Word 6 или 7), скрипт потребуется немного отредактировать.
'Более ранние версии Word, чем 97, будут закрываться сразу после окончания работы скрипта.
'См. комментарии, которые укажут на необходимые изменения.
'End Description

'Скрипт разработан корп. SPSS и модифицирован 1 марта 2001 г., автор модификации: John Hendrickx.
'Таблицы форматируются с параметрами абзаца "не разрывать", "не отрывать от следующего"
'для того, чтобы таблицы не разрывались посередине. Кегль таблиц устанавливается равным 10 пт.
'Подробнее об изменениях см. процедуру ConvertToTextAndBackAgain.
'John Hendrickx, Nijmegen Business School, University of Nijmegen, Netherlands
'J.Hendrickx@bw.kun.nl

' Перевод: А. Балабанов, 09.11.2008.
' Проверено: SPSS 15.0, MS Word 2007.

'******************************************************
'ЧТОБЫ ПРЕДОТВРАТИТЬ ЗАКРЫТИЕ WORD 95 ПОСЛЕ ОКОНЧАНИЯ РАБОТЫ СКРИПТА,
'см. комментарии, выделенные таким способом
'******************************************************
'
'Возможно, вам потребуется:
'---исправить значение константы WORD_VERSION (версия MS Word)
'Если (старый) Word проинсталлирован в папку не по умолчанию,
'---отредактировать путь к папке Word
'
'******************************************************
'одна из следующих двух строк должна быть закомментирована
Const WORD_VERSION As Integer = 97
'Const WORD_VERSION As Integer = 95	'или 6, или 7
'******************************************************
'измените значение константы, чтобы получить другой формат таблиц
Const WORD_TABLE_FORMAT = 0
'******************************************************
'
'проигнорировать, если WORD_VERSION = 97
'******************************************************
'Если WORD_VERSION < 97 и Word проинсталлирован в нестандартную папку,
'отредактируйте следующую константу соответственно
Const WORD_PATH As String = "C:\\MSOFFICE\\WINWORD\\WINWORD.EXE"
'******************************************************
'
'******************************************************
'Для адаптации скрипта к WORD 95 более никаких изменений не требуется
'******************************************************
'
'
'******************************************************
'При желании можете отредактировать процедуру WordMacro (см. ниже), которая
'форматирует таблицу после вставки её в Word
'******************************************************
Sub WordMacro(intFootnotes As Integer)
	On Error Resume Next

	If WORD_VERSION < 97 Then
		FindWordTable95 intFootnotes
	Else	'Если WORD_VERSION = 97, тогда
		FindWordTable97 intFootnotes
		'Следующая процедура работает и необходима только под Word 97
		ConvertToTextAndBackAgain
	End If

	With objWordApp
		'"паркуем" курсор в конец документа.
		'.LineDown 2 + intFootnotes
		.EndOfDocument
	End With

	Debug.Print Err; Err.Description
	Err.Clear
	'+++
End Sub


Sub FindWordTable95(intFootnotes As Integer)
	On Error Resume Next
	Dim i As Integer

	With objWordApp
		.LineUp intFootnotes
		For i = 0 To intFootnotes + 4	'полагаем, заголовок занимает максимум 4 строки
			.LineUp 'Count:=1
			.TableAutoFormat Format:=WORD_TABLE_FORMAT, Autofit:=True
			Debug.Print Err; Err.Description
			If Err = 0 Then
				'Найдена таблица!
				Exit For
			Else
				Err.Clear
			End If
		Next
	End With
End Sub


Sub FindWordTable97(intFootnotes As Integer)
	On Error Resume Next
	Dim i As Integer

	With objWord.Selection
		.MoveUp Count:=intFootnotes
		For i = 0 To intFootnotes + 4	'полагаем, заголовок занимает максимум 4 строки
			.MoveUp 'Count:=1
			.Tables(1).Select
			Debug.Print Err; Err.Description
			If Err = 0 Then
				'Найдена таблица!
				Exit For
			Else
				Err.Clear
			End If
		Next
	End With
End Sub

Sub ConvertToTextAndBackAgain()
	On Error Resume Next

    Dim lngNumRows As Long
    Dim lngNumColumns As Long

    With objWord.Selection.Tables(1)
        .Select
        lngNumRows = .Rows.Count
        lngNumColumns = .Columns.Count
    End With

    With objWord.Selection
    	.Rows.ConvertToText Separator:=1	':=wdSeparateByTabs (константа Word "разделитель - знак табуляции")
	    .ConvertToTable Separator:=1, NumColumns:=lngNumColumns, _
	        NumRows:=lngNumRows, Format:=WORD_TABLE_FORMAT, ApplyBorders:=True, _
	        ApplyShading:=True, ApplyFont:=False, ApplyColor:=True, _
	        ApplyHeadingRows:=True, ApplyLastRow:=False, ApplyFirstColumn:=True, _
	        ApplyLastColumn:=False, AutoFit:=True
    	.Tables(1).AutoFormat Format:=1, AutoFit:=True
    	'исправления внёс: John Hendrickx
    	.ParagraphFormat.KeepWithNext = True
    	.ParagraphFormat.KeepTogether = True
    	.Font.size = 10
    	.ParagraphFormat.Alignment = 2				'wdAlignParagraphRight (константа Word "выровнять абзац по правому краю")
	End With

	'выравнивание первого столбца по левому краю (в большинстве случаев так таблица лучше смотрится)
	objWord.Selection.Columns(1).Select
	objWord.Selection.ParagraphFormat.Alignment = 0			'wdAlignParagraphLeft (константа Word "выровнять абзац по левому краю")

	'выделяем абзац, который сразу над таблицей (её заголовок)
	'применяем свойства "не разрывать", "не отрывать от следующего", кегль 10 пт.
	'Unit:=5 -> wdLine (константа Word "единица перемещения - строка")
	objWord.Selection.MoveUp Unit:=5, Count:=1
	objWord.Selection.Paragraphs(1).Range.Select
	With objWord.Selection
    	.ParagraphFormat.KeepWithNext = True
    	.ParagraphFormat.KeepTogether = True
    	.Font.size = 10
	End With
	'Конец исправлений - John Hendrickx.

	If Err Then
		Debug.Print "ConvertToTextAndBackAgain: ошибка " & Err
		Debug.Print Err.Description
	End If
End Sub
'
'
'******************************************************
'см. выделенные комментарии ниже, чтобы настроить вставку таблиц как картинок
'(например, для SPSS 7.5) или для вставки только выделенных объектов выдачи
'******************************************************


'настройки для заголовков диалога
Const SCRIPT_NAME As String = "Экспорт в документ Word"
'настройки для подавления нежелательных диалоговых окон
Const ALERTS_PRESERVE As Boolean = False
Const ALERTS_RESTORE As Boolean = True

Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'объявление глобальных переменных, используемых большинством процедур
Dim objWordApp As Object
Dim objOutput As ISpssOutputDoc
'+++ добавлена для обхождения некоторой ошибки Word97, связанной с печатью +++
Dim objWord As Object
'+++

'потребуется для сообщения пользователю о невозможности вставки объектов...
Dim s_intErrorCount As Integer


Sub Main
    Dim strFileName As String

	On Error Resume Next

	'В SPSS 8.0 и выше можно вызвать данный скрипт из файла синтаксиса.
	'В этом случае мы хотели бы подавить возможные предупреждения, которые прервут
	'исполнение скрипта. Но в SPSS 7.5 такая попытка вызовет ошибку.
	'Поэтому вся обработка предупреждений вынесена в отдельную функцию
	'Alerts. Вызовем её для установки новых настроек. Перед окончанием
	'скрипта надо будет вызвать её ещё раз для восстановления старых настроек.
	Alerts(ALERTS_PRESERVE)

	'Останавливаем работу, если окно выдачи SPSS пусто.
	If objSpssApp.Documents.OutputDocCount > 0 Then
	    Set objOutput = objSpssApp.GetDesignatedOutputDoc
	Else
		'Функция MessageBox вызывает стандартный MsgBox, но перед этим проверяет настройки Alerts.
		MessageBox( "Окно выдачи SPSS пусто. " & vbCrLf & _
			"Выполните анализ и запустите снова.", vbExclamation, SCRIPT_NAME)
		'Восстанавливаем настройки педупреждений перед выходом!
	    Alerts(ALERTS_RESTORE)
		End
	End If

	'Запрос имени файла, в который будет сохранена экспортированная выдача.
	'В SPSS 8 скрипт может быть вызван из синтаксиса, и имя файла можно передать как параметр.
	'Иначе - запрашиваем имя через диалог у пользователя.
	strFileName = GetFileName()

	'Следующую проверку, в принципе, можно убрать.
	'И в таком случае выдача будет экспортирована, но не сохранена.
	If strFileName = "" Then
		'Пользователь отменил диалог, или имя файла указано при вызове из синтаксиса,
		'но целевой файл недоступен для записи.
		'Всегда восстанавливаем настройки перед выходом!
		Alerts(ALERTS_RESTORE)
		End
	End If

	'Запускаем Word и сохраняем ссылку на это приложение в глобальной переменной objWordApp.
	CreateWord

	'Здесь мы, наконец, что-то начинаем делать!
	ExportItems

    'Сохраняем файл. Следовало бы оформить это процедурой, если бы это не убиралось в одну строчку.
    objWordApp.FileSaveAs Name:=strFileName

    'Сообщаем пользователю, что имеются объекты, которые не удалось скопировать...
    If s_intErrorCount > 0 Then
    	'... но только в том случае, если сообщения разрешены.
    	MessageBox( "Некоторые объекты могли быть не скопированы и (или) не вставлены в Word." & vbCrLf & _
    		"Проверьте исходную выдачу SPSS и результирующий документ Word.", vbExclamation, SCRIPT_NAME)
    End If

	'И в последний раз:
	'- Всегда восстанавливаем настройки перед выходом!
    Alerts(ALERTS_RESTORE)
End Sub

' настройки параметров экспорта - примеч. перев.
Sub ExportItems
    Dim objItems As ISpssItems
    Dim objItem As ISpssItem
    Dim i As Long
	Dim intFootnotes As Integer

	On Error Resume Next
	objWordApp.FileNewDefault

    Set objItems = objOutput.Items
    For i = 0 To objItems.Count - 1
        Set objItem = objItems.GetItem(i)
        Debug.Print "Item " & i & " Type " & objItem.SPSSType & _
        	" Visible " & objItem.Visible
        '******************************************************
        'одна из двух следующих строк должна быть закомментирована
        'If objItem.Visible And objItem.Selected Then	'копировать только выделенные объекты
        If objItem.Visible Then							'копировать все видимые элементы выдачи
        '******************************************************
           	Select Case objItem.SPSSType
                Case SPSSPivot, SPSSWarning, SPSSNote
					'для макроса Word нам потребуется знать число примечаний к таблице
	                intFootnotes = objItem.ActivateTable.FootnotesArray.Count
        			'копирование не сработает, если элемент активирован!
        			objItem.Deactivate
        			'******************************************************
        			'снимите комментарий со следующей строки, если надо вставить объекты как картинки
        			'PasteIntoWord objItem, "Pict"
        			'******************************************************
	                'закомментируйте все остальное в этом Case, если надо вставить объекты как картинки
	                PasteIntoWord objItem, "RTF"
	                'применяем макрос Word для форматирования таблицы
	                WordMacro intFootnotes
	                '******************************************************
                Case SPSSLog, SPSSText, SPSSTitle
                	PasteIntoWord objItem, "RTF"
                Case SPSSChart, SPSSIGraph
                    PasteIntoWord objItem, "Pict"
                Case Else
                    'ничего не делаем
            End Select
        End If
    Next
End Sub


Sub PasteIntoWord (objItem As ISpssItem, strDataType As String)
	On Error Resume Next

	Dim lngSleep As Long
	lngSleep = 100	'1/10-я секунды

    Clipboard ""	'.Clear - очистка буфера обмена

    objOutput.ClearSelection
    objItem.Selected = True

    'Копируем объект в буфер обмена. Зацикливаемся только в случае проблем.
    Do
        objWordApp.EndOfDocument
   		Sleep lngSleep
		objOutput.Copy
		If Err Then
	 		'Буфер может быть ещё не готов к использованию, так что возникнет ошибка.
			'В этом случае пробуем подождать подольше перед следующей попыткой
			lngSleep = 2 * lngSleep
		End If
	Loop Until (Err = 0) Or (lngSleep > 2000)

	If Err Then	'какая-то ошибка с копированием. Попытаемся проинформировать пользователя
		Clipboard ">>> Элемент не может быть скопирован: ошибка №" & Err & vbCrLf & Err.Description
		s_intErrorCount = s_intErrorCount + 1
		Err.Clear
	End If

	lngSleep = 100
    Do
   		Sleep lngSleep
	    objWordApp.EditPasteSpecial DataType:=strDataType
		If Err Then
	 		'Буфер может быть ещё не готов к использованию, так что возникнет ошибка.
			'В этом случае пробуем подождать подольше перед следующей попыткой
			lngSleep = 2 * lngSleep
		End If
	Loop Until (Err=0) Or (lngSleep > 2000)

	If Err Then
		s_intErrorCount = s_intErrorCount + 1
		Err.Clear
	End If

	'вставляем пустую строку после каждого элемента
    Clipboard vbCrLf & " "

    objWordApp.EndOfDocument
    objWordApp.EditPasteSpecial DataType:="Text"
End Sub


Function GetFileName() As String
	Dim strFileName As String

	'Во-первых, проверим, был ли скрипт вызван из синтаксиса,
	'и было ли передано имя файла в качестве параметра.

	On Error Resume Next
	'следующая проверка вызовет ошибку в SPSS 7.5
	strFileName = objSpssApp.ScriptParameter(0)
	If Err Then
		Err.Clear
	End If

	If strFileName <> "" Then
	    'уничтожаем существующий файл с таким именем, т.к. пользователь попросил об этом
		If Dir$(strFileName) <> "" Then
	    	Kill strFileName
	    End If
    	'но стереть файл не получится, если он открыт
	    If Err = 10101 Then
	    	Err.Clear
	    	'тогда активируем и закрываем документ, пытаемся снова
	    	If WORD_VERSION < 97 Then
	    		'неизвестно, как поступать в этом случае, прекращаем попытки
	    		strFileName = ""
	    	Else
	    		'если документ открыт в Word, пытаемся его закрыть
	    		CloseOpenDocument strFileName
		    	Kill strFileName
		    	If Err Then
		    		MessageBox( "Ошибка " & Err & vbCrLf & Err.Description, vbExclamation, SCRIPT_NAME)
		    		'если не сработало, отменяем экспорт
			    	Err.Clear
			    	strFileName = ""
			    End If
			End If
	    End If
		GetFileName = strFileName
		Exit Function
	End If

	'Если параметр с именем файла не был передан, запрашиваем имя файла у пользователя
    Do
	    'получаем путь и имя файла, куда будет сохранён экспортируемый документ
	    '3=подтверждение перезаписи существующего файла
	    strFileName = GetFilePath$("Output.doc","doc",,SCRIPT_NAME, 3)
	    If strFileName = "" Then	'действие отменено пользователем
	    	Exit Function
	    End If
	    'уничтожаем существующий файл, т.к. пользователь дал добро
	    On Error Resume Next
		If Dir$(strFileName) <> "" Then
	    	Kill strFileName
	    End If
	    'удалить не получится, если документ открыт
	    If Err = 10101 Then
	    	MessageBox( "Файл """ & strFileName & _
	    		""" в данный момент открыт в Word и не может быть заменен. " & _
	    		vbCrLf & vbCrLf & _
	    		"Пожалуйста, выберите другое имя файла, " & _
	    		"или закройте выбранный файл и попытайтесь снова.", vbExclamation, _
	    		SCRIPT_NAME)
	    	strFileName = ""
	    ElseIf Err Then
	    	'на все прочие ошибки у нас нет заготовленных действий - просто выходим
	    	Exit Function
	    End If
	Loop Until strFileName <> ""

	GetFileName = strFileName
End Function


Sub CloseOpenDocument(strFileName As String)
	On Error Resume Next
	'+++ Следующие объявления вынесены в область глобальных переменных для обхождения некой проблемы печати Word 97 +++
	'Dim objWord As Object
	'Set objWord = GetObject(,"Word.Application")
	'+++
	Dim objDoc As Object
	Set objDoc = objWord.Documents(GetName(strFileName))
	objDoc.Close SaveChanges:=0	'wdDoNotSaveChanges (костанта Word "не сохранять изменения")
	Err.Clear
End Sub


Sub CreateWord
	On Error Resume Next

	'Окно Word 95 после экспорта исчезнет, если не сделать эту проверку
   	If WORD_VERSION < 97 Then
   		If vbNo = MessageBox ("Приложение Word уже запущено?", vbYesNo+vbQuestion, SCRIPT_NAME) Then
		   	Dim dblWordProgID As Double
		    dblWordProgID = Shell(WORD_PATH, vbNormalNoFocus)
		End If
	End If

	'Объект objWordApp в действительности не является приложением (дял Word 97), а является программой WordBasic.
	'Это сделано для совместимости со старыми версиями Word.
	'То, что мы делаем, эквивалентно следующим командам:
	'Set objWord = CreateObject("Word.Application")
	'Set objWordApp = objWord.WordBasic
	'Поскольку в большинстве случаев нам не требуется дополнительная функциональность,
	'присущая приложению, нам этого достаточно.

	'GetObject с ссылкой на приложение Word 97 не будет работать для Word 95
	Set objWordApp = GetObject(,"Word.basic")
	'Если Err = 10096 Then Debug.Print "Word не запущен, используйте CreateObject"
	If objWordApp Is Nothing Then
	    Set objWordApp = CreateObject("Word.basic")
	End If
	'в случае, если потребутся диагностировать другие ошибки
	Debug.Print Err; Err.Description
	Err.Clear

	If objWordApp Is Nothing Then
		MessageBox( "Невозможно запустить Word.  " & vbCrLf & _
			"Выполнение скрипта прекращено.", vbExclamation, SCRIPT_NAME)
		End
	End If

	'+++ Добавлно для обхождения некой проблмы печати Word97 +++
	If WORD_VERSION >= 97 Then
		Set objWord = GetObject(,"Word.Application")
	End If
	Debug.Print "ObjWord указывает на Nothing: " & ((objWord Is Nothing) = True)
	'+++

	'objWordApp.FileNewDefault
    'копирование/вставка не будут работать как ожидается, если приложение Word не отображется на экране
    objWordApp.AppShow

End Sub


'Удаляет имя диска и путь из строки с полным путем к файлу (оставляет только имя).
Function GetName(strFileName As String) As String
	Dim strName As String
	Dim intPos As Integer
	Dim intPos1 As Integer

	strName = strFileName

	'Удаляем имя диска и двоеточие, если есть.
	intPos = InStr(strName, ":")
	If intPos > 0 Then
		strName = Mid$(strName, intPos + 1)
	End If

	'Находим последний слэш: \\.
	Do
		intPos = intPos1
		intPos1 = InStr(intPos1 + 1, strName, "\\")
	Loop Until intPos1 = 0

	'Убираем всё до последнего слэша включительно.
	If intPos > 0 Then
		strName = Mid$(strName, intPos + 1)
	End If
	Debug.Print  strName

	'Расширение файла отбрасывать нет нужды...

	GetName = strName
End Function

'Обрабатывает свойство Alerts, которое вызывает ошибку в SPSS 7.5.
'Для инициализации надо вызвать функцию с параметром  False (или ALERTS_PRESERVE).
'Для восстановления надо вызвать функцию с параметром True (или ALERTS_RESTORE) перед завершением работы скрипта.
'Если скрипт вызван из синтаксиса, т.е. (ScriptParameter(0) <> ""),
'эта функция подавит выдачу предупреждений, которые, ожидая реакции пользователя, могут остановить выполнение экспорта.
Function Alerts(blnRestore As Boolean) As Boolean
	Static blnInitialized As Boolean
	Static blnAlerts As Boolean
	Static blnAlertsInitial As Boolean

	On Error Resume Next

	If Not blnInitialized Then
		blnInitialized = True

		blnAlertsInitial = objSpssApp.Alerts
		If Err Then	'если ошибка, значит, имеем дело с spss 7.5
			blnAlertsInitial = True
			Err.Clear
		End If

		blnAlerts = (objSpssApp.ScriptParameter(0) = "")
		If Err Then	''если ошибка, значит, имеем дело с spss 7.5
			blnAlerts = True
			Err.Clear
		End If
	End If

	If blnRestore Then
		objSpssApp.Alerts = blnAlertsInitial
		blnAlerts = blnAlertsInitial
		'blnInitialized = False
	End If

	Err.Clear
	Alerts = blnAlerts
End Function


'Вызов функции MsgBox с предварительной проверкой настроек предупреждений (Alerts), можно ли показать диалог.
'Возвращает результат функции MsgBox (указывающий, какая кнопка была нажата), либо 0, если Alerts = False.
Function MessageBox(strAlertMessage As String, intType As Integer, strTitle As String)
	On Error Resume Next
	Debug.Print strAlertMessage
	If Alerts(ALERTS_PRESERVE) Then
		MessageBox = MsgBox(strAlertMessage, intType, strTitle)
	Else
		'Можно вставить сюда функцию, записывающую событие в журнал.
		MessageBox = 0
	End If
End Function