Save attachment in Outlook using VBA on secondary Inbox - vba

I have been trying to get below to trigger on a shared inbox.
I can get this working fine using a script I call manually with a for loop on the Inbox.
I can also get this working using my main inbox using the Session.GetDefaultFolder(olFolderInbox).Items.
Any help on where I am going wrong?
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim ns As NameSpace
Dim olInboxItems As MAPIFolder
Set ns = Application.GetNamespace("MAPI")
Set objOwner = ns.CreateRecipient("xx#xx.com")
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Debug.Print ns
Debug.Print objOwner
Debug.Print olInboxItems
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
Dim olMailItem As MailItem
Dim strAttachmentName As String
'
' Only inspect mail items
' Ignore appointments, meetings, tasks, etc.
'
If TypeOf Item Is MailItem Then
Debug.Print MailItem
Set olMailItem = Item
If olMailItem.Attachments.Count = 1 Then
strAttachmentName = olMailItem.Attachments.Item(1).FileName
olMailItem.Attachments.Item(1).SaveAsFile "C:\EmailAttachments\" + strAttachmentName
End If
End If
Set Item = Nothing
Set olMailItem = Nothing
End Sub


You declare the variable as Items, but you assign it to an instance of the MAPIFolder object.
Change that code to
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox).Items


Dmitry identified the problem - Contradictory declarations.
The underlying issue is the misuse of
On Error Resume Next
" It is very important to remember that On Error Resume Next does not in any way "fix" the error. It simply instructs VBA to continue as if no error occured."
and the non-use of
Option Explicit
You might have found.
Dim olInboxItems As Items
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox).Items
rather than
Dim olInboxItems As MAPIfolder


Or you could do it this way-
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim ns As NameSpace
Dim olInboxItems As MAPIFolder
Dim objOwner As Outlook.Recipient
Set ns = Application.GetNamespace("MAPI")
Set objOwner = ns.CreateRecipient("xx#xx.com")
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Items = olInboxItems.Items
'Debug.Print ns
'Debug.Print objOwner
'Debug.Print olInboxItems
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
SaveAttachment Item
End If
End Sub
Private Sub SaveAttachment(olMailItem As Outlook.MailItem)
Dim strAttachmentName As String
'
' Only inspect mail items
' Ignore appointments, meetings, tasks, etc.
'
'Debug.Print MailItem
If olMailItem.Attachments.Count = 1 Then
strAttachmentName = olMailItem.Attachments.Item(1).FileName
olMailItem.Attachments.Item(1).SaveAsFile "C:\EmailAttachments\" + strAttachmentName
End If
Set olMailItem = Nothing
End Sub

Related

Run code when new email comes to any subfolder in a Shared Mailbox

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

Runtime error "-2147024809" Moving Sent Mails To SentMail-Folder of secondary account

I have two accounts open in Outlook.
When I send a Mail via the secondary account it appears in the sent folder of the primary account.
I want to move the sent mail to the sent folder of the secondary account whenever I send mail.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Folder As Outlook.Folder
If TypeName(Item) = "MailItem" Then
If Item.SenderName = "MY SECONDARY EMAIL" Then
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Dim newFolder As Outlook.Folder
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("mysecondary#email.de")
objOwner.Resolve
If objOwner.Resolved Then
Set newFolder = NS.GetSharedDefaultFolder(objOwner, olFolderSentMail)
MsgBox (newFolder)
Item.Move newFolder
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
I get this Error message:
-2147024809 - Unfortunately there is a problem. You can try again
It shows that the line Set newFolder = NS.GetSharedDefaultFolder(objOwner, olFolderSentMail) is causing this problem.

The error is MAPI_E_INVALID_PARAMETER. Most likely that means the specified mailbox is not an Exchange mailbox or it belongs to a different Exchange org.
If that mailbox is already opened in the current profile, you can access that Store object (and use Store.GetDefaultFolder) from the Namespace.Stores collection.

Dmitry Streblechenko's answer worked!
Here is how I did it if anyone got the same problem:
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Sub inboxItems_ItemAdd(ByVal Item As Object)
If TypeName(Item) = "MailItem" Then
If Item.SenderName = "SENDERNAME" Then
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Dim newFolder As Outlook.Folder
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oRoot As Outlook.Folder
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("secondary#email.de")
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oRoot = oStore.GetRootFolder
If oStore = "SECONDARY EMAIL NAME" Then
Call EnumerateFolders(oRoot, Item)
End If
Next
End If
End If
End Sub
Sub EnumerateFolders(ByVal oFolder As Outlook.Folder, Item)
Dim folders As Outlook.folders
Dim Folder As Outlook.Folder
Dim foldercount As Integer
Set folders = oFolder.folders
foldercount = folders.Count
For Each Folder In folders
If Folder.FolderPath = "\\SECONDARY EMAIL NAME\Sent Items" Then
Item.Move Folder
End If
Next
End Sub

How to delete old emails when a new email with the same subject is being received

I'm Having trouble deleting Emails with same subject line but keeping the newly received Email on Outlook-vba
Does anyone have any ideas on how to do that?

You can work with Dictionary Object to Store Items.Subject while you measure the received Item.ReceivedTime with Item.ReceivedTime in your Inbox.Items
Dictionary in VBA is a collection-object:
you can store all kinds of things in it: numbers, texts, dates, arrays, ranges, variables and objects, Every item in a Dictionary gets its own unique key and
With that key you can get direct access to the item (reading/writing).
Now to Automate the process - Try working with Application.Startup Event (Outlook) And Items_ItemAdd Event (Outlook)
Items.ItemAdd Event Occurs when one or more Items are added to the specified collection. This event does not run when a large number of items are added to the folder at once.
Code Example
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
RemoveDupEmails Item ' call sub
End If
End Sub
Private Sub RemoveDupEmails(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim DupItem As Object
Dim Items As Outlook.Items
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
Debug.Print Item.ReceivedTime ' Immediate Window
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = Inbox.Items
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Set Item = Items(i)
If Item.ReceivedTime >= Items(i).ReceivedTime Then
If DupItem.Exists(Item.Subject) Then
Debug.Print Item.Subject ' Immediate Window
'Item.Delete ' UnComment to delete Item
Else
DupItem.Add Item.Subject, 0
End If
End If
End If
Next i
Set olNs = Nothing
Set Inbox = Nothing
Set DupItem = Nothing
Set Items = Nothing
End Sub

Shared Mailbox Management

I need a macro that will move messages received into a shared mailbox to a subfolder of that mailbox, depending on the sender's email address, basically a normal outlook rule.
I've been looking at some articles on http://www.slipstick.com/ which has got me part way there but there isn't an exact solution for what I want to do and I'm not proficient enough with VBA in Outlook yet to work it out.
So far I've got this code on ThisOutlookSession to watch the mailbox:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
End Sub
And this function in a module to obtain the path of the watched mailbox folder:
' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
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

This works, I used a case to move the item if it came from a specific email address:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
For Each Item In olInboxItems
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim objDestFolder As Outlook.MAPIFolder
Dim destFolder As String
Dim sendersAddress As String
If Item.Class = olMail Then
sendersAddress = Item.SenderEmailAddress
Select Case sendersAddress
Case "no-reply#omniture.com"
destFolder = ">Digital Analytics\Inbox\Reports"
Case "no-reply#edigitalresearch.com"
destFolder = ">Digital Analytics\Inbox\Reports"
End Select
Set objDestFolder = GetFolderPath(destFolder)
Item.Move objDestFolder
End If
End Sub

get outlook to fire vba script on old emails

I have wrote some vba in outlook that fires when a new email comes in. However I want to fire it on an old email for testing. Can anyone tell me how.
my current code is
Private Sub objInbox_ItemAdd(ByVal Item As Object)
Thanks

I've sorted it thanks.
Private Sub Application_Startup()
Set objInbox = Session.GetDefaultFolder(olFolderInbox).Items
'Call test
'MsgBox "outlook starting"
End Sub
Sub test()
MsgBox "in test"
Dim ns As NameSpace
Dim item As Object
Dim inbox As MAPIFolder
'Dim sub_folder As MAPIFolder
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
'Set sub_folder = inbox.Folders("TEST")
For Each item In inbox.Items
If TypeOf item Is MailItem Then
MsgBox "right subject"
End If
Next item
End Sub