Print current syntax with file path, date, time and page numbers.sbs

 

Download as .sbs Shows as plain text

 

  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
'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
Related pages

...

Navigate from here