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
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
We use a shared Outlook email box and we need to save some of the attachments from that email.
I need the macro to:
Allow user to select multiple emails and save all the attachments in the selection
Allow the user to select what folder to save the attachments in (it will be different every time)
Add the ReceivedTime to the file name as we get some email attachments with the same name but they are always received on different days
Not alter the original email (don't delete the attachment or add a note to the email)
I have combined different lines from macros I found.
On both lines with "***" I get
"Runtime error 91: "object variable or With block variable not set"
I remove the dateFormat and SaveAs and still get the runtime error on the SaveAs line.
Sub saveAttachment()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Dim objSel As Outlook.Selection
Dim lngCount As Long
Dim sFolder As String
Dim dateFormat As String
dateFormat = Format(objMsg.ReceivedTime, "yyyy-mm-dd") '***
Dim xlObj As Excel.Application
Set xlObj = New Excel.Application
' Open the select folder prompt
With xlObj.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
ElseIf .Show = 0 Then
MsgBox "Failed to select folder to save attachements to"
Exit Sub
End If
End With
xlObj.Quit
Set xlObj = Nothing
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
objAtt.SaveAsFile sFolder & "\" & objAtt.FileName & dateFormat '***
Else
MsgBox "No attachements selected"
End If
Next
End Sub
We are utilizing Office365.
First of all, you need to place the Format method inside the loop where the mail item is accessible and instantiated. Then you need to make sure the file path is valid and no forbidden symbols are used in the file name.
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
dateFormat = Format(objMsg.ReceivedTime, "yyyy-mm-dd")
objAtt.SaveAsFile sFolder & "\" & objAtt.FileName & dateFormat
Else
MsgBox "No attachements selected"
End If
Next
You may find the Getting started with VBA in Office article helpful.
Return an object property after you have the object.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub saveAttachment()
Dim objItem As Object
Dim objAtts As Attachments
Dim objAtt As Attachment
Dim objSel As Selection
Dim lngCount As Long
Dim sFolder As String
Dim dateFormat As String
Dim xlObj As Excel.Application
Set xlObj = New Excel.Application
' Open the select folder prompt
With xlObj.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
ElseIf .Show = 0 Then
MsgBox "Failed to select folder to save attachements to"
Exit Sub
End If
End With
xlObj.Quit
Set xlObj = Nothing
' .Selection allows more than one item
Set objSel = ActiveExplorer.Selection
For Each objItem In objSel
' Mailitems only
If TypeOf objItem Is MailItem Then
dateFormat = Format(objItem.ReceivedTime, "yyyy-mm-dd")
Set objAtts = objItem.Attachments
lngCount = objAtts.Count
If lngCount > 0 Then
For Each objAtt In objAtts
Debug.Print sFolder & "\" & dateFormat & objAtt.FileName
objAtt.SaveAsFile sFolder & "\" & dateFormat & objAtt.FileName
Next
Else
MsgBox "No attachments in " & objItem.Subject
End If
End If
Next
End Sub
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.
I have a little script that converts an email into a Task in my outlook.
My main frustration is that it won't preserve the html format, and deals with embedded images as attachments. I was wondering if anyone could help. I know it is possible as I've copied the body of an email directly across to the body of a task manually and it is preserved fine.
Sub ConvertSelectedMailtoTask()
Dim objApp As Outlook.Application
Dim objTask As Outlook.TaskItem
Dim objMail As Outlook.MailItem
Set objTask = Application.CreateItem(olTaskItem)
Set objApp = Application
If TypeName(objApp.ActiveWindow) = "Explorer" Then
For Each objMail In Application.ActiveExplorer.Selection
If Left(objMail.Subject, 3) = "RE:" Or Left(objMail.Subject, 3) = "FW:" Then
subj = Right(objMail.Subject, Len(objMail.Subject) - 4)
Else
subj = objMail.Subject
End If
With objTask
.Subject = subj
.Importance = objMail.Importance
.StartDate = objMail.ReceivedTime
.Body = objMail.Body
.DueDate = Date + 3
If objMail.Attachments.Count > 0 Then
CopyAttachments objMail, objTask
End If
.ReminderSet = True
.ReminderTime = Date + 2.5
.Sensitivity = olPrivate
.Save
End With
Next
ElseIf TypeName(objApp.ActiveWindow) = "Inspector" Then
Set objMail = objApp.ActiveInspector.CurrentItem
If Left(objMail.Subject, 3) = "RE:" Or Left(objMail.Subject, 3) = "FW:" Then
subj = Right(objMail.Subject, Len(objMail.Subject) - 4)
Else
subj = objMail.Subject
End If
With objTask
.Subject = subj
.Importance = objMail.Importance
.StartDate = objMail.ReceivedTime
.Body = objMail.Body
.DueDate = Date + 3
If objMail.Attachments.Count > 0 Then
CopyAttachments objMail, objTask
End If
.ReminderSet = True
.ReminderTime = Date + 2.5
.Sensitivity = olPrivate
.Save
End With
End If
Set objTask = Nothing
Set objMail = Nothing
Set objApp = Nothing
End Sub
And here is the script for the attachments
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.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
Update:
I found a bit of code that uses a word document to preserve the formatting:
Sub CopyFullBody(sourceItem As Object, targetItem As Object)
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objDoc2 As Word.Document
Dim objSel2 As Word.Selection
On Error Resume Next
' get a Word.Selection from the source item
Set objDoc = sourceItem.GetInspector.WordEditor
If Not objDoc Is Nothing Then
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory
objSel.Copy
Set objDoc2 = targetItem.GetInspector.WordEditor
If Not objDoc2 Is Nothing Then
Set objSel2 = objDoc2.Windows(1).Selection
objSel2.PasteAndFormat wdPasteDefault
Else
MsgBox "Could not get Word.Document for " & _
targetItem.Subject
End If
Else
MsgBox "Could not get Word.Document for " & _
sourceItem.Subject
End If
Set objDoc = Nothing
Set objSel = Nothing
Set objDoc2 = Nothing
Set objSel2 = Nothing
End Sub
This doesn't seem like it would be the only solution hence updating my own post instead of answering my question as this seems a bit long winded (using another application just to give me formatting, when I can copy and paste text manually just fine all in Outlook). If anyone has any other thoughts on this/defining attachment types please carry on answering!
in the line
.Body = objMail.Body
you only ask fot the non-formatted Body. Try instead:
.Body = objMail.htmlBody
and something completely different: I just put reminders onto the emails themselves, so I have no need to create extra Tasks at all...
Keep in mind that Outlook tasks, appointments and tasks work with RTF, not HTML. hence TaskItem, ContactItem and AppointmentItem objects only expose the RtfBody property, but not HTMLBody (like MailItem does).
You will need to either convert HTML to RTF (you can try the Word Object Model for that) or use Redemption (I am its author): unlike Outlook Object Model, it exposes the RDOTaskItem.HTMLBody property and dynamically converts HTML to the native (for tasks) RTF when that property is set.
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