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