When I receive e-mail I need check mail body. And I have keywords-more than thousand- If mail has that words, rules should be move to a specific folder. I use this script:
CreateRule()
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 oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oMoveTarget = oInbox.Folders("test").Folders("subTest")
Set colRules = Application.Session.DefaultStore.GetRules()
Set oRule = colRules.Create("ruleTest", olRuleReceive)
Set oMoveRuleAction = oRule.Actions.MoveToFolder
With oMoveRuleAction
.Enabled = True
.Folder = oMoveTarget
End With
Set oExceptSubject = _
oRule.Conditions.BodyOrSubject
With oExceptSubject
.Enabled = True
.Text = Array("my keywords")
End with
colRules.Save
End Sub
But this script dont accept all my keywords, how can I add them in rule...
You need to split the array with commas as the following sample shows:
'Add the subjects to the rule condition
For Each objRuleCondition In objSpecificRule.Conditions
If objRuleCondition.ConditionType = olConditionSubject Then
If objRuleCondition.Enabled = True Then
Set objTextRuleCondition = objRuleCondition
strTextArray = objTextRuleCondition.Text
varSubjects = objDictionary.Keys
varNewTextArray = Split(Join(strTextArray, ",") & "," & Join(varSubjects, ","), ",")
objTextRuleCondition.Text = varNewTextArray
End If
End If
Next
See How to Quickly Add the Subjects of Multiple Emails to the Condition of a Specific Outlook Rule for more information.
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
I'm trying to export sender email address and recipient email addresses (to and cc) to Excel. I adapted code I found online. It does most of what I need but there are two problems:
It only works with a single recipient. If there are two or more recipients, it provides names (e.g. Jo Bloggs) instead of email addresses.
It only includes people in the 'To' field, not those in the 'CC' field.
I think the bit that needs fixing is:
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
Full code:
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim obj As Object
Dim olItem 'As Outlook.MailItem
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("Sheet1")
On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
xlSheet.Range("A1") = "Sender Name"
xlSheet.Range("B1") = "Sender Email"
xlSheet.Range("C1") = "Subject"
xlSheet.Range("D1") = "Body"
xlSheet.Range("E1") = "Sent To"
xlSheet.Range("F1") = "Date"
End If
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each obj In objItems
Set olItem = obj
'collect the fields
strColA = olItem.SenderName
strColB = olItem.SenderEmailAddress
strColC = olItem.Subject
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime
' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColB)
If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF
'Next row
rCount = rCount + 1
xlWB.Save
Next
' don't wrap lines
xlSheet.Rows.WrapText = False
xlWB.Save
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Iterating through all items in the folder is not really a good idea. I'd recommend starting from the Find/FindNext or Restrict methods instead. Please note that there are some item properties that you can’t use for the filter. You can read more about the properties not allowed in the filter string and string formats used for the search criterion on MSDN.
The following example uses the Restrict method to get all Inbox items of Business category and moves them to the Business folder. To run this example, create or make sure a subfolder called 'Business' exists under Inbox:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Categories] = 'Business'")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Please remember that you can set a suitable filter (View | View Settings |filter) on a folder and study the filter string on the SQL tab of the Filter dialog. Then you can construct any required filter string in the code.
If woudl be nice to use Items.Find/FindNext or Items.Restrict, but I cannot think of a query that would let you do what you want. If it is a one time thing, you have no choice but to loop through all items in a folder and for each item loop through all recipients and compare each recipient's entry id (Recipient.EntryID) with the sender entry id (MailItem.Sender.EntryId).
I created a rule to run a script on all incoming email. The script checks if the email has any attachments and checks their type. Mails which have only .pdf attachments, stay in the inbox, the rest goes to Error folder. The script also ignores hidden attachments.
This works on my own Outlook mailbox. The problem is that it has to work on a shared mailbox.
I modified the rule so it would take into consideration only the messages arriving at a shared mailbox, but it's not working, even if I set up a rule without any script.
I tried to change the script, but the only thing I managed to achieve is moving the pdf-less emails from my inbox to Error folder in shared inbox.
Here is the script that works with my own mailbox:
Sub PDF(Item As Outlook.MailItem)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer
allPdf = True
hidNum = 0
Dim pa As PropertyAccessor
For Each myAtt In Item.Attachments
Debug.Print myAtt.DisplayName
Set pa = myAtt.PropertyAccessor
If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
hidNum = hidNum + 1
Else
If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
allPdf = False
End If
End If
Next
If allPdf = False Or Item.Attachments.Count = hidNum Then
Item.Move Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Error")
End If
Set myAtt = Nothing
Set pa = Nothing
End Sub
I tried this script, but it's not working:
Sub PDF4(Item As Outlook.MailItem)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("test#mailbox.com")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders(olFolderInbox)
Set colItems = objFolder.Items
allPdf = True
hidNum = 0
Dim pa As PropertyAccessor
For Each Item In objFolder.Items
For Each myAtt In Item.Attachments
Debug.Print myAtt.DisplayName
Set pa = myAtt.PropertyAccessor
If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
hidNum = hidNum + 1
Else
If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
allPdf = False
End If
End If
Next
If allPdf = False Or Item.Attachments.Count = hidNum Then
Item.Move objInbox.Folders("Error")
End If
Set myAtt = Nothing
Set pa = Nothing
End Sub
There are two problems:
Is it possible to set up a rule that takes into consideration only the messages which arrive at the shared inbox? The current rule checks only the emails, which arrive at my inbox. (I have no option in Rule Management to "Apply changes to this folder:".)
If not possible, I could always make the script work through macro.
How should the code be written? Maybe it's ok and is not working only because of the rule. Is it possible to make a script that checks the attachments only of the messages that arrive at the shared inbox?
#niton suggested using ItemAdd and it worked. Now the script checks emails in shared inbox.
Thank you for help!
Solution:
It has to be put inside ThisOutlookSession
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Dim Recip As Outlook.Recipient
Set Recip = objNS.CreateRecipient("test#mail.com")
Set objWatchFolder = objNS.GetSharedDefaultFolder(Recip, olFolderInbox)
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
Set Recip = Nothing
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer
allPdf = True
hidNum = 0
Dim pa As PropertyAccessor
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Dim Recip As Outlook.Recipient
Set Recip = objNS.CreateRecipient("test#mail.com")
Set objWatchFolder = objNS.GetSharedDefaultFolder(Recip, olFolderInbox)
For Each myAtt In Item.Attachments
Debug.Print myAtt.DisplayName
Set pa = myAtt.PropertyAccessor
If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
hidNum = hidNum + 1
Else
If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
allPdf = False
End If
End If
Next
If allPdf = False Or Item.Attachments.Count = hidNum Then
Item.Move objWatchFolder.Parent.Folders("Error")
End If
Set Item = Nothing
Set myAtt = Nothing
Set pa = Nothing
Set objWatchFolder = Nothing
Set Recip = Nothing
End Sub
I'm sure the code could be more optimized, but "it just works".
So, I've been wrestling with this task for WAY too long now. I am trying to make a button that creates an appointment and sends it to someone. So far, I've been successful in creating the appointment with the variables I want, but I can't figure out how to send it to the right person. Or send it at all for that matter. I'm very new to Outlook applications within VBA, so be gentle with me, but here is my code so far:
Sub appt()
Dim OutApp As Object
Dim OutMail As Object
Dim duedate As String
Dim currentrow As String
Dim currentsheet As String
Dim owner As String
currentsheet = ActiveSheet.Name
currentrow = Range("C10:C" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
duedate = Range("C" & currentrow).Offset(0, 1)
owner = Range("C" & currentrow).Offset(0, 2)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(1)
On Error Resume Next
With OutMail
.Recipients = Range("M3")
.Subject = "Next PDB Task for " & currentsheet
.Importance = True
.Start = "8:00 AM" & duedate
.End = "8:00 AM" & Format(Date + 5)
.ReminderMinutesBeforeStart = 10080
.Body = "Text and Stuff"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Unload Emy
End Sub
So, this is definitely grabbing the information I want from the sheet it's run in, however it's not going anywhere. Do I need to use something other than .Recipients? Is it possible to forward this (with .Forward maybe?)? Any help would be greatly appreciated!!!
P.S. The email address I want to send the appointment to is in cell M3.
I didn't try the scripts, but it looks like they will do what you want.
Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Dan Wilson")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = _
myNamespace.GetSharedDefaultFolder _
(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
excel vba create appointment in someone elses calendar
Sub MultiCalendars()
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim objGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objFolder As Folder
Dim calItem As Object
Dim mtgAttendee As Outlook.Recipient
Dim i As Integer
Set Application.ActiveExplorer.CurrentFolder = Session.GetDefaultFolder(olFolderCalendar)
DoEvents
Set objPane = Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
Set objGroup = .GetDefaultNavigationGroup(olMyFoldersGroup)
' To use a different calendar group
' Set objGroup = .Item("Shared Calendars")
End With
For i = 1 To objGroup.NavigationFolders.Count
If (objGroup.NavigationFolders.Item(i).Folder.FullFolderPath = "\\Mailbox - Doe, John T\Calendar") Then
Set objNavFolder = objGroup.NavigationFolders.Item(i)
Set calItem = objNavFolder.Folder.Items.Add(olAppointmentItem)
calItem.MeetingStatus = olMeeting
calItem.Subject = "Test Meeting - Ignore"
calItem.Location = "TBD Location"
calItem.Start = #1/19/2015 1:30:00 PM#
calItem.Duration = 90
Set mtgAttendee = calItem.Recipients.Add("John Doe")
mtgAttendee.Type = olRequired
Set mtgAttendee = calItem.Recipients.Add("Jane Doe")
mtgAttendee.Type = olOptional
Set mtgAttendee = calItem.Recipients.Add("CR 101")
mtgAttendee.Type = olResource
calItem.Save
If (calItem.Recipients.ResolveAll) Then
calItem.Send
Else
calItem.Display
End If
End If
Next
Set objPane = Nothing
Set objModule = Nothing
Set objGroup = Nothing
Set objNavFolder = Nothing
Set objFolder = Nothing
Set calItem = Nothing
Set mtgAttendee = Nothing
End Sub
https://answers.microsoft.com/en-us/office/forum/office_2010-customize/excel-vba-create-an-appointment-in-someone-elses/4c2ec8d1-82f2-4b02-abb7-8c2de2fd7656?auth=1
I currently am able to use the macro below to create a Rule that will send all email with the Selected sender address to a designated folder.
This works fine. However I want to create the rule to send all email from that domain (regardless of sender) to the folder.
Here is the code I am currently using.
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 oRuleCondition As Outlook.AddressRuleCondition
Dim oExceptSubject As Outlook.TextRuleCondition
Dim oInbox As Outlook.Folder
Dim oMoveTarget As Outlook.Folder
'Specify target folder for rule move action
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
'Assume that target folder already exists
Set oMoveTarget = Application.Session.Folders("myinbox").Folders("Folders").Folders("Reference").Folders("Vendor Marketing")
'Get Rules from Session.DefaultStore object
Set colRules = Application.Session.DefaultStore.GetRules()
Dim sSender As String
For Each objItem In Application.ActiveExplorer.Selection
If objItem.Class = olMail Then
sSender = objItem.SenderEmailAddress
End If
Next
Dim domain() As String
domain = Split(sSender, "#")
Dim dDomain As String
dDomain = "#" + domain(1)
'Create the rule by adding a Receive Rule to Rules collection
If MsgBox("Do you want to create a rule for " + sSender + "?", vbOKCancel) = vbOK Then
Set oRule = colRules.Create(sSender, olRuleReceive)
'Specify the condition in a ToOrFromRuleCondition object
Set oFromCondition = oRule.Conditions.From
With oFromCondition
.Enabled = True
.Recipients.Add (sSender)
.Recipients.ResolveAll
End With
'Specify the action in a MoveOrCopyRuleAction object
'Action is to move the message to the target folder
Set oMoveRuleAction = oRule.Actions.moveToFolder
With oMoveRuleAction
.Enabled = True
.Folder = oMoveTarget
End With
'Update the server and display progress dialog
colRules.Save
oRule.Execute ShowProgress:=True
End If
Ok, so after much more diggings/trial and error. I found a solution.
The main thing to see is that the type is "AddressRuleCondition" and the property you want to modify is not "Text", but is "Address"
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 oRuleCondition As Outlook.AddressRuleCondition <--------HERE
Dim oExceptSubject As Outlook.TextRuleCondition
Dim oInbox As Outlook.Folder
Dim oMoveTarget As Outlook.Folder
'Specify target folder for rule move action
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
'Assume that target folder already exists
Set oMoveTarget = Application.Session.Folders("myinbox").Folders("Folders").Folders("Reference").Folders("Vendor Marketing")
'Get Rules from Session.DefaultStore object
Set colRules = Application.Session.DefaultStore.GetRules()
Dim sSender As String
For Each objItem In Application.ActiveExplorer.Selection
If objItem.Class = olMail Then
sSender = objItem.SenderEmailAddress
End If
Next
Dim domain() As String
domain = Split(sSender, "#")
Dim dDomain As String
dDomain = "#" + domain(1)
'Create the rule by adding a Receive Rule to Rules collection
If MsgBox("Do you want to create a rule for " + dDomain + "?", vbOKCancel) = vbOK Then
Set oRule = colRules.Create(dDomain, olRuleReceive)
'Specify the condition in a ToOrFromRuleCondition object
'Set oFromCondition = oRule.Conditions.From
'With oFromCondition
'.Enabled = True
'.Recipients.Add (sSender)
'.Recipients.ResolveAll
'End With
Set oRuleCondition = oRule.Conditions.SenderAddress
With oRuleCondition
.Enabled = True
.Address = Array(dDomain) <--------HERE
End With
'Specify the action in a MoveOrCopyRuleAction object
'Action is to move the message to the target folder
Set oMoveRuleAction = oRule.Actions.moveToFolder
With oMoveRuleAction
.Enabled = True
.Folder = oMoveTarget
End With
'Update the server and display progress dialog
colRules.Save
oRule.Execute ShowProgress:=True
End If