Newbie Outlook VBA. intermediate Excel VBA. Windows 7 Professional, Outlook 2010
I have a script running from a rule that autoforwards all incoming emails. I need it as a rule because otherwise it will not forward the mails in the queue when Outlook loads.
I would like to have the default signature deleted when the mails are forwarded. As the reply is "blank" it is unnecessary to have the sig appended. I have found some code that supposedly worked in Outlook 2007 from the MSDN site. It compiles no errors, executes no errors. I have referenced MS Word in VBA. But the forwarded emails all have the signature still attached.
I cannot just delete the signature because I need it to be there on replies. The switch for the signature is for both replies and forwarded mail.
Here is the code:
Option Explicit
Sub Incoming3(MyMail As MailItem)
Dim strID As String
Dim strSender As String
Dim StrSubject As String
Dim objItem As Outlook.MailItem
Dim myItem As Outlook.MailItem
strID = MyMail.entryID
Set objItem = Application.Session.GetItemFromID(strID)
strSender = objItem.SenderName
StrSubject = objItem.Subject
StrSubject = strSender + ": " + StrSubject
objItem.Subject = StrSubject
objItem.AutoForwarded = False
Set myItem = objItem.Forward
myItem.Recipients.Add "bcc.hwb#gmail.com"
myItem.DeleteAfterSubmit = True
Call DeleteSig(objItem)
myItem.Send
Set myItem = Nothing
Set objItem = Nothing
End Sub
Sub DeleteSig(msg As Outlook.MailItem)
Dim objDoc As Word.Document
Dim objBkm As Word.Bookmark
On Error Resume Next
Set objDoc = msg.GetInspector.WordEditor
Set objBkm = objDoc.Bookmarks("_MailAutoSig")
If Not objBkm Is Nothing Then
objBkm.Select
objDoc.Windows(1).Selection.Delete
End If
Set objDoc = Nothing
Set objBkm = Nothing
End Sub
Any help with Outlook or VBA code would be much appreciated.
Processing the wrong mail in DeleteSig.
myItem.DeleteAfterSubmit = True
Call DeleteSig(myItem)
myItem.Send
Edit 2015 02 26
Debugging VBA Code
Private Sub Incoming3_test()
' Open a mailitem then click F8 repeatedly from this code
Dim currItem As MailItem
Set currItem = ActiveInspector.currentItem
Incoming3 currItem
End Sub
Sub Incoming3(MyMail As MailItem)
Dim myItem As Outlook.MailItem
Set myItem = MyMail.Forward
myItem.Subject = MyMail.senderName & ": " & MyMail.Subject
myItem.Recipients.Add "bcc.hwb#gmail.com"
myItem.DeleteAfterSubmit = True
myItem.Display ' If you are using F8 you can
' view the action taken in DeleteSig.
' Delete the line later.
Call DeleteSig(myItem)
'myItem.Send
Set myItem = Nothing
End Sub
Sub DeleteSig(msg As Outlook.MailItem)
Dim objDoc As Word.Document
Dim objBkm As Word.Bookmark
On Error Resume Next '<--- Very bad without On Error GoTo 0
Set objDoc = msg.GetInspector.WordEditor
Set objBkm = objDoc.Bookmarks("_MailAutoSig")
On Error GoTo 0
If Not objBkm Is Nothing Then
objBkm.Select ' <--- This is where the action starts.
objDoc.Windows(1).Selection.Delete
End If
Set objDoc = Nothing
Set objBkm = Nothing
End Sub
Edit 2015 02 26 - End
When you assign a VBA macro sub to run by the rule you get an instance of the MailItem object. For example:
Sub Incoming3(MyMail As MailItem)
The MyMail object represents an incoming email message which you should use in the code. But I see that you get a new instance:
strID = MyMail.entryID
Set objItem = Application.Session.GetItemFromID(strID)
There is no need to do so. Use the MyMail object in the code.
Also I see the following code:
Set objBkm = objDoc.Bookmarks("_MailAutoSig")
Try to run the code under the debugger and see whether the bookmark can be found. If there is no such bookmark you need to search the body for the first entry From: in the text and delete all the content before that keyword.
Finally, you may find the Getting Started with VBA in Outlook 2010 article in MSDN helpful.
Related
We are updating mails from the drafts folder and sending them a few times a day.
I want to open a selected mail resend it save it so it goes back to drafts and then close it.
I tried below
Sub DRAFT()
Dim myItem As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim objActionsMenu As Office.CommandBarControl
Dim olResendMsg As Outlook.MailItem
' get current item & open if needed
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set myItem = Application.ActiveExplorer.Selection.Item(1)
myItem.Display
Case "Inspector"
Set myItem = Application.ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If myItem Is Nothing Then
MsgBox "Could not use current item. Please select or open a single email.", _
vbInformation
GoTo exitproc
End If
' run the resend command
Set objInsp = myItem.GetInspector
objInsp.CommandBars.ExecuteMso ("ResendThisMessage")
' save orig email
myItem.Save
' close orig email
myItem.Close
exitproc:
Set myItem = Nothing
Set objInsp = Nothing
Set objActionsMenu = Nothing
Set olResendMsg = Nothing
End Sub
You need to pass a OlInspectorClose enumeration value to the MailItem.Close method. It indicates the close behavior, i.e. the save mode. If the item displayed within the inspector has not been changed, this argument has no effect.
Name Value Description
olDiscard 1 Changes to the document are discarded.
olPromptForSave 2 User is prompted to save documents.
olSave 0 Documents are saved.
So, your code should like that:
' close orig email
myItem.Close olSave
Instead of executing the ribbon control programmatically using the CommandBars.ExecuteMso method you may try to create a cope of the source item and then send it.
The ExecuteMso method is useful in cases where there is no object model for a particular command. Works on controls that are built-in buttons, toggleButtons and splitButtons. On failure it returns E_InvalidArg for an invalid idMso, and E_Fail for controls that are not enabled or not visible.
Instead, you may use the MailItem.Copy method which creates another instance of an object.
Sub CopyItem()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim myItem As Outlook.MailItem
Dim myCopiedItem As Outlook.MailItem
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myNewFolder = myFolder.Folders.Add("Saved Mail", olFolderDrafts)
Set myItem = Application.CreateItem(olMailItem)
myItem.Subject = "Speeches"
Set myCopiedItem = myItem.Copy
myCopiedItem.To = "email#address.com"
myCopiedItem.Send()
End Sub
Although there is a mistake in myItem.Close, you cannot resend mail that has not been sent.
Option Explicit
Sub SendMailBasedOnPermanentDraft()
Dim myItem As MailItem
Dim objInsp As Inspector
Dim myCopyOfUnsentItemInDrafts As MailItem
' get current item & open if needed
On Error Resume Next
Select Case TypeName(ActiveWindow)
Case "Explorer"
Set myItem = ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set myItem = ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If myItem Is Nothing Then
MsgBox "Could not use current item. Please select or open a single email.", vbInformation
GoTo exitProc
End If
If myItem.Sent = False Then
Set myCopyOfUnsentItemInDrafts = myItem.copy
With myCopyOfUnsentItemInDrafts
.Subject = "Copied " & Now & ": " & myItem.Subject
.Save
.Display ' change to .Send
End With
Else
MsgBox "Select or open a single unsent email.", vbInformation
End If
exitProc:
Set myItem = Nothing
Set objInsp = Nothing
Set myCopyOfUnsentItemInDrafts = Nothing
End Sub
When I create an email from an .oft template it doesn't show all the content of the e-mail.
It's missing content like images and/or attachments.
I tried to merge Sub reply1() and Sub reply2():
Sub Reply1()
Dim Original As Outlook.MailItem
Dim Reply As Outlook.MailItem
Set Original = Application.ActiveExplorer.Selection(1).Reply
Set Reply = Application.CreateItemFromTemplate("C:\Outlook\Mail.oft")
Original.HTMLBody = Reply.HTMLBody & Original.HTMLBody
Original.Display
End Sub
Sub Reply1()
This code doesn't show images or attachments of my own .oft mail.
It does show my e-mail signature but at the very bottom of both mails.
It does show the content of the e-mail I respond to correctly.
Sub Reply2()
Dim origEmail As MailItem
Dim replyEmail As MailItem
Set origEmail = ActiveExplorer.Selection(1)
Set replyEmail = CreateItemFromTemplate("C:\Outlook\Mail.oft")
replyEmail.To = origEmail.Reply.To
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.Recipients.ResolveAll
replyEmail.Display
Set origEmail = Nothing
Set replyEmail = Nothing
End Sub
Sub Reply2() does the opposite of Sub Reply1.
It shows the images and attachments of my own .oft mail.
It will not show my e-mail signature correctly.
It will not display the content of the mail I respond to correctly. The images are missing
Sub Reply1() Results:
Sub Reply2() Results
Embedded images are stored as hidden attachments on the email message. If you create a new Outlook item based on the template you need to re-attach the required images to get the message body rendered correctly. You can read more about that in the How to add an embedded image to an HTML message in Outlook 2010 thread.
Also, I have noticed the following code:
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
Remember, the HTML string should be a well-formed markup. If you want to insert something into the message body of an existing item you need to paste that inside the opening <body> and closing </body> elements. Otherwise, you may end up with a broken or improperly rendered message body. Even if Outlook do its great job by sorting most mistakes out.
The code below does work in my situation.
Sub Reply1()
Dim fromTemplate As MailItem
Dim reply As MailItem
Dim oItem As Object
Set fromTemplate = CreateItemFromTemplate("C:\Outlook\Mail.oft")
Set oItem = GetCurrentItem()
If Not oItem Is Nothing Then
Set reply = oItem.ReplyAll
CopyAttachments oItem, fromTemplate, reply
reply.HTMLBody = fromTemplate.HTMLBody & reply.HTMLBody
reply.Display
oItem.UnRead = False
End If
Set reply = Nothing
Set oItem = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Sub CopyAttachments(source1, source2, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In source1.Attachments
strFile = strPath & objAtt.fileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
For Each objAtt In source2.Attachments
strFile = strPath & objAtt.fileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub
Forwarding an email retains attachments.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Reply_Retain_Attachments()
Dim fromTemplate As MailItem
Dim origEmail As MailItem
Dim forwardEmail As MailItem
Set fromTemplate = CreateItemFromTemplate("C:\Outlook\Mail.oft")
Set origEmail = GetCurrentItem()
If Not origEmail Is Nothing Then
' Forward retains attachments
Set forwardEmail = origEmail.Forward
forwardEmail.HTMLBody = fromTemplate.HTMLBody & forwardEmail.HTMLBody
forwardEmail.To = origEmail.reply.To ' keep .reply here
forwardEmail.Recipients.ResolveAll
forwardEmail.Display
Else
' This may never occur
MsgBox "GetCurrentItem is nothing?"
End If
End Sub
Function GetCurrentItem() As Object
'On Error Resume Next ' uncomment if you find it necessary
Select Case TypeName(ActiveWindow)
Case "Explorer"
Set GetCurrentItem = ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = ActiveInspector.CurrentItem
End Select
End Function
I'm trying to forward emails from my company's Outlook to an email account outside of our company. I have been given the ok to do this.
I'd like to forward any email that contains "Excel Friday" in the subject line.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If Msg.Subject = "Excel Friday" Then
Dim myMail As Outlook.MailItem
Set myMail = Msg.Reply
myMail.To = "xxxxxx#fakemail.com"
myMail.Display
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I'd like to forward any email that contains "Excel Friday" in the subject line to another email address.
But in the code you check for the exact match of the subject line:
If Msg.Subject = "Excel Friday" Then
Instead you need to look for a substring. To find the position of a substring in a string, use Instr function.
If Instr(Msg.Subject, "Excel Friday") Then
Also I have noticed that you use the Reply method:
Set myMail = Msg.Reply
Use the Forward method instead:
Set myMail = Msg.Forward
And then use the Send method.
myMail.Recipients.Add "Eugene Astafiev"
myMail.Send
Be aware, the code is based on the ItemAdd event handler. This event is not fired when a large number of items are added to the folder at once (more than 16).
You can do this using a Run a Script rule
Sub ChangeSubjectForward(Item As Outlook.MailItem)
Item.Subject = "Test"
Item.Save
Set olForward = Item.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
End Sub
If a vba you can run on all messages in a folder at any time.
Paste into ThisOutlookSession and run
Sub ChangeSubjectThenSend()
Dim olApp As Outlook.Application
Dim aItem As Object
Set olApp = CreateObject("Outlook.Application")
Set mail = olApp.ActiveExplorer.CurrentFolder
For Each aItem In mail.Items
aItem.Subject = "New Subject"
aItem.Save
Set olForward = aItem.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
Next aItem
End Sub
source Link
I'm struggling to insert a string in an incoming email via VBA. The routine works fine when sending mail and it will work on incoming mail if the user clicks Actions Edit. The issue is that incoming mail is locked in read only mode. I've spent the past 13.5 hours searching everywhere. It is possible in earlier versions of Outlook, however Microsoft have removed the CommandBar functionality in Office 2013. Basically I need a way to allow the mail to be editable via a setting in VBA.
Here is the routine
Sub StampReference()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objDoc As Word.Document
Dim objSel As Word.Selection
strFullReference = "Reference: " & Reference
On Error Resume Next
Set objOL = Application
If objOL.ActiveInspector.EditorType = olEditorWord Then
Set objDoc = objOL.ActiveInspector.WordEditor
Set objNS = objOL.Session
Set objSel = objDoc.Windows(1).Selection
objSel.Move wdStory, -1
objDoc.Characters(1).InsertBefore _
strFullReference & vbCrLf & vbCrLf
objSel.Move wdParagraph, 1
End If
Set objOL = Nothing
Set objNS = Nothing
End Sub
EDIT
I've cracked it! Here is the way to change the mode for anyone interested. It is quick and dirty, however it shows how it can be done. I took some code that someone had written to do a Resend and played around with variants to stumble across the correct value to edit. I call this routine just before stamping the information in
Sub SetEditMode()
Dim myItem As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim objActionsMenu As Office.CommandBarControl
Dim olNewMailItem As Outlook.MailItem
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set myItem = ActiveExplorer.Selection.Item(1)
myItem.Display
Case "Inspector"
Set myItem = ActiveInspector.CurrentItem
Case Else
End Select
If myItem Is Nothing Then GoTo ExitProc
'edit mode
Set objInsp = ActiveInspector
objInsp.CommandBars.ExecuteMso ("EditMessage")
objActionsMenu.Execute
ExitProc:
End Sub
I've cracked it! Here is the way to change the mode for anyone interested. It is quick and dirty, however it shows how it can be done. I took some code that someone had written to do a Resend and played around with variants to stumble across the correct value to edit. I call this routine just before stamping the information in
Sub SetEditMode()
Dim myItem As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim objActionsMenu As Office.CommandBarControl
Dim olNewMailItem As Outlook.MailItem
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set myItem = ActiveExplorer.Selection.Item(1)
myItem.Display
Case "Inspector"
Set myItem = ActiveInspector.CurrentItem
Case Else
End Select
If myItem Is Nothing Then GoTo ExitProc
'edit mode
Set objInsp = ActiveInspector
objInsp.CommandBars.ExecuteMso ("EditMessage")
objActionsMenu.Execute
ExitProc:
End Sub
user2970334
got a little problem, I hope someone can help me.
(Outlook 2010 VBA)
this is my current code, what i need is when i click on a mail (only the mail i clicked on, not every mail in the folder/same place)
it has to check if the Sender of the mail is already in my contacts or in the
Addressbook 'All Users',
and if it's not a one of those yet, open the AddContact window and fill in his/her information
what doesn't work yet is:
most important of all, it doesn't run the script when i click on a mail
the current check if the contact already exsist doesn't work
and goes with a vbMsgBox (yes or no and response stuff) wich is not what i want/need
if the contact already exsist then nothing has to happen.
I hope i gave enough information and someone can help me out here :)
Sub AddAddressesToContacts(objMail As Outlook.MailItem)
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
''don't want or need a vbBox/ask box, this is a part of the current contactcheck
''wich doesn't work and is totaly wrong :P
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
bContinue = True
sSenderName = ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
''this part till the --- is wrong, i need someting to check if the contact (the sender)
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
response = vbAbort
If response = vbAbort Then
bContinue = False
End If
End If
''---------
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
'.Save
oContact.Display
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
hey, i still have a last question,
'sets the name of the contact
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
'checks if the contact exsist, if it does exit the for loop
If Not oContact Is Nothing Then
Exit For
End If
End If
this checks if the name is already in contacts,
i need it that it checks if the E-mailaddress is in contacts or not,
can you help me with that?
i had someting like this in mind
set oSendermail = ?the e-mailaddress?
If Not oSendermail Is Nothing Then
Exit For
End If
End If
A solution (including test routine) could look as follows:
(assuming that we only consider external SMTP mails. Adjust the path to your contact folder and add some more error checking!)
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub AutoContactMessageRule(newMail As Outlook.mailItem)
' "script" routine to be called for each incoming Mail message
' This subroutine has to be linked to this mail type using
' Outlook's rule assistant
Dim EntryID As String
Dim StoreID As Variant
Dim mi As Outlook.mailItem
Dim contactFolder As Outlook.Folder
Dim contact As Outlook.ContactItem
On Error GoTo ErrorHandler
' we have to access the new mail via an application reference
' to avoid security warnings
EntryID = newMail.EntryID
StoreID = newMail.Parent.StoreID
Set mi = Application.Session.GetItemFromID(EntryID, StoreID)
With mi
If .SenderEmailType = "SMTP" Then
Set contactFolder = FindFolder("Kemper\_local\TestContacts")
Set contact = contactFolder.items.Find("[Email1Address]=" & Chr(34) & .SenderEmailAddress & Chr(34))
If Not TypeName(contact) <> "Nothing" Then
Set contact = contactFolder.items.Add(olContactItem)
contact.Email1Address = .SenderEmailAddress
contact.Email1AddressType = .SenderEmailType
contact.FullName = .SenderName
contact.Save
End If
End If
End With
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "Ooops!"
Err.Clear
On Error GoTo 0
End Sub
Private Function FindFolder(path As String) As Outlook.Folder
' Locate MAPI Folder.
' Separate sub-folder using '/' . Example: "My/2012/Letters"
Dim fd As Outlook.Folder
Dim subPath() As String
Dim I As Integer
Dim ns As NameSpace
Dim s As String
On Error GoTo ErrorHandler
s = Replace(path, "\", "/")
If InStr(s, "//") = 1 Then
s = Mid(s, 3)
End If
subPath = Split(s, "/", -1, 1)
Set ns = Application.GetNamespace("MAPI")
For I = 0 To UBound(subPath)
If I = 0 Then
Set fd = ns.Folders(subPath(0))
Else
Set fd = fd.Folders(subPath(I))
End If
If fd Is Nothing Then
Exit For
End If
Next
Set FindFolder = fd
Exit Function
ErrorHandler:
Set FindFolder = Nothing
End Function
Public Sub TestAutoContactMessageRule()
' Routine to test Mail Handlers AutoContactMessageRule()'
' without incoming mail messages
' select an existing mail before executing this routine
Dim objItem As Object
Dim objMail As Outlook.mailItem
Dim started As Long
For Each objItem In Application.ActiveExplorer.Selection
If TypeName(objItem) = "MailItem" Then
Set objMail = objItem
started = GetTickCount()
AutoContactMessageRule objMail
Debug.Print "elapsed " & (GetTickCount() - started) / 1000# & "s"
End If
Next
End Sub