1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
' Исправленная версия 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