I managed to find a nice little script that will forward emails to an external address becuase our exchange server is configured not to do that.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryIDs
Dim objItem
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
Set myItem = objItem.Forward
myItem.Recipients.Add "mike.dumka#outlook.com"
myItem.Send
Next
End Sub
Works perfect. But now ... I would only like to do this if they are messages, not appointment updates or requests. I have no idea where to find this, or even what to look for. My VBA skills are from very long ago.
If you look at the screenshot, I think I have the MsgBox function in the right way, but could you verify?
Thanks,
Mike
You can either check the myItem.MessageClass property (it will be "IPM.Note" for the regular messages) or myItem.Class property - it will be 43 (olMail).
Just a little bit of conditional logic to ensure that you're only dealing with MailItem (since objItem is variant/object and may be another type of item like an AppointmentItem, etc.):
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
MsgBox "I'm working!", vbExclamation
Dim varEntryIDs
Dim objItem As Object
Dim myItem As MailItem
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
'## Check the item's TypeName and ONLY process if it's a MailItem:
If TypeName(objItem) = "MailItem" Then
Set myItem = objItem.Forward
myItem.Recipients.Add "mike.dumka#outlook.com"
myItem.Send
Else:
MsgBox "Type of item is: " & TypeName(objItem)
End If
Next
End Sub
Related
I have the below code to permanently delete mail from the inbox.
However, when responses to a meeting invite, to say the person has accepted the meeting do not delete.
When I click on that mail and run this code it does not delete?
Sub PermDelete(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim objDeletedFolder As Outlook.Folder
Dim objItem As Object
Dim objProperty As Variant
Set objDeletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
To run code that has an argument like (Item As Outlook.MailItem) you need to pass the information in this case Item.
You cannot run such code from a button.
You can run Sub delItemPermanently() from a button or F8 to step through.
Option Explicit
Sub delItemPermanently()
' Select a single item
' This line passes the item to PermDelete
PermDelete ActiveExplorer.Selection(1)
End Sub
Sub PermDelete(Item As Object)
' Notice Object not Mailitem
' This will accommodate mailitems as well
...
End Sub
In the code your function accepts an instance of the MailItem class only. But an Outlook folder may contain different types of items - appointments, documents, notes and etc. To differentiate them at runtime you can use the following construction:
Dim obj As Object
If TypeName(obj) = "MailItem" Then
' your code for mail items here
End If
So, you need to declare the function in the following way (if you don't need to do separate actions for different kind of items):
Sub PermDelete(Item As Object)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim objDeletedFolder As Outlook.Folder
Dim objItem As Object
Dim objProperty As Variant
Set objDeletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
Set Item to a generic Object
Example on selected item
Option Explicit
Public Sub Example()
Dim obj As Object
Set obj = ActiveExplorer.Selection.Item(1)
obj.Delete
End Sub
I have code that reads mail to generate a task with the mail's content.
In a few cases this hits a problem, when reading the RTFbody from the mail, saying "not implemented".
Can I test against this? Like WHEN IS NULL ... which checks if a variable has appropriate content.
Sub CreateTempTaskFromMail()
Dim oMail As Outlook.MailItem
Set oMail = ActiveInspector.CurrentItem
Dim s, sNr As String
s = oMail.subject
Dim oTask As Outlook.TaskItem
Set oTask = CreateTaskWithTempFolder(s, False) ' Function creating and returing task
oTask.RTFBody = oMail.RTFBody
End sub
I tried to test several ways if RTFbody has a problem. All of these approaches throw an error.
If oMail.RTFBody Is Nothing Then Stop
If IsError(oMail.RTFBody) Then Stop
If IsMissing(oMail.RTFBody) Then Stop
If IsEmpty(oMail.RTFBody) Then Stop
If there is absolutely no real solution then
Option Explicit
Sub CreateTempTaskFromMail()
Dim oObj As Object
Dim oMail As mailItem
Dim oTask As TaskItem
Dim s As String
Set oObj = ActiveInspector.currentItem
If oObj.Class = olMail Then
Set oMail = oObj
s = oMail.subject
Set oTask = CreateTaskWithTempFolder(s, False) ' Function creating and returing task
' If you absolutely cannot determine the problem
' https://excelmacromastery.com/vba-error-handling#On_Error_Resume_Next
On Error Resume Next
oTask.RTFBody = oMail.RTFBody
If Err <> 0 Then
Debug.Print "Error was bypassed using a technique that is to be avoided."
Exit Sub
End If
' Consider mandatory AND as soon as possible
On Error GoTo 0
oTask.Display
Else
Debug.Print "not a mailitem"
End If
End Sub
Before accessing the RTFBody property in the code I'd suggest checking the item's type first to make sure such property exists for a specific item type:
If TypeOf item Is MailItem Then
' do whatever you need with RTFBody here
End If
Or
If TypeName(item) = "MailItem" Then
' do whatever you need with RTFBody here
End If
If you are using Office 2016 product, you should update office. It is early office 2016 build's bug.
can someone advise what have I done wrong on here? It is not picking up the emails the way it should (i.e. automatically download the attachments into a folder). There is no error messages, but simply no action (I went F8 but would not notice any irregularities).
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")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "test123#gmail.com") And _
(Msg.Subject = "Test123") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Test\Test1\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Also, when I'm trying to F8 for errors, the VBA only goes through the first part of the code i.e. Private Sub Application_Startup(), I'm unable to test the other part {Private Sub Items_ItemAdd(ByVal item As Object)} cos the VBA simply denies going through it line by line (no error pop-ups or anything, it simply is not picking up the lines)
The problem is in the line
myAttachments.item(1).SaveAsFile attPath & Att
You are always picking attachment no 1, which might be something else than you think. Add a For Each around this, and you'll hopefully get some better results.
My guess is that your problem is this condition:
If (Msg.SenderName = "test123#gmail.com")
The MailItem.SenderName property returns the display name of the sender, which may not be the actual email address. You should be checking the MailItem.SenderEmailAddress property instead.
If the email you're trying to match is an Exchange address (ie, it's from someone in your office's Outlook account), the MailItem.SenderEmailAddress will return an incomprehensible string that you'll need to resolve to an actual email. In that case, you'd need to check the MailItem.Sender.GetExchangeUser().PrimarySmtpAddress property instead.
For that reason, I like to use an "emailMatches" function that checks both scenarios. Then your condition would be something like:
If emailMatches(Msg, "test123#company.com")
Here's the function I use:
Function emailMatches(mItem As Object, addressToMatch As String) As Boolean
Dim goAhead As Boolean
goAhead = False
If UCase(mItem.SenderEmailAddress) = UCase(addressToMatch) Then
goAhead = True
ElseIf Left(mItem.SenderEmailAddress, 5) = "/O=EX" Then
If UCase(mItem.Sender.GetExchangeUser().PrimarySmtpAddress) = UCase(addressToMatch) Then
goAhead = True
End If
End If
emailMatches = goAhead
End Function
I have a listener in VBA on my outlook box to perform an action if a receive a mail from a specific email.
The problem is that if I get a error mail (non-delivery email) then my condition is run on a mail which doesn't have that property so my method crashes.
I don't know what the subject may be either.
Does anyone have an idea if I can test if the property exists or if there is another property I can check for to identify if my sender matches?
Many thanks in advance
Sub SetFlagIcon()
Dim mpfInbox As Outlook.Folder
Dim obj As Outlook.MailItem
Dim i As Integer
Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Test")
' Loop all items in the Inbox\Test Folder
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set obj = mpfInbox.Items.Item(i)
If obj.SenderEmailAddress = "someone#example.com" Then
'Set the yellow flag icon
obj.FlagIcon = olYellowFlagIcon
obj.Save
End If
End If
Next
End Sub
Dim obj as a generic Object - there are objects other than MailItem in your Inbox, also to improve your loop try using Items.Restrict Method (Outlook)
Option Explicit
Sub SetFlagIcon()
Dim mpfInbox As Outlook.Folder
Dim obj As Object
Dim Items As Outlook.Items
Dim i As Long
Dim Filter As String
Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder _
(olFolderInbox).Folders("Temp")
Filter = "[SenderEmailAddress] = 'someone#example.com'"
Set Items = mpfInbox.Items.Restrict(Filter)
' Loop all items in the Inbox\Test Folder
For i = 1 To Items.Count
If Items(i).Class = olMail Then
Set obj = Items(i)
'Set the yellow flag icon
obj.FlagIcon = olYellowFlagIcon
obj.Save
End If
Next
End Sub
Items.Restrict Method Applies a filter to the Items collection, returning a new collection containing all of the items from the original that match the filter.
I use the Application_ItemSend event to trigger actions on mails I send.
Under certain conditions the mail shall be moved to a new subfolder.
Since one can't move the mail before it is sent without jeopardizing the send, I copy the mail before sending and delete the original after.
Set myCopiedItem = objItem.Copy
myCopiedItem.Move olTempFolder
myCopiedItem.UnRead = False
myCopiedItem.SentOnBehalfOfName = olSession.CurrentUser
myCopiedItem.SendUsingAccount = olSession.Accounts(1)
'myCopiedItem.SenderName = olSession.CurrentUser
'myCopiedItem.SenderEmailAddress = olSession.CurrentUser.Address
objItem.DeleteAfterSubmit = True
I would like to have me as a sender on the copied mail.
I tried to set several different properties:
.SendOnBehalfOfName and .SendUsingAccount do not do what I am after.
.SenderName and .SenderEmailAddress showed to be "read only"
How can I avoid that the mail shows up in the folder without a sender?
Would this work for you:
Save the email in the Application_ItemSend event first:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.Save
MoveEmail Item, "\\Mailbox - Darren Bartrup-Cook\Inbox\Some Folder\Some Sub Folder"
End Sub
In a separate module (excuse MoveEmail being a function - originally it returned the EmailID of the moved email):
'----------------------------------------------------------------------------------
' Procedure : MoveEmail
' Author : Darren Bartrup-Cook
' Date : 03/07/2015
'-----------------------------------------------------------------------------------
Public Function MoveEmail(oItem As Object, sTo As String) As String
Dim oNameSpace As Outlook.NameSpace
Dim oDestinationFolder As Outlook.MAPIFolder
Set oNameSpace = Application.GetNamespace("MAPI")
Set oDestinationFolder = GetFolderPath(sTo)
oItem.Move oDestinationFolder
End Function
'----------------------------------------------------------------------------------
' Procedure : GetFolderPath
' Author : Diane Poremsky
' Original : http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
'-----------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Outlook.MAPIFolder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Firstly, Move is a function, not a sub - it returns the newly created item. The original must be immediately discarded.
set myCopiedItem = myCopiedItem.Move(olTempFolder)
Secondly, sender related properties are set only after the message is sent and moved to the Sent Items folder. One solution is to wait until the Items.ItemAdd event fires on the Sent Items folder and make a copy then - the sender properties will be set by that time.
In theory, you can set a dozen or so PR_SENDER_* and PR_SENT_REPRESENTING_* MAPI properties, but if I remember my experiments correctly, MailItem.PropertyAccessor.SetProperty will not let you set sender related properties. If using Redemption is an option (I am its author), it allows to set the RDOMail.Sender and RDOMail.SentOnBehalfOf properties to an instance of an RDOAddressEntry object (such as that returned by RDOSession.CurrentUser).