I have written a macro to open the path to a selected email in the results of the Outlook search.
The email is not automatically marked in the open folder so I search for the email in "ActiveExplorer". With .display, I can open the email, but I could not find a way to select the found email in "ActiveExplorer".
Public Sub MailOrdnerPfad()
Dim obj As Object
Dim Ordner As Outlook.MAPIFolder
Dim Betreff As String
Dim Mail As MailItem
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Betreff = obj.ConversationTopic
Set Ordner = obj.Parent
Set Application.ActiveExplorer.CurrentFolder = Ordner
For Each Mail In Ordner.Items
If Mail.ConversationTopic = Betreff Then
Mail.Display
Exit For
End If
Next
End Sub
Clear the original selection then add the found item.
Option Explicit
Public Sub MailOrdnerPfad()
Dim obj As Object
Dim Ordner As Folder
Dim ordItem As Object
Dim Betreff As String
Dim myMail As MailItem
Set obj = ActiveWindow
If TypeOf obj Is Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
If obj.Class = olMail Then
Betreff = obj.ConversationTopic
Debug.Print "Betreff: " & Betreff
Set Ordner = obj.Parent
Set ActiveExplorer.CurrentFolder = Ordner
Debug.Print "Ordner.: " & Ordner
For Each ordItem In Ordner.items
If ordItem.Class = olMail Then
Set myMail = ordItem
Debug.Print "myMail.ConversationTopic: " & myMail.ConversationTopic
If myMail.ConversationTopic = Betreff Then
ActiveExplorer.ClearSelection
' myMail.Display
ActiveExplorer.AddToSelection myMail
Exit For
End If
End If
Next
End If
End Sub
Related
I tried to create email routing rule with below scenario.
Incoming email will be located at Inbox/Active folder. Subject of the email will contain the ticket ID and content
Once new email coming to Active subfolder, Outlook will get the email subject and create the subfolder with format "ticket ID - content" eg: "123123 - issue with outlook"
Then a rule will be created to route this incoming email with ticket ID to the subfolder that I just created
Below is my code but it did not work. Only subfolder is created as expected. Please help me to review if any idea. Thanks
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim olapp As Outlook.Application
Dim olnamespace As Outlook.NameSpace
Set olapp = Outlook.Application
Set olnamespace = olapp.GetNamespace("MAPI")
Set inboxItems = olnamespace.GetDefaultFolder(olFolderInbox).Folders("Filter").Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim olapp As Outlook.Application
Dim olnamespace As Outlook.NameSpace
Dim olActivefolder As Folder
Dim ticketnumber As String
Dim rightsubject As String
Dim leftsubject As String
Dim extsubject As String
Dim colRules As Outlook.Rules
Dim oRule As Outlook.Rule
Dim colRuleActions As Outlook.RuleActions
Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
Dim oFromCondition As Outlook.ToOrFromRuleCondition
Dim oExceptSubject As Outlook.TextRuleCondition
Dim oInbox As Outlook.Folder
Dim oMoveTarget As Outlook.Folder
Set olapp = Outlook.Application
Set olnamespace = olapp.GetNamespace("MAPI")
Set olActivefolder = olnamespace.GetDefaultFolder(olFolderInbox).Folders("Active")
If TypeName(Item) = "MailItem" Then
Debug.Print "triggered"
ticketnumber = Item.Subject
rightsubject = Right(ticketnumber, 16)
leftsubject = Left(ticketnumber, 60)
olActivefolder.Folders.Add (rightsubject & " - " & leftsubject)
End If
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Active")
Set oMoveTarget = oInbox.Folders(rightsubject & " - " & leftsubject)
Set colRules = Application.Session.DefaultStore.GetRules()
Set oRule = colRules.Create(rightsubject, olRuleReceive)
Set oFromCondition = oRule.Conditions.Subject
With oFromCondition
.Enabled = True
.Text = rightsubject
End With
Set oMoveRuleAction = oRule.Actions.MoveToFolder
With oMoveRuleAction
.Enabled = True
.Folder = oMoveTarget
End With
colRules.Save
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
The subject condition should look like this:
'Dim oFromCondition As Outlook.ToOrFromRuleCondition
'Set oFromCondition = oRule.Conditions.subject
'With oFromCondition
' .Enabled = True
' .Text = rightSubject
'End With
Dim oSubjectCondition As TextRuleCondition
Set oSubjectCondition = oRule.Conditions.subject
With oSubjectCondition
.Enabled = True
.Text = Array(rightSubject)
End With
There is likely no need for rules.
Private Sub inboxItems_ItemAdd_Test()
inboxItems_ItemAdd ActiveInspector.CurrentItem
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
' Folder created for first mail
' No folder created for subsequent mail
Dim oInbox As folder
Dim oActivefolder As folder
Dim oMoveTarget As folder
Dim oFolder As folder
Dim ticketNumber As String
Set oInbox = Session.GetDefaultFolder(olFolderInbox)
Set oActivefolder = oInbox.Folders("Active")
If TypeName(Item) = "MailItem" Then
Debug.Print "triggered"
' For testing
ticketNumber = "123123"
For Each oFolder In oActivefolder.Folders
If oFolder.Name = ticketNumber Then
Set oMoveTarget = oActivefolder.Folders(ticketNumber)
Debug.Print " Folder exists: " & oMoveTarget.Name
Exit For
End If
Next
If oMoveTarget Is Nothing Then
Set oMoveTarget = oActivefolder.Folders.Add(ticketNumber)
Debug.Print " Folder added: " & oMoveTarget.Name
End If
Item.Move oMoveTarget
End If
Debug.Print "Done."
End Sub
Whenever I receive meeting cancellation, I would like to remove the meeting cancellation request from my inbox and remove the meeting from the Calendar. Below code works for removing the email, but does not remove the meeting. I have to manually go to calendar and click on "Remove from Calendar". Any ideas?
Sub RemoveCancelledMeetingEmails()
Dim objInbox As Outlook.Folder
Dim objInboxItems As Outlook.Items
Dim i As Long
Set objInbox = Application.Session.GetDefaultFolder(olFolderInbox)
For Each Item In objInbox.Items
If TypeOf Item Is Outlook.MeetingItem Then
Dim objMeeting As Outlook.MeetingItem: Set objMeeting = Item
If objMeeting.Class = 54 Then
Dim objAppointment As Outlook.AppointmentItem
'Set objAppointment = objMeeting.GetAssociatedAppointment(True)
'objMeeting.Display
objMeeting.Delete
'Item.Delete
End If
End If
Next
End Sub
Uncommment the GetAssociatedAppointment line (change the parameter to false to avoid creating an appointment if it does not exist) and call objAppointment.Delete
Set olResCalendar = OpenMAPIFolder("\MailboxName\Calendar")
Sub RemoveCanceledAppointments()
Dim olResCalendar As Outlook.MAPIFolder, olApptItem As Outlook.AppointmentItem,
intCounter As Integer
'Change the path to the resource calendar on the next line
Set olResCalendar = OpenMAPIFolder("\MailboxName\Calendar")
For intCounter = olResCalendar.Items.Count To 1 Step -1
Set olApptItem = olResCalendar.Items(intCounter)
If Left(olApptItem.Subject, 9) = "Canceled:" Then
olApptItem.Delete
End If
Next
Set olApptItem = Nothing
Set olResCalendar = Nothing
End Sub
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, i
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath <> ""
i = InStr(szPath, "\")
If i Then
szDir = Left(szPath, i - 1)
szPath = Mid(szPath, i + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function
Function IsNothing(Obj)
If TypeName(Obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function
From: https://superuser.com/questions/663992/how-can-i-set-outlook-2010-to-automatically-remove-cancelled-meeting
Sharing the code that works now.
Sub deleteFromInbox()
Dim oMeetingItem As Outlook.MeetingItem
Dim oAppointmentItem As AppointmentItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItems = oInbox.Items.Restrict("[MessageClass] = 'IPM.Schedule.Meeting.Canceled'")
For Each oAppt In oItems
If TypeOf oAppt Is MeetingItem Then
Set oMeetingItem = oAppt
If Len(oAppt.Subject) > 0 And InStr(1, oAppt.Subject, "Canceled:") <> 0 Then
Set oAppointmentItem = oMeetingItem.GetAssociatedAppointment(False)
Debug.Print oAppt.Subject
If Not oAppointmentItem Is Nothing Then
oAppointmentItem.Delete
End If
oAppt.Delete
End If
End If
Next
End Sub
When searching for items in All Outlook Items, it shows the messages/items found. Part of the search result items include the folder the message resides in. I'm trying to open a new window of the parent folder where the item resides then highlight that message in the new window. The following code opens the folder, but I cannot figure out how to locate and select the item.
'Opens folder in new windows of current messages folder location
Public Sub OpenFolderPath()
Dim obj As Object
Dim objOLApp As Outlook.Application
Dim objExp As Outlook.Explorer
Dim F As Outlook.MAPIFolder
Dim Msg$
Dim SelMsg As MailItem
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.Name & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set objExp = Application.Explorers.Add(F, olFolderDisplayNormal)
objExp.Activate
End If
' The following does not work
For Each SelMsg In objExp.CurrentFolder.Items
If obj.EntryID = SelMsg.EntryID Then
MsgBox SelMsg.EntryID
' What to put here to select the found item.
End If
Next
End Sub
Here's code that will work:
'Opens folder in new windows of current messages folder location
Public Sub OpenFolderPath()
Dim obj As Object
Dim objOLApp As Outlook.Application
Dim objExp As Outlook.Explorer
Dim F As Outlook.MAPIFolder
Dim Msg$
Dim SelMsg As MailItem
Dim i as Long
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.Name & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set objExp = Application.Explorers.Add(F, olFolderDisplayNormal)
objExp.Activate
End If
'Wait for the user interface to catch up
' (Wait for the new window to finish displaying)
DoEvents
objExp.ClearSelection
For Each SelMsg In objExp.CurrentFolder.Items
If obj.EntryID = SelMsg.EntryID Then
objExp.AddToSelection SelMsg
End If
Next
End Sub
'Opens folder in new windows of current messages folder location
Public Sub OpenFolderPath()
Dim obj As Object
Dim objOLApp As Outlook.Application
Dim objExp As Outlook.Explorer
Dim F As Outlook.MAPIFolder
Dim Msg$
Dim SelMsg As MailItem
Dim i as Long
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.Name & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set objExp = Application.Explorers.Add(F, olFolderDisplayNormal)
objExp.Activate
End If
' The following does not work
i = 1
For Each SelMsg In objExp.CurrentFolder.Items
If obj.EntryID = SelMsg.EntryID Then
MsgBox objExp.CurrentFolder.Items.Item(i)
' What to put here to select the found item.
End If
i = i + 1
Next
End Sub
I tried this vba to get all Sender and Recipient email addresses from emails in Outlook 2003 folder
Sub GetALLEmailAddresses()
Dim objFolder As Folder
Set objFolder = Application.ActiveExplorer.Selection
Dim dic As Dictionary
Dim strEmail As String
Dim strEmails As String
Dim objItem As MailItem
For Each objItem In objFolder.Items
strEmail = objItem.SenderEmailAddress
'If Not dic.Exists(strEmail) Then
'strEmails = strEmails + strEmail + ";"
'dic.Add strEmail, ""
'End If
Next
Debug.Print strEmails
End Sub
any idea what I am doing wrong?
This is my working example for To values
Sub ExtractEmail()
Dim OlApp As Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Text File
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\email addresses.txt", True)
' loop to read email address from mail items.
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
Dim strEmails As String
For Each Mailobject In Folder.Items
Email = Mailobject.To
If InStr(1, Email, "kovalovsky.com", vbTextCompare) Then
If Not dic.Exists(Email) Then
strEmails = strEmails + Email + vbCrLf
dic.Add Email, ""
End If
End If
Next
a.WriteLine (strEmails)
Set OlApp = Nothing
Set Mailobject = Nothing
a.Close
End Sub
My code I use in Outlook:
i use it to copy to clipboard but its one email only it doesnt work for whole inbox\folderofchoice
you might be able to create a loop to open your emails get the info then close the email etc etc...
Sub Get_SenderName()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Dim clipboard As MSForms.DataObject
Set clipboard = New MSForms.DataObject
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
sSender = objItem.SenderName
clipboard.SetText sSender
clipboard.PutInClipboard
Else
ErrMsg = MsgBox("No Email Open To Get Data, Please Open Email To Use This.", vbInformation, "You Did It Wrong.")
End If
End Sub
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