Results 1 to 5 of 5
  1. #1
    3 Star Lounger
    Join Date
    Jun 2002
    Location
    Nottingham, Nottinghamshire, United Kingdom
    Posts
    257
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Printing mail (Outlook 2000)

    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).

  2. #2
    5 Star Lounger
    Join Date
    May 2001
    Location
    Washington, USA
    Posts
    750
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Printing mail (Outlook 2000)

    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.

  3. #3
    Uranium Lounger
    Join Date
    Dec 2000
    Location
    Salt Lake City, Utah, USA
    Posts
    9,508
    Thanks
    0
    Thanked 6 Times in 6 Posts

    Re: Printing mail (Outlook 2000)

    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.
    -John ... I float in liquid gardens
    UTC -7ąDS

  4. #4
    3 Star Lounger
    Join Date
    Apr 2003
    Location
    Calgary, Alberta
    Posts
    208
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Printing mail (Outlook 2000)

    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!

  5. #5
    5 Star Lounger
    Join Date
    May 2001
    Location
    Washington, USA
    Posts
    750
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Printing mail (Outlook 2000)

    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) & _
    ":</p><table>"

    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") & _
    " AND [End] > " & _
    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 & "</table>"
    .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 = "<tr><td valign=" & Quote("top") & _
    "width=" & Quote("100") & ">"
    If objAppt.AllDayEvent = True Then
    strRow = strRow & "All day"
    Else
    strRow = strRow & _
    FormatDateTime(objAppt.Start, vbShortTime) & _
    " - " & FormatDateTime(objAppt.End, vbShortTime)
    End If
    strRow = strRow & "</td><td valign=" & Quote("top") & ">" & _
    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 & "</td>"
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •