Printing mail (Outlook 2000)

Topic

New Reply

Hi

Does anyone know where Outlook stores the template it uses to format printed email messages? I’d like to print the subject in big letters on all printouts rather than my name (which I know).

Reply | Quote

Replies

I’m pretty sure you can’t get at that. To do this you’d need a little code to automate printing via Word or Excel. Word would probably be best for this.

Reply | Quote

What you can do without code is limited to the options you’ll find under (select a mail folder) Page Setup | Define Print Styles | select a Style | Edit | Header and Footer tab. You can at least remove Username from the Header, but you can’t add the Subject in native Outlook. You can also adjust Header and Footer Fonts and Font Size in that dialog.

Reply | Quote

As per John’s suggestion, you can also change the font for two different areas. Go to the same dialog which John specifies, in the Format tab. If you don’t want your name at the top to be as large, click on the Title… Font… button and change it to be smaller, without bolding? The Field… Font… applies to the header of the e-mail (To, From, Date, and Subject). You can change this area to be larger with bolding? Hope this helps as well!

Reply | Quote

I don’t have anything that prints an email. Below is code that prints an appointment to word. Maybe it will give you a running start. If nothing else, it shows one way to wrestle with Word via automation.

Sub MailTodaysAppts()
Dim strAns As String
Dim dteAns As Date
Dim strDefaultDate

strDefaultDate = Date + 1
strAns = InputBox(“Enter the date to report MM/DD/YY): “, “Date Input”, strDefaultDate)

If strAns “” Then ‘ Cancel was clicked so do nothing
If IsDate(strAns) Then
dteAns = strAns
Else
dteAns = Date ‘ Didn’t enter a valid date so assume today
End If
End If

Call MailAnyDaysAppts(dteAns)

End Sub

Sub MailAnyDaysAppts(dteDate As Date)
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colCal As Outlook.Items
Dim strFind As String
Dim colMyAppts As Outlook.Items
Dim objAppt As Outlook.AppointmentItem
Dim objMsg As Outlook.MailItem
Dim strHTML As String

‘ start HTML for message
strHTML = ”

Here are my appointments for ” & _
FormatDateTime(dteDate, vbLongDate) & _
“:

”

Set objApp = CreateObject(“Outlook.Application”)
Set objNS = Application.GetNamespace(“MAPI”)
Set colCal = objNS.GetDefaultFolder(olFolderCalendar).Items
colCal.Sort “[Start]”
colCal.IncludeRecurrences = True

‘ get appointments spanning date
strFind = “[Start] ” & _
Quote(Format(dteDate, “dd mmm yyyy”) & ” 12:00 AM”)
Debug.Print strFind
Set colMyAppts = colCal.Restrict(strFind)
For Each objAppt In colMyAppts
strHTML = strHTML & AddApptRow(objAppt)
Next
Set colMyAppts = Nothing

‘ get appointments starting on date
strFind = “[Start] >= ” & _
Quote(Format(dteDate, “dd mmm yyyy”) & ” 12:00 AM”) & _
” AND [Start] < " & _
Quote(Format(dteDate + 1, "dd mmm yyyy") & " 12:00 AM")
Debug.Print strFind
Set colMyAppts = colCal.Restrict(strFind)
For Each objAppt In colMyAppts
strHTML = strHTML & AddApptRow(objAppt)
Next

' create new message
Set objMsg = objApp.CreateItem(olMailItem)
With objMsg
.Subject = "Appointments for " & _
FormatDateTime(dteDate, vbLongDate)
.HTMLBody = strHTML & "

”
.Display
End With

Set objApp = Nothing
Set objNS = Nothing
Set colCal = Nothing
Set colMyAppts = Nothing
Set objAppt = Nothing
End Sub

Function AddApptRow(objAppt As Outlook.AppointmentItem) As String
Dim strRow As String
strRow = “

”
If objAppt.AllDayEvent = True Then
strRow = strRow & “All day”
Else
strRow = strRow & _
FormatDateTime(objAppt.Start, vbShortTime) & _
” – ” & FormatDateTime(objAppt.End, vbShortTime)
End If
strRow = strRow & “ ” & _
objAppt.Subject
If objAppt.Location “” Then
strRow = strRow & ” (” & _
objAppt.Location & “)”
End If
strRow = strRow & ”

”
If objAppt.Body “” Then
strRow = strRow & objAppt.Body & ”

”
End If
strRow = strRow & “

”
AddApptRow = strRow
End Function

Function Quote(MyText)
Quote = Chr(34) & MyText & Chr(34)
End Function

Sub DSToExcel()
Dim objApp As Application
Dim objDL As Object
Dim objRecip As Recipient
Dim objAddrEntry As AddressEntry
Dim objexcel As Excel.Application
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objrange As Excel.Range
Dim I As Integer
Dim intStartRow As Integer
Dim intcol As Integer
On Error Resume Next

Set objApp = CreateObject(“outlook.application”)
If objApp.Inspectors.Count > 0 Then
Set objDL = objApp.ActiveInspector.CurrentItem
If objDL.Class olDistributionList Then
MsgBox “The current item is not a distribution list.”
GoTo Exit_DLToExcel
End If
Else
MsgBox “No open item!”
GoTo Exit_DLToExcel
End If
Set objexcel = GetObject(, “Excel.application”)
On Error GoTo 0
If objexcel Is Nothing Then
Set objexcel = CreateObject(“Excel.Application”)
End If
objexcel.Visible = True
Set objWB = objexcel.Workbooks.Add
Set objWS = objWB.Worksheets(1)
objWS.Cells(1, 1) = objDL.Subject
intStartRow = 3
intRow = intStartRow

For I = 1 To objDL.MemberCount
Set objAddrEntry = objDL.GetMember(I).AddressEntry
objWS.Cells(intRow, 1) = objAddrEntry.Name
objWS.Cells(intRow, 2) = objAddrEntry.Address
objWS.Cells(intRow, 3) = objAddrEntry.Type
intRow = intRow + 1
Next
Set objrange = objWS.Range(Cells(3, 1), Cells(intRow, 3))

For I = 1 To 3
objrange.Columns(I).EntireColumn.AutoFit
Next
objWB.Names.Add _
Name:=Replace(objDL.Subject, ” “, “”), _
RefersTo:=”=” & “” & objWS.Name & _
“!” & objrange.Address & “”

objWS.Activate

Exit_DLToExcel:
Set objApp = Nothing
Set objDL = Nothing
Set objRecip = Nothing
Set objAddrEntry = Nothing
Set objWB = Nothing
Set objWS = Nothing
Set objWS = Nothing
Set objrange = Nothing
Set objexcel = Nothing

End Sub

Sub prnappt()
‘ Gather data from an opened appointment and print to
‘ Word. This provides a way to print the attendee list with their
‘ response, which Outlook will not do on its own.

‘ Set up Outlook
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objSelection As Selection
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strUnderline As String ‘ Horizontal divider line

‘ Set up Word
Dim objWord As Word.Application
Dim objdoc As Word.Document
Dim wordRng As Word.Range
Dim wordPara As Word.Paragraph

On Error Resume Next

Set objApp = CreateObject(“Outlook.Application”)
Set objItem = objApp.ActiveInspector.CurrentItem
Set objSelection = objApp.ActiveExplorer.Selection
Set objAttendees = objItem.Recipients

Set objWord = GetObject(, “Word.application”)
If objWord Is Nothing Then
Set objWord = CreateObject(“word.application”)
End If

strUnderline = String(60, “_”) ‘ use 60 underline characters

On Error GoTo EndClean:

‘ check for user problems with none or too many items open
Select Case objSelection.Count
Case 0
MsgBox “No appointment was opened. Please opten the appointment to print.”
GoTo EndClean:
Case Is > 1
MsgBox “Too many items were selected. Just select one!!!”
GoTo EndClean:
End Select

‘ Is it an appointment
If objItem.Class 26 Then
MsgBox “You First Need To open The Appointment to Print.”
GoTo EndClean:
End If

‘ Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.Location
strNotes = objItem.Body
objOrganizer = objItem.Organizer
objAttendeeReq = “”
objAttendeeOpt = “”

‘ Get The Attendee List
For x = 1 To objAttendees.Count
strMeetStatus = “”
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = “No Response (or Organizer)”
Case 1
strMeetStatus = “Organizer”
Case 2
strMeetStatus = “Tentative”
Case 3
strMeetStatus = “Accepted”
Case 4
strMeetStatus = “Declined”
End Select

If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & objAttendees(x).Name & vbTab & strMeetStatus & vbCr
Else
objAttendeeOpt = objAttendeeOpt & objAttendees(x).Name & vbTab & strMeetStatus & vbCr
End If
Next

‘ Word: Open a new doc and stuff it

objWord.Visible = True
Set objdoc = objWord.Documents.Add
Set objdoc = objWord.ActiveDocument
Set wordRng = objdoc.Range

With wordRng
.Font.Bold = True
.Font.Italic = False
.Font.Size = 14
.InsertAfter “Organizer: ” & objOrganizer
.InsertParagraphAfter
.InsertAfter strUnderline
.InsertParagraphAfter
.InsertParagraphAfter
End With

Set wordPara = wordRng.Paragraphs(4)
With wordPara.Range
.Font.Bold = False
.Font.Italic = False
.Font.Size = 12
.InsertAfter “Subject: ” & strSubject
.InsertParagraphAfter
.InsertAfter “Location: ” & strLocation
.InsertParagraphAfter
.InsertParagraphAfter
.InsertAfter “Start: ” & dtStart
.InsertParagraphAfter
.InsertAfter “End: ” & dtEnd
.InsertParagraphAfter
.InsertParagraphAfter
.InsertAfter “Required: ”
.InsertParagraphAfter
.InsertAfter objAttendeeReq
.InsertParagraphAfter
.InsertAfter “Optional: ”
.InsertParagraphAfter
.InsertAfter objAttendeeOpt
.InsertParagraphAfter
.InsertAfter strUnderline
.InsertParagraphAfter
.InsertAfter “NOTES”
.InsertParagraphAfter
.InsertAfter strNotes
End With

EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objSelection = Nothing
Set objAttendees = Nothing
Set objWord = Nothing
Set objdoc = Nothing
Set wordRng = Nothing
Set wordPara = Nothing

End Sub

Reply | Quote