I have some code to "move" an email to a specific Outlook folder when tagged with a specific category, however now I need to copy instead of sending the email to a specific folder for just one of the If statements. It is the one that references: "PO Send to Kathy".
'Occurs when changing item
Private Sub objInboxItemsOrder_ItemChange(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objTargetFolder As Outlook.Folder
If TypeOf Item Is MailItem Then
Set objMail = Item
'Move mails based on color category
If InStr(objMail.Categories, "Karen") > 0 Then
Set objTargetFolder = Application.Session.Folders("orders#xxx.com").Folders("Karen")
objMail.Move objTargetFolder
ElseIf InStr(objMail.Categories, "PO Send to Kathy") > 0 Then
Set objTargetFolder = Application.Session.Folders("orders#xxx.com").Folders("PO Send to Kathy")
objMail.Move objTargetFolder
ElseIf InStr(objMail.Categories, "Quote") > 0 Then
Set objTargetFolder = Application.Session.Folders("orders#xxxx.com").Folders("Quote")
objMail.Move objTargetFolder
ElseIf InStr(objMail.Categories, "PO Keep Here") > 0 Then
Set objTargetFolder = Application.Session.Folders("orders#xxx.com").Folders("Purchase Order")
objMail.Move objTargetFolder
End If
End If
End Sub
Related
I've New Ticket folder, once replied from the New Ticket folder mails have to be moved to Completed folder.
Getting error message
This method can't be used in an inline response mail item.
at olMail.Move olDestFolder ' move to InProgress folder.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olNameSpace As Outlook.NameSpace
Set olNameSpace = GetNamespace("MAPI")
Dim olDestFolder As Outlook.Folder
Set olDestFolder = olNameSpace.Folders("xxx#xxx.com").Folders("In Progress")
Dim olLookUpFolder As Outlook.Folder
Set olLookUpFolder = olNameSpace.Folders("xxx#xxx.com").Folders("Tickets")
Dim olMail As Outlook.MailItem
For Each olMail In olLookUpFolder.Items 'loop through Tickets folder to find original mail
If InStr(1, olMail.Subject, strTicket) > 0 Then 'look for unique ticket Id
olMail.Move olDestFolder ' move to InProgress folder
Exit For
End If
Next
End Sub
From the comment "strTicket- to read the subject line and see if the particular subject line as a response".
You need strTicket = "text based on Item.Subject" for
If InStr(1, olMail.Subject, strTicket) > 0
For example:
Item.Subject "Re: Ticket #123456"
strTicket would be 123456.
If InStr(1, olMail.Subject, strTicket) > 0 Then 'look for unique ticket Id in olLookUpFolder.Items
There is no need to extract the unique ticket Id. olMail.Subject is unique and will be in Item.Subject.
If Item.Subject is "Re: Ticket #123456"
then olMail.Subject is "Ticket #123456"
Reverse the order of the search terms in InStr.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olNameSpace As NameSpace
Set olNameSpace = GetNamespace("MAPI")
Dim olDestFolder As folder
Set olDestFolder = olNameSpace.Folders("xxx#xxx.com").Folders("In Progress")
Dim olLookUpFolder As folder
Set olLookUpFolder = olNameSpace.Folders("xxx#xxx.com").Folders("Tickets")
' olMail is a Class. Avoid as a variable name
'Dim olMail As MailItem
Dim olObj As Object ' Outlook items are not necessarily mailitems
For Each olObj In olLookUpFolder.Items 'loop through Tickets folder to find original mail
If olObj.Class = olMail Then
If InStr(1, Item.Subject, olObj.Subject) > 0 Then 'look for olObj.Subject in Item.Subject
olObj.Move olDestFolder ' move to InProgress folder
Exit For
End If
End If
Next
End Sub
If the preview pane is on then
Error: "This method can't be used with an inline response mail item."
This code restarted Outlook and disabled VBA the first time. Subsequently it only restarted Outlook. If you get similar results you may decide to turn off the preview pane yourself so the preview pane check is not invoked.
If InStr(1, Item.Subject, olObj.Subject) > 0 Then 'look for olObj.Subject in Item.Subject
If ActiveExplorer.IsPaneVisible(olPreview) = True Then
' Hide Preview Pane
' https://learn.microsoft.com/en-us/office/vba/api/outlook.explorer.ispanevisible
ActiveExplorer.ShowPane olPreview, False
olObj.Move olDestFolder ' move to InProgress folder
' Show Preview Pane
ActiveExplorer.ShowPane olPreview, True
Else
olObj.Move olDestFolder ' move to InProgress folder
End If
Exit For
End If
More information about the error related to inline response.
I'm trying to move emails from Inprogress Folder to Completed Folder, based on the word placed in the body of the mail when replied to.
if the reply mail has the word Completed then the reply mails have to be moved to Completed Folder.
if the reply mail has the word Cancelled then the reply mails have to be moved to Cancelled Folder.
I tried the below code, but it throws
Compile Error: Excepted expression
Error is because of this two-line.
If InStr(1,olMail.Body, "Completed") And
If InStr(1, Item.Subject, olObj.Subject) > 0
Full Code:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olNameSpace As NameSpace
Set olNameSpace = GetNamespace("MAPI")
Dim olDestFolder As folder
Set olDestFolder = olNameSpace.Folders("xxx#xxx.com").Folders("Completed")
Dim olLookUpFolder As folder
Set olLookUpFolder = olNameSpace.Folders("xxx#xxx.com").Folders("InProgress")
' olMail is a Class. Avoid as a variable name
'Dim olMail As MailItem
Dim olObj As Object ' Outlook items are not necessarily mailitems
For Each olObj In olLookUpFolder.Items 'loop through Tickets folder to find original mail
If olObj.Class = olMail Then
If InStr(1,olMail.Body, "Completed") And
If InStr(1, Item.Subject, olObj.Subject) > 0 Then 'look for olObj.Subject in Item.Subject
olObj.Move olDestFolder ' move to InProgress folder
Exit For
End If
End If
Next
End Sub
You wanted to write
If InStr(1,olMail.Body, "Completed") > 0 And InStr(1, Item.Subject, olObj.Subject) > 0 Then 'look for olObj.Subject in Item.Subject
olObj.Move olDestFolder ' move to InProgress folder
Exit For
End If
I have code that moves an email to a folder and mark it as read when I assign a category to the email.
The code actually works, in that it does what I want it to do, with the exception of throwing this error.
When I debug it shows the following
Private WithEvents objInboxFolder As Outlook.Folder
Private WithEvents objInboxItems As Outlook.Items
'Process inbox mails
Private Sub Application_Startup()
Set objInboxFolder = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInboxFolder.Items
End Sub
'Occurs when changing item
Private Sub objInboxItems_ItemChange(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objTargetFolder As Outlook.Folder
If TypeOf Item Is MailItem And Item.Categories <> "" Then
Set objMail = Item
'Move mails based on color category
If InStr(objMail.Categories, "Personal") > 0 Then
Set objTargetFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Personal")
objMail.Move objTargetFolder
Else
objMail.UnRead = False
objMail.Save
Set objTargetFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("01 Actioned")
objMail.Move objTargetFolder
End If
End If
End Sub
Consider If TypeOf Item Is MailItem And Item.Categories <> "".
VBA evaluates every term of a Boolean expression before combining them to get the final result. It does not check TypeOf Item Is MailItem and only continue if Item is a MailItem. If Item is not a MailItem, Item.Categories will fail.
Try:
If TypeOf Item Is MailItem Then
If Item.Categories <> ""
. . . .
End If
End If
I want to download all attachments of Unread emails from my MS Outlook. I found this below mentioned code on StackExchange which downloads attachments from first Unread email.
Can any one modify this code so i can apply it on all Unread emails.
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\"
Sub DownloadAttachmentFirstUnreadEmail()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object
'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = AttachmentPath & Format(Date, "DD-MM-YYYY") & "-"
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Exit Sub
End If
'~~> Extract the attachment from the 1st unread email
For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
'~~> Check if the email actually has an attachment
If oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
'~~> Download the attachment
oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
Exit For
Next
Else
MsgBox "The First item doesn't have an attachment"
End If
Exit For
Next
End Sub
When using Items.Restrict Method (Outlook) you may want to set the Filter for both Attachment and UnRead Items, Filter = "[attachment] = True And [Unread] = True" then use a For...Next and loop backwards
Example:
Option Explicit
Public Sub Example()
'// Declare your Variables
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Outlook.MailItem
Dim Atmt As Attachment
Dim Filter As String
Dim FilePath As String
Dim AtmtName As String
Dim i As Long
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
FilePath = "C:\Temp\"
Filter = "[attachment] = True And [Unread] = True"
Set Items = Inbox.Items.Restrict(Filter)
'// Loop through backwards
For i = Items.Count To 1 Step -1
Set Item = Items(i)
DoEvents
If Item.Class = olMail Then
Debug.Print Item.Subject ' Immediate Window
For Each Atmt In Item.Attachments
AtmtName = FilePath & Atmt.FileName
Atmt.SaveAsFile AtmtName
Next
End If
Next
Set Inbox = Nothing
Set Items = Nothing
Set Item = Nothing
Set Atmt = Nothing
Set olNs = Nothing
End Sub
Much cleaner, batter & faster...
I have VBA code that auto forwards all emails to an external account. I can't get the macro to show up in the Macro menu when I click F5 to run it.
Sub AutoForwardAllSentItemsss(Item As Outlook.MailItem)
Dim strMsg As String
Dim autoFwd As Outlook.MailItem
Set autoFwd = Item.forward
autoFwd.Recipients.Add "test#test.com"
autoFwd.Send
Set autoFwd = Nothing
End Sub
Set up a rule with a run a script option. You will see it when you choose a script.
If that is not what you are asking then.
Sub ManuForwardAllSelectedItemsss_V1()
Dim Item As Object
Dim iSend As Long
For iSend = 1 To ActiveExplorer.Selection.Count
If TypeOf Item Is mailItem Then
Set Item = ActiveExplorer.Selection(iSend)
AutoForwardAllSentItemsss Item
End If
Next
Set Item = Nothing
MsgBox "Done"
End Sub
or
Sub ManuForwardAllSelectedItemsss_V2()
Dim manuFwd As Outlook.mailItem
Dim Item As mailItem
Dim iSend As Long
For iSend = 1 To ActiveExplorer.Selection.Count
Set Item = ActiveExplorer.Selection(iSend)
If TypeOf Item Is mailItem Then
Set manuFwd = Item.Forward
manuFwd.Recipients.Add "test#test.com"
manuFwd.Send
End If
Next
Set Item = Nothing
Set manuFwd = Nothing
End Sub