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
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
'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