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
'Перенос видимых результатов из SPSS в Word через HTML.

'Данный скрипт экспортирует все видимые объекты из окна назначения результатов в MS Word. С промежуточной
' конвертацией в HTML.

' ВНИМАНИЕ! Константа EMLINK (см. ниже) определяет, вставлять ли рисунки как ссылки (True), 
'  или интегрировать в документ как картинку (False - по умолчанию) - модиф. перев.

' При этом графики не встраиваются в Word, на них создаются ссылки.
' Значки (**) будут обозначать значимые корреляции. Так они видоизменяются при экспорте в Word.

'ТРЕБОВАНИЯ:
'Необходимо открытое окно результатов (видимое содержимое будет передано в Word через HTML).
'Тестировалось с английской версией SPSS 10.07 и редактором MS Word 2000;
'В принципе, должно работать и на локализованных вариантах этих версий;
'Обратите внимание, что временный файл формата HTML для транзита выдачи создаётся в папке "c:\\temp\\".

'Сохраните этот файл как ExportVisibleOutputToWordViaHTML.SBS

'Автор:: rlevesque@videotron.ca, 14.07.2001
'http://www.spsstools.ru

' Перевод: А. Балабанов, 09.11.2008
' Проверено: SPSS 13.0, MS Word 2003.

Option Explicit
Const EMLINK As Boolean = False
Sub Main
    Dim intType As Integer
    Dim objOutputDoc As ISpssOutputDoc
    Dim objItems As ISpssItems
    Dim objItem As ISpssItem
	Dim strFile As String
	On Error GoTo ErrorHand
	Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc   

	' Это - путь ко временному файлу, который будет содержать выдачу в формате HTML
	strFile = "c:\\temp\\ExportToWord.htm"
	Kill strFile 	'Удалим файл, если он уже существует

	objOutputDoc.Visible = True

    ' Экспорт всех нескрытых объектов из окна результатов SPSS в файл HTML
    objOutputDoc.ExportDocument (SpssVisible, strFile, SpssFormatHtml, True)

	' Следующая процедура импортирует файл HTML в Word
    Call ImportHTMLToWord (strFile)                                        
	Kill strFile
	Exit Sub
	
	ErrorHand:
	Select Case Err
		Case 10101 'Невозможно удалить временный файл HTML
			Resume Next
		Case Else
			Debug.Print Err & " " & Err.Description
			MsgBox "Произошла ошибка."
	End Select
End Sub


'********************************
Sub ImportHTMLToWord (strFile As String)
'импорт файла HTML в документ Word

Dim WordApp As Object
    On Error GoTo Oopps
    
    'получим доступ к приложению Word (если оно ещё не запущено, инструкции после метки "Oopps" запустят его)
    Set WordApp=GetObject(,"Word.Application")
    
    With WordApp	
		If .Documents.Count = 0 Then	' если в Word нет открытых документов, придётся добавить новый документ
			.Documents.Add DocumentType:=0   '0=константа wdNewBlankDocument
		End If
		' Импорт файла HTML в Word
		.Selection.InsertFile FileName:=strFile, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
		If Not EMLINK Then Call WordMacro(WordApp)
	End With
    
    Set WordApp = Nothing
    Exit Sub

    Oopps:
	Select Case Err    
		Case 10096	'Приложение Word не запущено, следовательно, вместо GetObject надо использовать CreateObject
			Set WordApp = CreateObject("Word.Application")
			WordApp.Visible = True
			Debug.Print "error " & Err & ": " & Err.Description & "(Word не был запущен)"
			Resume Next
		Case Else
			Debug.Print "error " & Err & ": " & Err.Description
			Set WordApp = Nothing
			Exit Sub
	End Select
 End Sub
 Sub WordMacro(WordApp As Object)
' В случае, если экспортированный график вставился как ссылка, данный макрос интегрирует его
' в документ Word, помещая как картинку над текстом. Иначе - просто помещает картинку "перед текстом"
Const wdPasteMetafilePicture=3
Const wdFloatOverText=1
Dim idx As Integer

On Error GoTo ErrorHand
	For idx = WordApp.ActiveDocument.InlineShapes.Count -1 To 0 Step -1
		WordApp.ActiveDocument.InlineShapes(idx).Select
		WordApp.Selection.Copy
		WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
	        	Placement:=wdFloatOverText, DisplayAsIcon:=False
	Next idx

ErrorHand:
	Debug.Print Err.Description
	Exit Sub
End Sub