'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