Экспорт таблиц на лист MS Excel

' Исправленная версия Export_to_Excel_(BIFF).SBS
' Размещено в SPSSX-L, 15.01.2002, автор: K.Asselberghs

' Экспортирует Сводные таблицы из SPSS на один и тот же лист рабочей книги Excel.
' Таблицы разделяются пустыми строками.
' * Чтобы экспортировать и другие объекты, поправьте процедуру ExportItems().
' * ПРИМЕЧАНИЕ
'    Перед запуском скрипта, запустите Excel и выделите ячейку, с которой должна начаться вставка импортируемых таблиц.

'*****************************************************************************.

'ОПИСАНИЕ
'Этот скрипт экспортирует Сводные таблицы SPSS в Excel, используя BIFF (Binary Interchange File Format - двоичный формат файла для обмена).
'Конец ОПИСАНИЯ
'
'******************************************************
'При необходимости отредактируйте макрос Excel (см. ниже), который
'переформатирует таблицу после вставки в Excel
'******************************************************

Sub ExcelMacro()
  objExcelApp.Selection.AutoFormat Format:=&HFFFFEFC6, Number:=True, _
    Font:=True, Alignment:=True, Border:=True, Pattern:=True, Width:=True
    'Вы можете запросить в Excel выполнение этого макроса
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

    'Вот, наконец-то, место, где мы начинаем что-то делать по сути!
    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"
                    'применяем макрос Excel для форматирования таблицы
                    'ExcelMacro
               'Case SPSSLog, SPSSText, SPSSTitle
                    'PasteIntoExcel objItem, "Text"
                Case SPSSChart, SPSSIGraph
                     'PasteIntoExcel objItem, "Picture (Enhanced Metafile)"
                Case Else
                    'ничего не делаем
            End Select
        End If
    Next
    Err.Clear
End Sub


'Непосредственно контролирует процесс копирования и вставки.
'Используем технику отката и повторных попыток для борьбы со скрытыми ошибками буфера обмена.
Sub PasteIntoExcel (objItem As ISpssItem, strFormat As String)
    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 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  'KA

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