' Исправленная версия Export_to_Excel_(BIFF).SBS ' Размещено в SPSSX-L, 15.01.2002, автор: K.Asselberghs ' Добавлен ExcelMacro (форматирует вставленные таблицы), автор: Raynald Levesque, 19.05.2002 ' Макрос модифицирован 10.10.2002 так, чтобы номер таблиц и графиков можно было автоматически увеличивать на заданную константу. ' Затем, 15.01.2003 добавлен ещё один макрос для форматирования и вставки графиков, в т.ч. интеркативных. Автор: Ray. ' Экспортирует Сводные таблицы из SPSS на один и тот же лист рабочей книги Excel. ' Таблицы разделяются пустыми строками. ' * Чтобы экспортировать и другие объекты, поправьте процедуру ExportItems(). ' * ПРИМЕЧАНИЕ ' Перед запуском скрипта, запустите Excel и выделите ячейку, с которой должна начаться вставка импортируемых таблиц. '*****************************************************************************. 'ОПИСАНИЕ 'Этот скрипт экспортирует Сводные таблицы SPSS в Excel, используя BIFF (Binary Interchange File Format - двоичный формат файла для обмена). 'Конец ОПИСАНИЯ ' '****************************************************** 'При необходимости отредактируйте макрос Excel (см. ниже), который 'переформатирует таблицу после вставки в Excel '****************************************************** Dim nrows As Integer Dim tablenb As Integer 'номер таблицы, использующийся для именования диапазонов в Excel Dim chartnb As Integer Dim strTableNb As String 'константа, которая должна добавляться к номеру таблицы Const xlMoveAndSize As Integer =1 Sub ExcelMacro() ' Этот макрос добавляет номера к названию каждой таблицы, ' выделяет название жирным шрифтом и голубым цветом, ' определяет группы строк так, чтобы сами таблицы можно было легко скрывать и отображать ' только их заголовки (это упрощает поиск таблиц). ' Номер таблицы упрощает задание ссылок на таблицы при компоновке отчёта в Word. ' Автор: Raynald Levesque, 19.05.2002 Dim line1 As Long Dim line2 As Long Dim col1 As Integer Dim col2 As Integer On Error GoTo ErrExcelMacro With objExcelApp If tablenb=0 Then tablenb = CInt(strTableNb) + tablenb +1 Else tablenb = tablenb +1 End If line1 = .Selection.Row line2 = .Selection.Rows(.Selection.Rows.Count).Row col1 = 1 '.Selection.Column col2 = 10 '.Selection.Columns(.Selection.Columns.Count).Column ' Добавляем номер таблицы и выделяем заголовок жирным и голубым шрифтом .Cells(line1, col1)= "Таблица " & Str(tablenb) & ". " & .Cells(line1, col1) .cells(line1,col1).font.bold=True .cells(line1,col1).Font.ColorIndex = 5 .ActiveWorkbook.Names.Add Name:="Table" & LTrim(Str(tablenb)), RefersTo:=.Selection 'Выделяем строки таблицы (за исключением заголовка) и группируем их .Range(.Cells(line1 + 1, col1), .Cells(line2 + 2, col2)).Select .Selection.Rows.Group End With Exit Sub ErrExcelMacro: Debug.Print Err.Number & Err.Description MsgBox Err.Number & Err.Description Exit Sub End Sub Sub ExcelMacroCharts(strLabel As String ) ' Этот макрос добавляет номер к каждому графику и выделяет ' заголовок графика жирным и голубым шрифтом. ' Кроме того, он группирует строки, чтобы можно было скрыть график и просмотривать только заголовки ' (упрощает поиск нужных графиков в длинных файлах). ' Номера графиков упрощают ссылки на них при подготовке отчётов в Word. ' Автор: Raynald Levesque, 27.02.2003 Dim line1 As Long Dim line2 As Long Dim col1 As Integer Dim col2 As Integer Dim HauteurLigne As Double Dim HauteurGraph As Double Dim NbLigne As Integer On Error GoTo ErrExcelMacro With objExcelApp HauteurLigne = .Rows(1).RowHeight HauteurGraph = .Selection.ShapeRange.Height NbLigne = Int(HauteurGraph / HauteurLigne) + 1 line1 = .ActiveCell.Row line2 = line1 + NbLigne - 1 .Range(.Cells(line1-1, 1), .Cells(line2, 1)).EntireRow.Select If chartnb=0 Then chartnb = CInt(strTableNb) + chartnb +1 Else chartnb = chartnb +1 End If col1 = .Selection.Column col2 = .Selection.Columns(.Selection.Columns.Count).Column ' Добавим номер графика, выделим его заголовок жирным и голубым шрифтом .ActiveWorkbook.Names.Add Name:="Chart" & LTrim(Str(tablenb)), RefersTo:=.Selection .Cells(line1-1, col1)= "Рисунок " & Str(chartnb) & ". " & strLabel .cells(line1-1,col1).font.bold=True .cells(line1-1,col1).Font.ColorIndex = 5 'Выделим строки графика (за исключением заголовка) и сгруппируем их .Range(.Cells(line1, col1), .Cells(line2 + 2, col2)).Select .Selection.Rows.Group .Range(.Cells(line2 + 3, 1), .Cells(line2+3, 1)).Select End With Exit Sub ErrExcelMacro: Debug.Print Err.Number & Err.Description MsgBox Err.Number & Err.Description Exit Sub End Sub ' '****************************************************** 'ДАЛЕЕ НИКАКИХ ИЗМЕНЕНИЙ НЕ ТРЕБУЕТСЯ '****************************************************** 'используется как заголовок в диалоговых окнах Const SCRIPT_NAME As String = "Экспорт в рабочую книгу Excel" 'используются для подавления предупреждений и возврата прежних установок для предотвращения нежелательных диалоговых окон Const ALERTS_PRESERVE As Boolean = False Const ALERTS_RESTORE As Boolean = True Option Explicit 'Вызов функции Windows API, даёт больший контроль, чем функция Wait из Sax Basic Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'глобальные переменные, используются большинством процедур Dim objExcelApp As Object Dim objOutput As ISpssOutputDoc 'для уведомления пользователя о невозможности вставки объекта... 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) 'Отменяем экспорт, если в окне результатов пусто. If objSpssApp.Documents.OutputDocCount > 0 Then Set objOutput = objSpssApp.GetDesignatedOutputDoc Else 'процедура ErrorBox передаёт свои аргументы для отображения в MsgBox, но перед этим проверяет процедуру Alerts. ErrorBox "В SPSS отсутствуют результаты для экспорта. " & vbCrLf & _ "Пожалуйста, выполните анализ и запустите скрипт снова.", vbExclamation, SCRIPT_NAME 'Всегда восстанавливаем установки перед выходом! Alerts(ALERTS_RESTORE) End End If 'Получим имя файла, в котором будут сохранены результаты. 'С 8-й версии SPSS скрипт может вызываться из синтаксиса, которой передаст ему имя файла в качестве параметра. 'Если нет, запросим имя файла у пользователя. '@strFileName = GetFileName() 'Следующее условие может быть опущено, 'тогда результаты могут быть экспортированы, но без сохранения файла. '@ If strFileName = "" Then '@ 'Пользователь отменил выбор, либо указанный в синтаксисе при вызове файл не может быть перезаписан. '@ 'Всегда восстанавливаем установки перед выходом! '@ Alerts(ALERTS_RESTORE) '@ End '@ End If 'Запустим Excel и сохраним ссылку на это приложение в глобальной переменной objExcelApp. CreateExcel strTableNb = InputBox$("Введите константу, которая будет добавляться к номерам таблиц (например, 1000):", _ "Введите константу","0") 'Вот, наконец-то, место, где мы начинаем что-то делать по сути! ExportItems 'Сохраняем файл. Следовало бы сделать это в виде подпрограммы, если бы это не ограничивалось одной строкой кода. '@ objExcelApp.ActiveWorkbook.SaveAs FileName:=strFileName 'Скажем пользователю, были ли объекты, которые не удалось скопировать If s_intErrorCount > 0 Then '... но только если предупреждения не отключены ErrorBox "Некоторые объекты могли не вполне корректно скопироваться и вставиться в Excel." & vbCrLf & _ "Проверьте выдачу SPSS и полученный документ Excel.", vbExclamation, SCRIPT_NAME End If MsgBox "Готово!" 'В последний раз: 'Всегда восстанавливаем установки перед выходом! Alerts(ALERTS_RESTORE) End Sub 'Ищет объекты, подходящие для экспорта в Excel. Вставляет их в Excel и запускает форматирующий макрос. Sub ExportItems() Dim objItems As ISpssItems Dim objItem As ISpssItem Dim i As Long Dim intFootnotes As Integer On Error Resume Next '@ objExcelApp.Workbooks.Add Set objItems = objOutput.Items For i = 0 To objItems.Count - 1 Set objItem = objItems.GetItem(i) Debug.Print "Объект: " & i & ", тип: " & objItem.SPSSType & _ ", видимый: " & objItem.Visible 'С ОДНОЙ ИЗ СЛЕДУЮЩИХ ДВУХ СТРОК СЛЕДУЕТ СНЯТЬ КОММЕНТАРИЙ 'If objItem.Visible And objItem.Selected Then 'копируем только выделенные объекты If objItem.Visible Then 'копируем всё видимое содержимое 'ВЫБИРАЕМ, ЧТО И КАК ДОЛЖНО БЫТЬ ЭКСПОРТИРОВАНО В EXCEL Select Case objItem.SPSSType Case SPSSPivot ', SPSSWarning ', SPSSNote 'пропустим Notes, если закомментировано 'PasteIntoExcel objItem, "Picture (Enhanced Metafile)" 'закомментируйте остаток этого варианта (Case), если вставляете объект как картинку PasteIntoExcel objItem, "Biff",False 'применяем макрос Excel для форматирования таблицы nrows = objExcelApp.Selection.Areas(1).Rows.Count + 1 'KA Call ExcelMacro objExcelApp.ActiveCell.Offset(nrows, 0).Activate 'K.A. (эта строка помещена сюда мной - R.L.) 'Case SPSSLog, SPSSText, SPSSTitle 'PasteIntoExcel objItem, "Text" Case SPSSChart, SPSSIGraph objExcelApp.ActiveCell.Offset(1, 0).Activate '(добавлено мной - А.Б.) PasteIntoExcel objItem, "Рисунок", True ' возможны ошибки, если формат вставки в вашей версии Excel ' называется по-другому. Внесите исправления сюда. - А.Б. objExcelApp.Selection.Placement = xlMoveAndSize Call ExcelMacroCharts(objItem.Label) Case Else 'ничего не делаем End Select End If Next Err.Clear End Sub 'Непосредственно контролирует процесс копирования и вставки. 'Используем технику отката и повторных попыток для борьбы со скрытыми ошибками буфера обмена. Sub PasteIntoExcel (objItem As ISpssItem, strFormat As String, bolSkip2Lines As Boolean) Static intSheet As Integer On Error Resume Next Dim lngSleep As Long Dim nrows As Integer lngSleep = 100 '1/10-я секунды Clipboard "" '.Clear (очистим буфер обмена) objOutput.ClearSelection objItem.Selected = True 'Копируем объект. Следующий за этим цикл - только если возникли проблемы. Do Sleep lngSleep objOutput.Copy If Err Then 'буфер обмена может быть недоступен в этот момент для вставки результата метода copy 'попробуем подождать и попытатемся снова lngSleep = 2 * lngSleep End If Loop Until (Err = 0) Or (lngSleep > 2000) If Err Then 'что-то не так с копированием. Попробуем сказать об этом пользователю Clipboard ">>> Объект не может быть скопирован: Ошилка # " & Err & vbCrLf & Err.Description strFormat = "Text" s_intErrorCount = s_intErrorCount + 1 Err.Clear End If '@ intSheet = intSheet + 1 '@ If intSheet > objExcelApp.Sheets.Count Then '@ objExcelApp.Sheets.Add '@ Else '@ objExcelApp.Sheets("Blad" & Trim$(CStr$(intSheet))).Select '@ End If lngSleep = 100 Do Sleep lngSleep objExcelApp.ActiveSheet.PasteSpecial Format:=strFormat, Link:=False, DisplayAsIcon:= False nrows = objExcelApp.Selection.Areas(1).Rows.Count + 1 'KA 'MsgBox CStr(nrows) If Err And strFormat="Рисунок" Then Err.Clear '- (добавлено мной - А.Б. Даже при корректном указании формата вставки) 'с SPSS 13, Office 2002 и Windows XP Prof. картинка вставляется, 'но генерируется ошибка. Чтобы не вставлять её несколько раз, 'просто "притворяемся", что ошибки не было. If Err Then Debug.Print "Paste Error: " & Err; Err.Description 'буфер обмена в этот момент может быть недоступен для вставки 'попробуем подождать и попытаемся снова lngSleep = 2 * lngSleep End If Loop Until (Err=0) Or (lngSleep > 2000) If Err Then s_intErrorCount = s_intErrorCount + 1 Err.Clear End If 'objExcelApp.ActiveCell.Offset(nrows, 0).Activate 'K.A. (строка перемещена в процедуру ExportItems - R.L.) 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 'если документ открыт в Excel, попробуем закрыть его и снова попытаемся стереть CloseOpenDocument strFileName Kill strFileName If Err Then 'если ничего не помогает, откажемся от экспорта Err.Clear strFileName = "" End If End If GetFileName = strFileName Exit Function End If 'Если в параметрах скрипта пусто, запросим имя файла у пользователя Do 'получим путь и имя файла, куда будут сохранены результаты экспорта '3=означает подтверждение перезаписи существующего файла strFileName = GetFilePath$("Output.xls","xls",,SCRIPT_NAME, 3) If strFileName = "" Then 'пользователь отменил операцию Exit Function End If 'пробуем стереть файл, т.к. пользователь дал "добро" If Dir$(strFileName) <> "" Then Kill strFileName End If 'но иногда его нельзя стереть, если файл открыт If Err = 10101 Then ErrorBox "Файл """ & strFileName & _ """ в настоящий момент открыт в Excel и не может быть перезаписан. " & _ vbCrLf & vbCrLf & _ "Пожалуйста, укажите другой файл, " & _ "либо закройте этот и попробуйте ещё раз.", vbExclamation, _ SCRIPT_NAME Err.Clear strFileName = "" ElseIf Err Then 'не ясно, как обрабатывать другие возможные ошибки Err.Clear Exit Function End If Loop Until strFileName <> "" GetFileName = strFileName End Function Sub CloseOpenDocument(strFileName As String) On Error Resume Next CreateExcel objExcelApp.Workbooks(GetName(strFileName)).Activate objExcelApp.ActiveWorkbook.Close Err.Clear End Sub 'возвращает ссылку на приложение Excel в глобальную переменную objExcelApp. Sub CreateExcel() On Error Resume Next 'GetObject возвращает ссылку на запущенное приложение. Set objExcelApp = GetObject(,"Excel.Application") '@ If Err = 10096 Then Debug.Print "Excel не запущен, используем CreateObject" 'CreateObject запускает Excel, если тот к настоящему моменту не был запущен. '@ If objExcelApp Is Nothing Then '@ Set objExcelApp = CreateObject("Excel.Application") '@ End If 'в случае, если надо диагностировать и другие ошибки Debug.Print Err; Err.Description Err.Clear If objExcelApp Is Nothing Then ErrorBox "Перед запуском скрипта откройте рабочую книгу Excel " & vbCrLf & _ "и выделите ячейку, с которой желаете начать вставку результатов из SPSS.", vbExclamation, SCRIPT_NAME 'Всегда восстанавливаем установки перед выходом! Alerts(ALERTS_RESTORE) End End If objExcelApp.Visible = True If objExcelApp.ActiveWorkbook Is Nothing Then ErrorBox "Не найтено открытых рабочих книг в Excel." & vbCrLf & _ "Перед запуском скрипта откройте рабочую книгу Excel," & vbCrLf & _ "и выделите ячейку, с которой желаете начать вставку результатов из SPSS.", vbExclamation, SCRIPT_NAME 'Всегда восстанавливаем установки перед выходом! Alerts(ALERTS_RESTORE) End End If 'objExcelApp.Workbooks.Add 'objExcelApp.ActivateMicrosoftApp 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: проверяет, разрешено ли выдавать сообщения Function ErrorBox(strAlertMessage As String, intType As Integer, strTitle As String) On Error Resume Next Debug.Print strAlertMessage If Alerts(ALERTS_PRESERVE) Then ErrorBox = MsgBox(strAlertMessage, intType, strTitle) Else 'Сообщения запрещены. ErrorBox = 0 End If End Function