Move mail to folder from button on ribbon - vba

I have a macro that will run perfectly using F8 to step through it but will skip the last step, to move an email, when run from a button on the ribbon.
Here is the code.
Sub Reportmail()
'Declare Variables
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim objDestFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem
Dim Move As Outlook.MailItem
Dim selEmail As Outlook.MailItem
Dim moveToFolder As Outlook.MAPIFolder
Dim MItem As MailItem
'Append subject & Move
For Each MItem In ActiveExplorer.Selection
MItem.Subject = "Suspicious Email: " & MItem.Subject
Next
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
On Error GoTo xyz
Set myNewFolder = olFolder.Folders.Add("Suspicious Items")
xyz:
Set olFolder = olFolder.Folders("Suspicious Items")
Set objNS = Application.GetNamespace("MAPI")
'Set folder to move suspicious email into
Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Suspicious Items")
'SET Task
Set selEmail = ActiveExplorer.Selection.Item(1).Forward
'Set Recipient
selEmail.Recipients.Add "myemail#mydonain.com"
'Send Email
selEmail.Send
'Move email to folder
ActiveExplorer.Selection.Item(1).Move objDestFolder
End Sub

You can debug the problem by adding error trapping and examining the error message and the variables' values at the time of the error by adding:
On Error GoTo oops
{your code}
finish:
On Error GoTo 0
Exit Sub
oops:
Debug.Print Err.Number;Err.Description
Debug.Assert False
Resume finish
End Sub

Figured I'd show what I tried to explain in my comment to your question:
'Set olApp = Outlook.Application
'Set objNS = olApp.GetNamespace("MAPI")
'Set objNS = Outlook.Application.GetNamespace("MAPI")
'****I'd prefer condensing above to the following since olApp, objNS not used again
Set olFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
On Error Resume Next '<-****my personal preference, part 1
Set olFolder = olFolder.Folders("Suspicious Items")
On Error GoTo 0 '<--- updated per comments
'xyz: <-****my personal preference, part 2. Nothing "wrong" with how you wrote it.
If olFolder.Name = "Inbox" Then Set olFolder = olFolder.Add("Suspicious Items")
'****objNS and olFolder already defined!! No need to set 2 objects to same folder.
'Set objNS = Application.GetNamespace("MAPI")
'Set folder to move suspicious email into
'Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Suspicious Items")
'SET Task
'Append subject & Move
For Each MItem In ActiveExplorer.Selection
MItem.Subject = "Suspicious Email: " & MItem.Subject
Set selEmail = MItem.Forward
'Set Recipient
selEmail.Recipients.Add "myemail#mydonain.com"
'Send Email
selEmail.Send
'Move email to folder
'MItem.Move objDestFolder
MItem.Move olFolder
Next

Related

How to setup VBscript to run in a specific folder in Outlook [duplicate]

How can I in an Outlook VBA macro iterate all email items in a specific Outlook folder (in this case the folder belongs not to my personal inbux but is a sub-folder to the inbox of a shared mailbox.
Something like this but I've never done an Outlook macro...
For each email item in mailboxX.inbox.mySubfolder.items
// do this
next item
I tried this but the inbox subfolder is not found...
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("myGroupMailbox")
Set objFolder = objFolder.Folders("Inbox\mySubFolder1\mySubFolder2")
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If new_msg.Subject Like "*myString*" Then
strBody = myItem.Body
Dim filePath As String
filePath = "C:\myFolder\test.txt"
Open filePath For Output As #2
Write #2, strBody
Close #2
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
Next Item
End Sub
In my case the following worked:
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Likewise, you can as well iterate through calender items:
Private Sub ListCalendarItems()
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olRecItems = olNS.GetDefaultFolder(olFolderTasks)
strFilter = "[DueDate] > '1/15/2009'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
For Each Item In olFilterRecItems
If TypeName(Item) = "TaskItem" Then
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Note that this example is using filtering and also .GetDefaultFolder(olFolderTasks) to get the builtin folder for calendar items. If you want to access the inbox, for example, use olFolderInbox.
The format is:
Set objFolder = objFolder.Folders("Inbox").Folders("mySubFolder1").Folders("mySubFolder2")
As advised in a comment "move the next item line to before the ProgramExit label"
Sub TheSub()
Dim objNS As Outlook.NameSpace
Dim fldrImAfter As Outlook.Folder
Dim Message As Outlook.MailItem
'This gets a handle on your mailbox
Set objNS = GetNamespace("MAPI")
'Calls fldrGetFolder function to return desired folder object
Set fldrImAfter = fldrGetFolder("Folder Name Here", objNS.Folders)
For Each Message In fldrImAfter.Items
MsgBox Message.Subject
Next
End Sub
Recursive function to loop over all folders until the specified folder name is found....
Function fldrGetFolder( _
strFolderName As String _
, objParentFolderCollection As Outlook.Folders _
) As Outlook.Folder
Dim fldrSubFolder As Outlook.Folder
For Each fldrGetFolder In objParentFolderCollection
'MsgBox fldrGetFolder.Name
If fldrGetFolder.Name = strFolderName Then
Exit For
End If
If fldrGetFolder.Folders.Count > 0 Then
Set fldrSubFolder = fldrGetFolder(strFolderName,
fldrGetFolder.Folders)
If Not fldrSubFolder Is Nothing Then
Set fldrGetFolder = fldrSubFolder
Exit For
End If
End If
Next
End Function

Create a folder based on domain and in that folder create a folder based on sender name

I want a macro/rule/code that creates a folder in Outlook based on the sender's domain, after that I want it to create a folder based on the sender's name in the sender's domain folder, and then move the mail to that folder.
I am thinking of a folder layout like this:
Inbox\#senders domain\#Senders name\Email.msg
Please refer to this code, however, you may need to change something as your special request.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
' set object reference to default Inbox
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)
' fires when new item added to default Inbox
' (per Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
' don't do anything for non-Mailitems
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
Set Msg = item
' move received email to target folder based on sender name
senderName = Msg.senderName
If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = _
objNS.GetDefaultFolder(olFolderInbox).Folders(senderName)
End If
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error Goto 0
If Not FolderTocheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
More information, please see,
Create new folder for new sender name and move message into new folder

Code in Application_Quit() not Running (Outlook)

I've added some VBA code to my outlook application to run some clean-up when I close the program. Specifically, I delete any notification emails automatically generated by my test environment at work.
Then I try to empty my junk folder, mark emails in a specific folder as read, and then permanently delete all the items from my "Deleted Items" folder. Here is the code:
Private Sub Application_Quit()
On Error Resume Next
Call delete_LV_emails
Call mark_JIRA_read
Call empty_junk
Call empty_deleted
End Sub
The subs that I am calling are in a module named "Cleanup", and I know they all work when I run them on their own. However, only the "delete_LV_emails" sub gets called. That is, when I close/re-open outlook. The only thing that has occurred is that the automatically generated emails are moved to the "Deleted Items" folder. I can't figure out why only one of the subs is being called.
If it matters, the code for each of the subs is below:
Sub delete_LV_emails()
On Error Resume Next
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItem As Object
Dim arrKeys(0 To 1) As String
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox)
arrKeys(0) = "LabVIEW Error"
arrKeys(1) = "Test Complete"
iItemCount = olFolder.Items.Count
sDate = Split(Str(Now), " ")(0)
For iItemInd = iItemCount To 1 Step -1
Set olItem = olFolder.Items(iItemInd)
If Not Split(Str(olItem.CreationTime), " ")(0) = sDate Then GoTo NEXTITEM
iKeyInd = 0
While Not iKeyInd > 1
If InStr(olItem.Subject, arrKeys(iKeyInd)) Then olItem.Delete
iKeyInd = iKeyInd + 1
Wend
NEXTITEM:
Next
Set olNS = Nothing
Set olFolder = Nothing
Set olItem = Nothing
End Sub
Sub empty_deleted()
On Error Resume Next
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItem As Object
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderDeletedItems)
iItemCount = olFolder.Items.Count
For iItemInd = iItemCount To 1 Step -1
Set olItem = olFolder.Items(iItemInd)
olItem.Delete
Next
Set olNS = Nothing
Set olFolder = Nothing
Set olItem = Nothing
End Sub
Sub empty_junk()
On Error Resume Next
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItem As Object
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderJunk)
iItemCount = olFolder.Items.Count
For iItemInd = iItemCount To 1 Step -1
Set olItem = olFolder.Items(iItemInd)
olItem.Delete
Next
Set olNS = Nothing
Set olFolder = Nothing
Set olItem = Nothing
End Sub
Sub mark_JIRA_read()
On Error Resume Next
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItem As Object
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Jira")
iItemCount = olFolder.Items.Count
For iItemInd = iItemCount To 1 Step -1
Set olItem = olFolder.Items(iItemInd)
If olItem.UnRead Then olItem.UnRead = False
Next
Set olNS = Nothing
Set olFolder = Nothing
Set olItem = Nothing
End Sub
I realize that this is an extremely long-winded question, but if anyone has any insight I would greatly appreciate it.
Remove On Error Resume Next from your code then run it again
On Error Resume Next you are basically instructing VBA to essentially ignore the error and resume execution on the next line of code.
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 occurred.
See more info on
http://www.cpearson.com/excel/ErrorHandling.htm
The latest versions of Outlook do not call the Quit event handler. They do not pass Go and do not collect $200 - they just quit.
You can watch the Explorer.Close and Inspector.Close events - if there is only one Explorer or Inspector left (as reported by Application.Explorers.Count and Application.Inspectors.Count), Outlook is closing.

Unable to forward an email due to run-time error '287'

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "Greetings") > 0 Then
senderemail = myitem.Sender.GetExchangeUser.PrimarySmtpAddress
If senderemail = "abc#xyz.com" Then
Set oMail = myitem.Forward
oMail.Recipients.Add "i#me.com"
oMail.HTMLBody = "Hi"
oMail.Display
End If
End If
End If
Next myitem
My code use to run properly a few weeks back. Today I ran again and debugging it I see that once it comes to Set oMail = myitem.Forward I get an outlook window open and an Run-time error saying Application-defined or object-defined error.
How can I get the forward email and error at the same time? First I use to get the outlook window only after the display command. Also due to this I am not able to execute the next lines of code in my forward email.
Edit:
Also now I see that directly displaying the email does not give any error, but once I use .Forward command this is when error comes.
Few Errors in your code, so I clean it up and added more code - Try it and let me know.
Option Explicit
Sub olForward()
Dim olApp As Outlook.Application
Dim olFolder As Outlook.MAPIFolder
Dim olInbox As Outlook.MAPIFolder
Dim olNameSpace As Outlook.NameSpace
Dim olItem As Outlook.MailItem
Dim olSender As String
Set olApp = New Outlook.Application
Set olNameSpace = Application.GetNamespace("MAPI")
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
'// Require this procedure be called only when a message is selected
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each olItem In Application.ActiveExplorer.Selection
If olItem.class = olMail Then
If InStr(1, olItem.Subject, "Greetings") > 0 Then
olSender = olItem.SenderEmailAddress
If olSender = "abc#xyz.com" Then
Set olItem = olItem.Forward
olItem.Recipients.Add "Om3r <i#me.com>"
olItem.HTMLBody = "Hi" + olItem.HTMLBody
olItem.Display
End If
End If
End If
Next
End Sub

Iterate all email items in a specific Outlook folder

How can I in an Outlook VBA macro iterate all email items in a specific Outlook folder (in this case the folder belongs not to my personal inbux but is a sub-folder to the inbox of a shared mailbox.
Something like this but I've never done an Outlook macro...
For each email item in mailboxX.inbox.mySubfolder.items
// do this
next item
I tried this but the inbox subfolder is not found...
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("myGroupMailbox")
Set objFolder = objFolder.Folders("Inbox\mySubFolder1\mySubFolder2")
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If new_msg.Subject Like "*myString*" Then
strBody = myItem.Body
Dim filePath As String
filePath = "C:\myFolder\test.txt"
Open filePath For Output As #2
Write #2, strBody
Close #2
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
Next Item
End Sub
In my case the following worked:
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Likewise, you can as well iterate through calender items:
Private Sub ListCalendarItems()
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olRecItems = olNS.GetDefaultFolder(olFolderTasks)
strFilter = "[DueDate] > '1/15/2009'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
For Each Item In olFilterRecItems
If TypeName(Item) = "TaskItem" Then
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Note that this example is using filtering and also .GetDefaultFolder(olFolderTasks) to get the builtin folder for calendar items. If you want to access the inbox, for example, use olFolderInbox.
The format is:
Set objFolder = objFolder.Folders("Inbox").Folders("mySubFolder1").Folders("mySubFolder2")
As advised in a comment "move the next item line to before the ProgramExit label"
Sub TheSub()
Dim objNS As Outlook.NameSpace
Dim fldrImAfter As Outlook.Folder
Dim Message As Outlook.MailItem
'This gets a handle on your mailbox
Set objNS = GetNamespace("MAPI")
'Calls fldrGetFolder function to return desired folder object
Set fldrImAfter = fldrGetFolder("Folder Name Here", objNS.Folders)
For Each Message In fldrImAfter.Items
MsgBox Message.Subject
Next
End Sub
Recursive function to loop over all folders until the specified folder name is found....
Function fldrGetFolder( _
strFolderName As String _
, objParentFolderCollection As Outlook.Folders _
) As Outlook.Folder
Dim fldrSubFolder As Outlook.Folder
For Each fldrGetFolder In objParentFolderCollection
'MsgBox fldrGetFolder.Name
If fldrGetFolder.Name = strFolderName Then
Exit For
End If
If fldrGetFolder.Folders.Count > 0 Then
Set fldrSubFolder = fldrGetFolder(strFolderName,
fldrGetFolder.Folders)
If Not fldrSubFolder Is Nothing Then
Set fldrGetFolder = fldrSubFolder
Exit For
End If
End If
Next
End Function