I have a shared inbox that has several subfolders.
I want to use the subfolder names as the category for each email inside the relevant subfolder instead of creating a category and a rule for each folder.
As an example, I want to auto categorize the emails in "Support" with "Project A - Support" and the emails in "Project A" with "Project A"
Inbox
Project A
Support
Project B
Project C
Private WithEvents Items As Outlook.Items
Private Const AUTO_CATEGORY As String = "(test)"
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Set Ns = Application.GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
Set Subfolder = Inbox.Folders
Set Items = Subfolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim Cats() As String
Dim i&
Dim Exists As Boolean
If Len(Item.Categories) Then
Cats = Split(Item.Categories, ";")
For i = 0 To UBound(Cats)
If LCase$(Cats(i)) = LCase$(AUTO_CATEGORY) Then
Exists = True
Exit For
End If
Next
If Exists = False Then
Item.Categories = Item.Categories & ";" & AUTO_CATEGORY
Item.Save
End If
Else
Item.Categories = AUTO_CATEGORY
Item.Save
End If
End Sub
ItemAdd is as tedious as rules. You need code for each folder.
Option Explicit
Private WithEvents SubfolderProjectAItems As Items
Private WithEvents SubfolderProjectASupportItems As Items
Private WithEvents SubfolderProjectBItems As Items
Private WithEvents SubfolderProjectCItems As Items
Private Sub Application_Startup()
Dim myInbox As folder
Dim SubfolderProjectA As folder
Dim SubfolderProjectASupport As folder
Dim SubfolderProjectB As folder
Dim SubfolderProjectC As folder
Set Inbox = Session.GetDefaultFolder(olFolderInbox)
Set SubfolderProjectA = Inbox.folders("Project A")
Set SubProjectAItems = SubfolderProjectA.Items
Set SubfolderProjectASupport = SubfolderProjectA.folders("Support")
Set SubfolderProjectASupportItems = SubfolderProjectASupport.Items
Set SubfolderProjectB = Inbox.folders("Project B")
Set SubfolderProjectBItems = SubfolderProjectB.Items
Set SubfolderProjectC = Inbox.folders("Project C")
Set SubfolderProjectCItems = SubfolderProjectC.Items
End Sub
Private Sub testPA()
SubfolderProjectA_ItemAdd ActiveInspector.currentItem
End Sub
Private Sub SubfolderProjectA_ItemAdd(ByVal Item As Object)
Dim catStr As String
catStr = Item.Parent
If InStr(Item.categories, catStr) = 0 Then
Item.categories = Item.categories & ";" & catStr
Item.Save
End If
End Sub
Private Sub testPASupport()
SubfolderProjectASupportItems_ItemAdd ActiveInspector.currentItem
End Sub
Private Sub SubfolderProjectASupportItems_ItemAdd(ByVal Item As Object)
Dim catStr As String
catStr = Item.Parent.Parent & " - " & Item.Parent
If InStr(Item.categories, catStr) = 0 Then
Item.categories = Item.categories & ";" & catStr
Item.Save
End If
End Sub
Related
I want to run code when any new email comes to a specific shared mailbox.
The event triggers when the email comes to INBOX folder.
The event does not trigger if a new email comes straight to its subfolders - like to shared#mailbox.com/Inbox/subfolder1.
What should I change so the code runs if a new email comes to any subfolder in the inbox?
The mailbox has a lot of subfolders. Moreover their structure may change.
Option Explicit
Private WithEvents mtFolder As Outlook.Folder
Private WithEvents mtItems As Outlook.Items
Private Sub mtItems_ItemAdd(ByVal Item As Object)
Debug.Print "XXX"
'my CODE
End Sub
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Dim objOwner
Set objOwner = Ns.CreateRecipient("shared#mailbox.com")
objOwner.Resolve
If objOwner.Resolved Then
Set mtFolder = Ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set mtItems = mtFolder.Items
End If
Set Ns = Nothing
Exit Sub
eh:
End Sub
Thank you a lot for your help! Here the solution.
At first I have added Class Module named "clsFolder" with events:
Option Explicit
Private OlFldr As Folder
Public WithEvents Items As Outlook.Items
'called to set up the object
Public Sub Init(f As Folder) ', sPath As String)
Set OlFldr = f
Set Items = f.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Debug.Print "eMail '" & Item.Subject & "' was added to Folder '" & OlFldr.name & _
"'. Mailbox: '" & Item.Parent.Store & "'."
'do sth with a email added...
End If
End Sub
Then in ThisOutlookSession I setup a collecion of folder for all (sub)folders in the SharedMailbox:
Option Explicit
Public colFolders As Collection '<< holds the clsFolder objects with events
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim oFolder As Outlook.Folder
Set Ns = Application.GetNamespace("MAPI")
Dim objOwner
Set objOwner = Ns.CreateRecipient("my_Shared_Mailibox")
objOwner.Resolve
If objOwner.Resolved Then
Set oFolder = Ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set colFolders = New Collection
processFolder oFolder
End If
Set Ns = Nothing
Set oFolder = Nothing
Exit Sub
eh:
End Sub
'function to create folder objects
Function GetFolderObject(foldr As Folder)
Dim rv As New clsFolder
rv.Init foldr
Set GetFolderObject = rv
End Function
'process all subfolders
Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
colFolders.Add GetFolderObject(oParent)
Dim oMail As Outlook.MailItem
For Each oMail In oParent.Items
'do sth with every email if necessary
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
I am trying to auto forward an email from a specific sender and with a specific subject to a list of new recipients.
When I create a Run a Script Rule, my script is not shown.
Add my script via VBA Editor
Rules > Manage Rules & Alerts > Run a script
Select Run a script action -> Can not Select my script (script not show)
Option Explicit
Public WithEvents objInbox As Outlook.Folder
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInbox.Items
End Sub
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objForward As Outlook.MailItem
Dim xStr1 As String
Dim xStr2 As String
If TypeOf Item Is MailItem Then
Set objMail = Item
If (objMail.SenderEmailAddress = "T#com") And (objMail.Subject = "ZZZZZ") Then
Set objForward = objMail.Forward
GoTo commonOutput
End If
End If
Exit Sub
commonOutput:
With objForward
.HTMLBody = xStr1 & xStr2 & Item.HTMLBody
.Display
End With
Release:
Set myFwd = Nothing
End Sub
VBA script which can be assigned to a rule should have the following signature:
Public Sub Test(item as object)
' your code
End Sub
Your existing code does almost the same without rules. It handles the ItemAdd event for the Inbox folder, so you just need to replace the Display method call with Send:
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objForward As Outlook.MailItem
Dim xStr1 As String
Dim xStr2 As String
If TypeOf Item Is MailItem Then
Set objMail = Item
If (objMail.SenderEmailAddress = "T#com") And (objMail.Subject = "ZZZZZ") Then
Set objForward = objMail.Forward
GoTo commonOutput
End If
End If
Exit Sub
commonOutput:
With objForward
.HTMLBody = xStr1 & xStr2 & Item.HTMLBody
.Send
End With
Release:
Set myFwd = Nothing
End Sub
I have a script that works on my main inbox. It will move the email to a sub folder when a category is assigned. The sub folder is the same name as the category.
How do I modify the code to reference a shared mailbox?
My code that works on main inbox:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
I was able to get it working with the below
Option Explicit
Private WithEvents SharedInboxFld As Outlook.Folder
Private WithEvents SharedInboxItems As Outlook.Items
Private Sub Application_Startup()
Set SharedInboxFld = Outlook.Application.Session.Folders.Item("Shared MailboxName").Folders("Inbox") 'use the appropriate folder name
Set SharedInboxItems = SharedInboxFld.Items
End Sub
Private Sub SharedInboxItems_ItemChange(ByVal Item As Object)
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
xFlag = False
If Item.Categories <> "" Then
Set xFlds = SharedInboxFld.Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = Item.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
SharedInboxFld.Folders.Add Item.Categories, olFolderInbox
End If
Set xTargetFld = SharedInboxFld.Folders(Item.Categories)
Item.Move xTargetFld
End If
End If
End Sub
Instead of GetDefaultFolder, call Outlook.Application.Session.CreateRecipient, and pass the returned Recipient object to GetSharedDefaultFolder.
I want to move emails, once they are categorized, into a folder with the same name as the category.
What I found so far:
Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MAPIFolder
Friend Sub Application_Startup()
On Error Resume Next
Set Explorer = Application.ActiveExplorer
End Sub
Private Sub Explorer_SelectionChange()
Dim obj As Object
Dim Sel As Outlook.Selection
Set Mail = Nothing
Set Sel = Explorer.Selection
If Sel.Count > 0 Then
Set obj = Sel(1)
If TypeOf obj Is Outlook.MailItem Then
Set Mail = obj
End If
End If
End Sub
Private Sub Mail_PropertyChange(ByVal Name As String)
Dim Ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Dim SubfolderName As String
If Name = "Categories" Then
Set Ns = Application.GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
SubfolderName = Mail.Categories
If Len(SubfolderName) = 0 Then Exit Sub
Set Subfolder = Inbox.Folders(SubfolderName)
If Subfolder.EntryID <> Mail.Parent.EntryID Then
Set MoveToThisFolder = Subfolder
EnableTimer 500, Me
End If
End If
End Sub
Friend Sub TimerEvent()
DisableTimer
If Mail Is Nothing Then Exit Sub
If MoveToThisFolder Is Nothing Then Exit Sub
Mail.Move MoveToThisFolder
Set Mail = Nothing
Set MoveToThisFolder = Nothing
End Sub
I have some problems with respect to Friend Sub TimerEvent () because it gives me
Sub or Function not compiled correctly
At the end i figured out in this way:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
Hope it could help!!!
The error is due to missing code for DisableTimer and EnableTimer.
The category has not yet updated when the code is triggered.
EnableTimer delays the move until after the category updates.
Without a delay, there would be an error when attempting to update, due to the item having been moved.
Attribution: http://www.vboffice.net/en/developers/trigger-actions-with-categories/
is there a way Outlook automatically runs a macro whenever I get an email that goes to a specific folder in Outlook (just to clarify, the email goes there because I have set up a rule, so instead of going to my inbox it goes to that folder).
I think I would need code that detects whenever my folder receives an new email and then automatically runs the macro.
My code is the following, I execute test, which executes SaveEmailAttachmentsToFolder.
Sub Test()
'Arg 1 = Folder name of folder inside your Inbox 'Arg 2 = File extension, "" is every file 'Arg 3 = Save folder, "C:\Users\Ron\test" or "" ' If you use "" it will create a date/time stamped folder for you in your "Documents" folder ' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "Dependencia Financiera", "xls", "V:\Dependencia Financiera\Dependencia Financiera\"
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _ ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As Folder
Dim SubFolder As Folder
Dim subFolderItems As Items
Dim Atmt As Attachment
Dim FileName As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
Set subFolderItems = SubFolder.Items
If subFolderItems.Count > 0 Then
subFolderItems.Sort "[ReceivedTime]", True
For Each Atmt In subFolderItems(1).Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
End If
' Clear memory ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set subFolderItems = Nothing
End Sub
seulberg1 told me to use the follwing code how, should my paste my own code since, it has 2 Subs.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup() Dim olApp As Outlook.Application
Set olApp = Outlook.Application Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Add your code here
ProgramExit: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ProgramExit End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace Set GetNS = app.GetNamespace("MAPI") End Function
Thanks you in advance !!!
This code (adapted from Jimmy Pena) should do the trick.
It initiates the event listener on Outlook startup and checks the folder "Your Folder Name" for new emails. It then performs a designatable action at the ("Add your code here") section.
Let me know if this helps
Best regards
seulberg1
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
**'Add your code here**
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function