'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