'BEGIN DESCRIPTION ' This script saves then prints the currently Designated Syntax file. ' The file name, path ,date, timestamp and page numbers are printed ' If the file has never been saved, the user is prompted for the file name and path ' If file is read only, saved file is printed. ' Has been tested with Word 2000 (English version) ' Raynald Levesque August 2001 ' Improvement Nov 2002: at end of the script, word is closed only if it was not ' running when the script started ' Visit my SPSS web site http://pages.infinit.net/rlevesqu/ 'END DESCRIPTION Public bolWordWasRunning As Boolean Sub Main ' This saves then prints the currently Designated Syntax file along ' with the file name, path ,date, time and page numbers. ' If file is read only, saved file is printed. ' Assign this script to a custom button in your Syntax window toolbar Dim objSyntaxDoc As ISpssSyntaxDoc Dim strDocPath As String Dim strMsg As String, strTitle As String Dim intButtons As Integer On Error GoTo Oopps strDocPath = "none" bolWordWasRunning = True ' If there are no open syntax file, Oopps will request the full path of the file Set objSyntaxDoc = objSpssApp.GetDesignatedSyntaxDoc If strDocPath = "none" Then strDocPath = objSyntaxDoc.GetDocumentPath End If If strDocPath = "" Then 'Syntax has never been saved, ask for path strDocPath = GetFilePath (,"sps",,"Select folder and enter name for the syntax file", 2) If strDocPath = "" Then Exit Sub 'User Cancelled the dialog box End If ' Save the current version of the syntax file objSyntaxDoc.SaveAs (strDocPath) 'If read only, ask if should print saved copy Call PrintSyntax(strDocPath) Exit Sub Oopps: Select Case Err.Number Case -2147467259 'There are no open syntax file, get path from user Debug.Print "There were no syntax file opened" strDocPath = GetFilePath (,"sps",,"Select the syntax file to be printed", 0) If strDocPath = "" Then Exit Sub 'User cancelled Dialog box Resume Next Case -2147418113 'File is read only Debug.Print "File is read only" strMsg = "The syntax file is read only!" & vbCr & "Do you want to print the saved copy?" intButtons = vbYesNo + vbExclamation strTitle = "File Is Read only!" If MsgBox (strMsg, intButtons, strTitle) = vbNo Then Exit Sub Resume Next Case Else MsgBox Err & " " & Err.Description Debug.Print Err & " " & Err.Description Exit Sub End Select End Sub ' Define some word constants 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 'get access to Word application (if it does not exist, Oopps will create it) Set WordApp=GetObject(,"Word.Application") With WordApp ' Load syntax file in word .Documents.Open FileName:=strDocPath, _ ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _ PasswordDocument:="", PasswordTemplate:="", Revert:=False, _ WritePasswordDocument:="", WritePasswordTemplate:="", Format:= wdOpenFormatAuto .ActiveWindow.View.Type = wdPrintView .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader ' Add path and file name to header With .selection .TypeText Text:= vbTab & strDocPath End With .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter ' Add date, time and page number to footer 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:=" of " .Fields.Add Range:=.Range, Type:=wdFieldNumPages End With .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument .ActiveDocument.PrintOut Background:= False ' Close document without saving changes .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 is not running: use CreateObject Set WordApp = CreateObject("Word.Application") ' WordApp.Visible = True Debug.Print "(Word was not already running)" bolWordWasRunning = False Resume Next Case Else Debug.Print "error " & Err & ": " & Err.Description Set WordApp = Nothing Exit Sub End Select End Sub