Macro to automatically prepend text to the beginning of a HTML message

[Mikky]

Hello Gurus :hi:

I've spent half a day trying to solve this but I'm not getting anywhere fast.

I need to add text to the beginning of all my outgoing messages (new, forwards, replies) and I am using a signature block with pictures so I believe I need to do this in HTML. What I've tried:
- adding the text to my signature block but it adds two lines before the text so I can't start typing straight away.
- using Quickparts but this requires additional mouse clicks before I can type the message. I'm trying to find something automated.

Ideally, I would like to integrate any new code with what I'm already using in ThisOutlookSession. This code is:

'Prompt for missing Subject before sending
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If Trim(Item.Subject) = "" Then
Cancel = True
MsgBox "The subject is missing", vbInformation
End If

'Add [COMPANY NAME] to Subject for all emails where that text doesn't already exist
If InStr(1, Item.Subject, "COMPANY NAME", vbTextCompare) = False Then
Item.Subject = Item.Subject & " [COMPANY NAME]"
End If

'Send a BCC copy of every Email to yourself, change email address as required
Dim R As Outlook.Recipient
Dim Address$
Address = "email address"
Set R = Item.Recipients.Add(Address)
R.Type = olBCC
R.Resolve

End Sub

I have to be honest, I really have no idea what I'm doing but managed to get things working through trail and error...
Any help that you can provide would be greatly appreciated. A gold star to whoever manages to get it all working together (if that's even possible): pray2:

Thanks in advance.

Mikky

[gmayor]

The following should work


Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim R As Outlook.Recipient
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Const strCompany As String = " [COMPANY]"
Const sAddress As String = "someone@somewhere.com"
Const strText As String = "This text is added to the start of the message" & vbCr
With Item
'this part should not be required as Outlook will warn of a missing subject
If Trim(.Subject) = "" Then
MsgBox "The subject is missing", vbInformation
Cancel = True
GoTo lbl_Exit
End If

'Add [COMPANY NAME] to Subject for all emails where that text doesn't already exist
If InStr(1, .Subject, strCompany) = 0 Then
.Subject = .Subject & strCompany
End If

'Send a BCC copy of every Email to yourself, change email address as required
Set R = .Recipients.Add(sAddress)
R.Type = olBCC
R.Resolve
'Add text to start of message
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = strText
End With
lbl_Exit:
Exit Sub
End Sub

[Mikky]

Graham you are a legend !!! :clap:

You've certainly saved my sanity.

One more quick one (well I hope its quick) - when [COMPANY NAME] is inserted at the beginning of the email the cursor is sitting just before the 'C'. Is there an easy way to have the cursor on the next line so I can start typing straight away?

If it's too hard don't worry. You've all ready helped SO much.

Cheers, Mikky.

[gmayor]

After the line
oRng.Text = strText

add

oRng.Collapse 0
oRng.Select

[Mikky]

Thanks again Graham

I got so excited when you posted the code that I immediately tried it out but didn't explain myself properly. I guess that's what happens when I'm doing this at 2am instead of sleeping...

The issue I was trying to convey was that there was no gap between [COMPANY NAME] and the beginning of the message. But with my limited knowledge I managed to work it out (once I'd slept on it of course).

In the line:


Const strText As String = "This text is added to the start of the message" & vbCr

I have added:


& vbNewLine

Thanks again for all your help. It is much appreciated.

Cheers, Mikky.

Oh and I couldn't find a gold star so I went with this. Thanks Graham:trophy: