Script to Print Emails Moved to Inbox SubFolder

[thepieman]

Dear All,

I work in a law firm where we still maintain paper files for all clients. Printing emails is becoming the bane of my life.

I currently have a Quick Access Toolbar icon to run the following macro to print the first page of an email:

Sub PrintPageOne()
SendKeys "%FPR"
SendKeys "%S"
SendKeys "1"
SendKeys "{ENTER}"
End Sub

I also use a proprietary practice management software that allows me to assign emails to the relevant client matter so that I can view them (and all other documents) through the software interface. Once the relevant email is assigned to the relevant matter it is moved in Outlook to a subfolder in the Inbox called "Inbound Matter Based Emails". Similarly, I can open a draft email through the software and once it is sent it is moved to a subfolder in Sent Items called "Outbound Matter Based Emails".

I would like to write a script that automatically prints the first page of each email (perhaps using the script above?) as it 'lands' in either of those two folders but I have no idea where to start. I have tried finding and editing various scripts found online but none seem to work.

Any help would be greatly appreciated.

Kind Regards,
Simon

[gmayor]

How I would approach this is to copy the message to Word and print it from there. You can use events to intercept the movement of the messages to the folders and print them. Put the code in the ThisOutlookSession module. Copy the macro as indicated (and change the message while testing). Run the Application_Startup macro manually (or restart Outlook) and move a message to one or other of the folders. You can modify the formatting as you wish, but as shown it is close to how Outlook would print it. If you have Word running in the background, the process is faster than if it has to start Word.

Option Explicit

Private WithEvents Items As Outlook.Items
Private WithEvents SentItems As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application

    Set olApp = Outlook.Application
    Set Items = Session.GetDefaultFolder(olFolderInbox).folders("Inbound Matter Based Emails").Items
    Set SentItems = Session.GetDefaultFolder(olFolderSentMail).folders("Outbound Matter Based Emails").Items
lbl_Exit:
    Exit Sub
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
Dim olInsp As Inspector
Dim wdApp As Object
Dim oDoc As Object
Dim wdDoc As Object
Dim oRng As Object
Dim bStarted As Boolean
    MsgBox "You moved an item into the 'Inbound Matter Based Emails' folder." 'Remove after testing
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStarted = True
    End If
    wdApp.Visible = True
    Set oDoc = wdApp.Documents.Add
    On Error GoTo 0
    On Error GoTo ErrorHandler
    With item
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        .Display
        Set oRng = oDoc.Range
        wdDoc.Range.Copy
        oRng.Paste
        oRng.collapse 1
        oRng.Text = Environ("UserName") & vbCr
        oRng.Font.Size = 14
        With oRng.ParagraphFormat
            With .Borders(-3)
                .LineStyle = 1
                .lineWidth = 12
                .Color = 0
            End With
        End With
        oRng.collapse 0
        oRng.Text = "From:" & vbTab & item.Sender.Name & vbCr
        With oRng.ParagraphFormat
            .TabStops.ClearAll
            .TabStops.Add wdApp.InchesToPoints(2)
        End With
        oRng.collapse 0
        oRng.Text = "Sent:" & vbTab & item.SentOn & vbCr
        With oRng.ParagraphFormat
            .TabStops.ClearAll
            .TabStops.Add wdApp.InchesToPoints(2)
        End With
        oRng.collapse 0
        oRng.Text = "To:" & vbTab & item.To & vbCr
        With oRng.ParagraphFormat
            .TabStops.ClearAll
            .TabStops.Add wdApp.InchesToPoints(2)
        End With
        oRng.collapse 0
        oRng.Text = "Subject:" & vbTab & item.subject & vbCr & vbCr
        With oRng.ParagraphFormat
            .TabStops.ClearAll
            .TabStops.Add wdApp.InchesToPoints(2)
        End With
        .Close 0
    End With
    wdApp.PrintOut FileName:="", _
                  Range:=4, _
                  item:=7, _
                  copies:=1, _
                  Pages:="1", _
                  PageType:=0, _
                  collate:=True, _
                  Background:=False, _
                  PrintToFile:=False, _
                  PrintZoomColumn:=0, _
                  PrintZoomRow:=0, _
                  PrintZoomPaperWidth:=0, _
                  PrintZoomPaperHeight:=0
    oDoc.Close 0
lbl_Exit:
    If Not wdApp Is Nothing Then
        If bStarted Then wdApp.Quit
    End If
    Set olInsp = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

Private Sub SentItems_ItemAdd(ByVal item As Object)
'the code here is the same as for Items_ItemAdd
End Sub

[thepieman]

Thanks Graham.

That has done the trick. Much appreciated.


Kind regards,
Simon

[thepieman]

Dear Graham (or other helpful soul),

I am wondering if I can add something like the code below to the macro above (essentially I want to select everything once it gets to Word, reduce all text by 1 font size, reduce the left/right indent and reduce the spacing between lines/paragraphs).

Selection.Font.Size = Selection.Font.Size - 1
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(-1.75)
.RightIndent = CentimetersToPoints(-1.58)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 6
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle

If so, where should I put it in the code above? I have tried in a few spots but can't get it to work.

And at great risk of sounding ungrateful (which I assure you I am not!), could I replace all of the code between Private Sub Items_ItemAdd/SentItems_ItemAdd and the relevant End Sub (which I think is the part that copies it to Word and prints it from Word) with the SendKeys macro in my first post to just print it from Outlook?

Many thanks,
Simon

[gmayor]

The additional code would go between

     .Close 0
End with

        With oDoc.Range
            .Font.Shrink
            With .ParagraphFormat
                .LeftIndent = wdApp.CentimetersToPoints(-1.75)
                .RightIndent = wdApp.CentimetersToPoints(-1.58)
                .SpaceBefore = 0
                .SpaceBeforeAuto = False
                .SpaceAfter = 6
                .SpaceAfterAuto = False
                .LineSpacingRule = 0
            End With
        End With