Печать текущего файла синтаксиса через MS Word

'BEGIN DESCRIPTION
' Скрипт сохраняет и выводит на печать текущий файл синтаксиса.
' Вместе с содержимым файла печатается путь и имя файла,
' дата и время, а также номер страницы. Для этого используется
' приложение MS Word.
' Если открытый файл имеет атрибут "только для чтения" (read only),
' возможна распечатка сохранённой копии файла.
' Автор: Raynald Levesque, август 2001
' Обновление (ноябрь, 2002): в конце работы скрипта Word закрывается лишь в том случае,
'   если он не был запущен к моменту запуска скрипта
' Советую назначить данному скрипту кнопку на панели инструментов окна редактора синтаксиса.
'END DESCRIPTION

'Тема: печать текущего файла синтаксиса с дополнениями: путь, дата, время, номера страниц.
'Ключевые слова: печать, синтаксис, путь, дата, время, файл, сохранение, Word, read only, только для чтения.
'Опубликован: август 2001/ноябрь 2002, перевод: 23.06.2008.
'Автор: Raynald Levesque; перевод: А. Балабанов.
'Размещение: http://www.spsstools.ru/Scripts/Printing/PrintCurrrentSyntaxWithPathDatePageNumbers.txt (.sbs)
'Проверено: SPSS 15.0.0, MS Word 2003 (русская версия).


Public bolWordWasRunning As Boolean

Sub Main
' В данной процедуре скрипт получает путь к файлу синтаксиса и сохраняет файл, а затем
' вызывает PrintSyntax, которая управляет редактором Word для печати файла.
	Dim objSyntaxDoc As Object 'ISpssSyntaxDoc
	Dim strDocPath As String
	Dim strMsg As String, strTitle As String
	Dim intButtons As Integer

	On Error GoTo Oopps
	strDocPath = "none"
	bolWordWasRunning = True

	' Если на данный момент нет открытого файла синтаксиса, переход по метке Oopps запросит путь к нужному файлу
	Set objSyntaxDoc = objSpssApp.GetDesignatedSyntaxDoc 

	If strDocPath = "none" Then		
		strDocPath = objSyntaxDoc.GetDocumentPath
	End If
	If strDocPath = "" Then 	'Файл синтаксиса ещё не сохранялся. Запрос пути для сохранения.
		strDocPath = GetFilePath (,"sps",,"Выберите папку и укажите имя для файла синтаксиса", 2)
		If strDocPath = "" Then Exit Sub	'Пользователь отменил диалог
		objSyntaxDoc.SaveAs (strDocPath)
	End If
	
	' Сохранение текущей версии синтаксиса
	If GetAttr(strDocPath) Mod 2 > 0 Then 'Файл помечен атрибутом "только для чтения"
		Debug.Print "Файл с атрибутом Read only"
		strMsg = "Данный файл синтаксиса только для чтения!" & vbCr & "Желаете распечатать сохранённую версию?"
		intButtons = vbYesNo + vbExclamation
		strTitle = "Файл только для чтения"
		If MsgBox (strMsg, intButtons, strTitle) = vbNo Then Exit Sub
	Else
		objSyntaxDoc.SaveAs (strDocPath)
	End If
	Call PrintSyntax(strDocPath)
	Exit Sub
	
Oopps:
	Select Case Err.Number
		Case -2147467259	'Нет открытого файла синтаксиса. Запрос пути к файлу у пользователя
			Debug.Print "There were no syntax file opened"
			strDocPath = GetFilePath (,"sps",,"Выберите файл синтаксиса, который следует распечатать", 0)
			If strDocPath = "" Then Exit Sub	'Пользователь отменил выбор
			Set objSyntaxDoc = objSpssApp.OpenSyntaxDoc(strDocPath)
			Resume Next
		Case Else
			MsgBox Err & " " & Err.Description
			Debug.Print Err & " " & Err.Description
			Exit Sub
	End Select 
	
End Sub


' Определим некоторые константы
Const wdAlignPageNumberRight 	= 0
Const wdOpenFormatAuto 			= 0
Const wdSeekMainDocument 		= 0
Const wdSeekCurrentPageHeader 	= 9
Const wdSeekCurrentPageFooter 	= 10
Const wdFieldDate 				= 31
Const wdfieldPage 				= 33
Const wdFieldTime 				= 32
Const wdPrintView 				= 3
Const wdFieldNumPages 			= 26
Const wdAlignParagraphCenter	= 1
Const vbTab						=Chr(9)
Const wdDoNotSaveChanges		=0

Sub PrintSyntax(strDocPath As String)
Dim WordApp As Object
    On Error GoTo Oopps
    
    ' получим ссылку на приложение MS Word (если оно ещё открыто, переход по метке Oopps откроет его)
    Set WordApp=GetObject(,"Word.Application")
    With WordApp
	   ' Откроем в Word файл синтаксиса
		.Documents.Open FileName:=strDocPath, _
	        ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
	        PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
	        WritePasswordDocument:="", WritePasswordTemplate:="", Format:= wdOpenFormatAuto, XMLTransform:="", Encoding:=1251

		.ActiveWindow.View.Type = wdPrintView   
	    .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

		' Добавим к верхнему колонтитулу путь и имя файла
		With .selection
		    .TypeText Text:= vbTab & strDocPath
		End With
	    .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter

		' Добавим к нижнему колонтитулу дату, время и номер страницы
		With .selection
		    .Fields.Add Range:=.Range, Type:=wdFieldDate
		    .TypeText Text:=" "
		    .Fields.Add Range:=.Range, Type:=wdFieldTime
		    .TypeText Text:=" " & vbTab
		    .Fields.Add Range:=.Range, Type:=wdfieldPage
		    .TypeText Text:=" из "
		    .Fields.Add Range:=.Range, Type:=wdFieldNumPages
		End With

	    .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
	    .ActiveDocument.PrintOut Background:= False
		' Закрываем документ без сохранения
		.ActiveDocument.Close SaveChanges:=False
	End With

	If bolWordWasRunning = False Then
    	WordApp.Quit SaveChanges:=wdDoNotSaveChanges
    End If
    Set WordApp = Nothing
    Exit Sub

    Oopps:
	Select Case Err    
		Case 10096	'Приложение Word не запущено. Используем функцию CreateObject
			Set WordApp = CreateObject("Word.Application")
'			WordApp.Visible = True
			Debug.Print "(Word ещё не был запущен)"
			bolWordWasRunning = False
			Resume Next
		Case Else
			Debug.Print "Ошибка " & Err & ": " & Err.Description
			Set WordApp = Nothing
			Exit Sub
	End Select
End Sub