Outlook program to move Attachments to SubFolder - vb.net

I have written this small program in VS2010 to run on Outlook 2007.
It works for a standard read through of the Inbox, but I cannot get it to correctly point to other Folders, I am getting a "COMException was unhandled by user code" error that says "The operation failed. An object could not be found." ...
I have included a screenshot of my Outlook structure if it helps ...
Imports Microsoft.Office.Interop
Public Class ThisAddIn
Private Sub ThisAddIn_Startup() Handles Me.Startup
End Sub
Private Sub ThisAddIn_Shutdown() Handles Me.Shutdown
End Sub
Private Sub Application_Startup() Handles Application.Startup
Dim MyApp As Outlook.Application = New Outlook.Application
Dim MyNS As Outlook.NameSpace = MyApp.GetNamespace("MAPI")
Dim MyInbox As Outlook.MAPIFolder = MyNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
Dim MyEmails As Integer = MyInbox.Items.Count
Dim MyEMail As Outlook.MailItem
Dim MyCount As Integer
Dim MySubFolder As Outlook.MAPIFolder = MyNS.Folders("Kickabout") **<<< Error occurs here**
For MyCount = MyEmails To 1 Step -1
MyEMail = MyInbox.Items(MyCount)
If MyEMail.SenderEmailAddress = "MrX#abc.com" Then
If MyEMail.Attachments.Count > 0 Then
MySubFolder = MyNS.Folders("Kickabout\Attachments")
End If
MyEMail.Move(MySubFolder)
End If
Next
End Sub
End Class

OK, I have solved this myself ... if anybody is interested in the future, you have to be quite explicit in setting up the path & need a Function to do so, here is the code ...
Imports Microsoft.Office.Interop
Public Class ThisAddIn
Dim strFolderPath As String
Private Sub ThisAddIn_Startup() Handles Me.Startup
End Sub
Private Sub ThisAddIn_Shutdown() Handles Me.Shutdown
End Sub
Private Sub Application_Startup() Handles Application.Startup
Dim MyApp As Outlook.Application = New Outlook.Application
Dim MyNS As Outlook.NameSpace = MyApp.GetNamespace("MAPI")
Dim MyInbox As Outlook.MAPIFolder = MyNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
Dim MyEmails As Integer = MyInbox.Items.Count
Dim MyEMail As Outlook.MailItem
Dim MyCount As Integer
Dim MySubFolder As Outlook.Folder = GetMyFolder("Outlook (Gary)\Kickabout")
Stop
For MyCount = MyEmails To 1 Step -1
MyEMail = MyInbox.Items(MyCount)
If MyEMail.SenderEmailAddress = "MrX#abc.com" Then
If MyEMail.Attachments.Count > 0 Then
MySubFolder = GetMyFolder("Outlook (Gary)\Kickabout\Attachments")
End If
MyEMail.Move(MySubFolder)
End If
Next
End Sub
Function GetMyFolder(FolderPath)
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim aFolders
Dim fldr
Dim i
Dim objNS
On Error Resume Next
strFolderPath = Replace(FolderPath, "/", "\")
aFolders = Split(FolderPath, "\")
'get the Outlook objects
' use intrinsic Application object in form script
objNS = Application.GetNamespace("MAPI")
'set the root folder
fldr = objNS.Folders(aFolders(0))
'loop through the array to get the subfolder
'loop is skipped when there is only one element in the array
For i = 1 To UBound(aFolders)
fldr = fldr.Folders(aFolders(i))
'check for errors
'If Err() <> 0 Then Exit Function
Next
GetMyFolder = fldr
' dereference objects
objNS = Nothing
End Function
End Class

Related

Move Shared Mailbox Email To Folder When Category Assigned

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.

Move email after being categorized

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/

Auto saving Outlook attachments VBA

I've been playing around with the below code in an attempt to save files which we receive daily in Outlook. The code seems to run fine, however, when I go to check the destination folder there are no attachments saved.
How can I modify the code to save the attachments to the specified folder?
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 = "made-up-email#some_domain.com") And _
(Msg.Subject = "Test") 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 = "T:\London File3 Group\Client Reporting\Test"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
End Sub
This code should work, something you may not have done is added this to the ThisOutlookSession object. Don't add to a standard module.
Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\"
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
Set InboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub InboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem: Set Msg = Item
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Filename As String
If Not TypeName(Msg) = "MailItem" Then Exit Sub
If (Msg.SenderName = "made-up-email#some_domain.com") And (Msg.Subject = "Test") And (Msg.Attachments.Count >= 1) Then
Set myAttachments = Item.Attachments
Filename = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Filename
Msg.UnRead = False
End If
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

VBA outlook 2010 move

m.display works but m.move(A) does not.
The folder exist.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim myInbox As Outlook.Folder
Dim A As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox =
myNameSpace.GetDefaultFolder(olFolderInbox)
Set A = myInbox.Folders("A")
Dim i As Integer
Dim m As MailItem
On Error Resume Next
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set m = Application.Session.GetItemFromID(arr(i))
If m.SenderEmailAddress = "notifications#transcore.com" Then
'MsgBox (m.Body)
m.Display
m.Move (A)
End If
Next
End Sub
Move is a function, not a sub. Move the message first, then display it:
set m = m.Move(A)
m.Display