Im writing a macro for outlook 2010. I get the error on the for each loop even the first time and oFolder does contain a folder.
BTW, SaveAttachments runs correctly the first time its just the second time it bombs.
Public Sub processFolder()
Set objNS = Application.GetNamespace("MAPI")
Dim oParent As Outlook.MAPIFolder
Dim oFolder As Outlook.MAPIFolder
Dim FolderName As String
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
SaveAttachments (objInbox)
If (objInbox.Folders.Count > 0) Then
For Each oFolder In objInbox.Folders
SaveAttachments (oFolder)
Next
End If
End Sub
Sub SaveAttachments(ByVal oParent As Outlook.MAPIFolder)
'Declaration
Dim myItems, myItem, myAttachments, myAttachment As Object
Dim myOrt As String
Dim myOlApp As New Outlook.Application
myOrt = "C:\attachments"
On Error Resume Next
'for all items do...
For Each myItem In oParent.Items
'point on attachments
Set myAttachments = myItem.Attachments
'if there are some...
If myAttachments.Count > 0 Then
'add remark to message text
myItem.Body = myItem.Body & vbCrLf & _
"Removed Attachments:" & vbCrLf
'for all attachments do...
For i = 1 To myAttachments.Count
'save them to destination
myAttachments(i).SaveAsFile myOrt & _
myAttachments(i).DisplayName
'add name and destination to message text
myItem.Body = myItem.Body & _
"File: " & myOrt & _
myAttachments(i).DisplayName & vbCrLf
Next i
'for all attachments do...
While myAttachments.Count > 0
'remove it (use this method in Outlook XP)
'myAttachments.Remove 1
'remove it (use this method in Outlook 2000)
myAttachments(1).Delete
Wend
'save item without attachments
myItem.Save
End If
Next
'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub
You have mixed and matched the method of calling SaveAttachments
Choose one or the other
Call SaveAttachments(objInbox) ' <--- Call requires brackets
SaveAttachments objInbox ' <--- No brackets
SaveAttachments oFolder ' <--- No brackets
Related
I want when Outlook opens to:
Search sent items with today's date with a specific subject.
If none is found, then send the "Test" email.
If found, display messagebox that says "Email is found".
I have only been able to do #1.
Private Sub Application_Startup()
Dim MItem As MailItem
Set MItem = Application.CreateItem(olMailItem)
MItem.Subject = "Test Alert"
MItem.To = "email#abc.com"
MItem.DeferredDeliveryTime = DateAdd("n", 1, Now) 'n = minute, h=hour
MItem.Send
End Sub
Update:
This is what I've tried. It doesn't seem to be searching the Sent Items folder with the subject.
Public Function is_email_sent()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olFldr As Outlook.Folder
Dim olItms As Outlook.Items
Dim objItem As Outlook.MailItem
On Error Resume Next
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(Outlook.olFolderSentMail)
For Each objItem In olFldr.Items
If objItem.Subject = "Test Alert" And _
objItem.SentOn = Date Then _
MsgBox "Yes. Email found"
Else
MsgBox "No. Email not found"
Exit For
End If
Next objItem
End Function
The main error is misuse of On Error Resume Next. Errors are bypassed, not fixed.
Public Sub is_email_sentFIX()
Dim olFldr As Folder
Dim olItms As Items
Dim objItem As Object
Dim bFound As Boolean
' Not useful here.
' Use for specific purpose to bypass **expected** errors.
'On Error Resume Next
Set olFldr = Session.GetDefaultFolder(olFolderSentMail)
Set olItms = olFldr.Items
olItms.sort "[SentOn]", True
For Each objItem In olItms
If objItem.Class = OlMail Then
Debug.Print objItem.Subject
If objItem.Subject = "Test Alert" Then
Debug.Print objItem.SentOn
Debug.Print Date
If objItem.SentOn > Date Then
MsgBox "Yes. Email found"
bFound = True
Exit For
End If
End If
End If
Next objItem
If bFound = False Then
MsgBox "No. Email not found"
End If
End Sub
If there are an excessive number of items in the Sent folder the "not found" outcome will be slow.
One possible option to the brute force way is to Restrict to the specific item, rather than using If statements.
this is some code ive used;
Sub sendmail10101() 'this is to send the email from contents in a cell
Dim obApp As Object
Dim NewMail As MailItem
Set obApp = Outlook.Application
Set NewMail = obApp.CreateItem(olMailItem)
'You can change the concrete info as per your needs
With NewMail
.Subject = Cells(21, 3).Value
.To = Cells(18, 3).Value
.Body = "Good day" & vbCrLf & "i hope you are keeping well " & vbCrLf & vbCrLf & "please can you assist with the below members infomation;" & vbCrLf & vbCrLf & vbCrLf & Cells(20, 3).Value
'.Attachments.Add ("C:\Attachments\Test File.docx")
.Importance = olImportanceHigh
.Display
End With
Set obApp = Nothing
Set NewMail = Nothing
End Sub
the next part is to search the mail box, which you can also use to search from the first initial cell;
Option Explicit
Public Sub Search_Outlook_Emails()
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outStartFolder As Outlook.MAPIFolder
Dim foundEmail As Outlook.MailItem
Set outApp = New Outlook.Application
Set outNs = outApp.GetNamespace("MAPI")
'Start at Inbox's parent folder
Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent
'Or start at folder selected by user
'Set outStartFolder = outNs.PickFolder
If Not outStartFolder Is Nothing Then
Set foundEmail = Find_Email_In_Folder(outStartFolder, ThisWorkbook.Sheets("Dashboard").TextBox1.Value)
If Not foundEmail Is Nothing Then
If MsgBox("Email subject: " & foundEmail.Subject & vbNewLine & vbNewLine & _
"Folder: " & foundEmail.Parent.FolderPath & vbNewLine & vbNewLine & _
"Open the email?", vbYesNo, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' found") = vbYes Then
foundEmail.Display
End If
Else
MsgBox "", vbOKOnly, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' not found"
End If
End If
End Sub
Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem
Dim outItem As Object
Dim outMail As Outlook.MailItem
Dim outSubFolder As Outlook.MAPIFolder
Dim i As Long
Debug.Print outFolder.FolderPath
Set Find_Email_In_Folder = Nothing
'Search emails in this folder
i = 1
While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing
Set outItem = outFolder.Items(i)
If outItem.Class = Outlook.OlObjectClass.olMail Then
'Does the findText occur in this email's body text?
Set outMail = outItem
If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail
End If
i = i + 1
Wend
DoEvents
'If not found, search emails in subfolders
i = 1
While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing
Set outSubFolder = outFolder.Folders(i)
'Only check mail item folders
If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)
i = i + 1
Wend
End Function
the previous code brings us a message box to say if its been found which can be removed but maybe use the message box and an IF statement
such as;
with activeworkbook
if msgbox.value = "yes" then
range("A1:A30") = "COMPLETED" 'ASSUMING THIS IS THE INTIAL TEST RANGE IT WILL CHANGE THE SUBJECT THUS STOPPING THE FIRST MACRO
end if
end with
or if no message box then use something such as IF found then so on...
hope this helps
I have the below code that runs through a folder looking for unread messages from a specific person with a specific subject. The loop is not beginning at the most recent emails. It's beginning a month ago where all the messages are read.
Sub MovingAttachmentsIntoNetworkFolders()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Email Subfolder") 'Specify Folder here
On Error GoTo ErrorHandler
For Each Item In olFolder.Items
Debug.Print Item.ReceivedTime
If Item.UnRead = True Then
If TypeOf Item Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = Item
Debug.Print Item.SenderEmailAddress
Debug.Print Item.Subject
Debug.Print Item.Attachments.Count
If Item.Sender = "emailaddress#email.com" And _
Item.Subject = "EmailSubject" And _
Item.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 = "mappednetworkdrive"
' save attachment
Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).FileName
Debug.Print Att & "\" & Format(Item.ReceivedTime, "mm-dd-yyyy")
myAttachments.Item(1).SaveAsFile Format(Item.ReceivedTime, "mm.dd.yyyy") & " " & Att
' mark as read
Item.UnRead = False
End If
End If
End If
Next
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Any reason why my code is behaving this way?
For a For Each loop, you can sort a collection of the items in the folder by ReceivedTime as described here Email data exported to Excel - Sort by Received Date
Note: Untested code to demonstrate how to sort
Option Explicit
Sub MovingAttachmentsIntoNetworkFolders()
Dim objNS As NameSpace
Dim olFolder As Folder
dim objItem as object
dim fldItems as items
Set objNS = GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
'Specify Folder here
Set olFolder = olFolder.Folders("Email Subfolder")
On Error GoTo ErrorHandler
' https://stackoverflow.com/questions/14948295/email-data-exported-to-excel-sort-by-received-date
set fldItems = olFolder.Items
fldItems.Sort "ReceivedTime", true
For Each objItem In fldItems
Debug.Print objItem.ReceivedTime
If objItem.UnRead = True Then
If TypeOf objItem Is MailItem Then
Debug.Print objItem.SenderEmailAddress
Debug.Print objItem.Subject
Debug.Print objItem.Attachments.Count
If objItem.Sender = "emailaddress#email.com" And _
objItem.Subject = "EmailSubject" And _
objItem.Attachments.Count = 1 Then
' mark as read
objItem.UnRead = False
End If
End If
End If
set objItem = Nothing
Next
ProgramExit:
Set objNS = Nothing
Set olFolder = Nothing
set fldItems = Nothing
set objItem = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
If code is in Outlook there is no need to reference Outlook.
Avoid using Item and olMail for variable names as they already have a purpose.
I want to move some messages from Inbox to a subfolder but this code (that I have copied from other forum) is not working. Can you tell me what is going wrong? Do you think it is not working because of the fact that I have two different accounts in this Outlook?
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim lngCount As Long
On Error GoTo MsgErr
Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = Application.ActiveExplorer.CurrentFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
'// Email_One
Case "bb"
// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("BB")
Set Item = Items.Find("[SenderEmailAddress] = 'bb#gmail.com'")
If TypeName(Item) <> "Nothing" Then
// Mark As Read
Item.UnRead = False
// Move Mail Item to sub Folder
Item.Move SubFolder
End If
'// Email_Two
Case "aa"
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("AA")
Set Item = Items.Find("[SenderEmailAddress] = 'aa#gmail.com'")
If TypeName(Item) <> "Nothing" Then
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
End If
Case Else:
Exit Sub
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Your Select Case is not set correctly-
Case "bb" should be Case "bb#gmail.com" & Case "aa" should be Case "aa#gmail.com"
also Set SubFolder = Inbox.Folders("BB") BB should be your subfolder name
__
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder '<- has been added
Dim olNs As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim Items As Outlook.Items
Dim lngCount As Long
' On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Folder = Application.Session.PickFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'bb#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "aa#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'aa#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
This question already has answers here:
For Each loop: Some items get skipped when looping through Outlook mailbox to delete items
(2 answers)
Closed 7 years ago.
I seem to be getting issues with moving emails from inbox to a sub-folder of inbox. I always thought my code was working until today. I noticed it's only moving half of the emails. I do not need a "move all" code, I have a purpose for this but I just need to move each emails and not all at once (I needed to check each emails). Please take a look at my code below. myNamespace.Folders.Item(1).Folders.Item(2) is my main Inbox.
Sub MoveEachInboxItems()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
For Each Item In myNamespace.Folders.Item(1).Folders.Item(2).Items
Dim oMail As Outlook.MailItem: Set oMail = Item
Item.UnRead = True
Item.move myNamespace.Folders.Item(1).Folders.Item(2).Folders("Other Emails")
Next
End Sub
here is good link
Moves Outlook Mail items to a Sub folder by Email address
Option Explicit
Public Sub Move_Items()
' // Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim lngCount As Long
On Error GoTo MsgErr
' Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items(lngCount)
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "Email_One#email.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder One")
Set Item = Items.Find("[SenderEmailAddress] = 'Email_One#email.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "Email_Two#email.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder Two")
Set Item = Items.Find("[SenderEmailAddress] = 'Email_Two#email.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Or to move all Mail items Inbox to sub folder
Option Explicit
Public Sub Move_Items()
' // Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim lngCount As Long
Dim Items As Outlook.Items
On Error GoTo MsgErr
' Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
I am trying to save all attachemnts from emails that arrived today.
I do not know how to reference the date property of an email object.
My existing code:
Sub GetAllAttachments() 'Exports and saves all attachements in the inbox
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Today = Format(Now(), "yyyy MM dd")
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Secondary")
Set Inbox = Inbox.Folders("Inbox")
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
If EMAIL_DATE = Today Then
For Each Atmt In Item.Attachments
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
End Sub
Item doesn't have the date property.
Try using the
Outlook.MailItem
For example:
Dim oMI as Outlook.MailItem
For Each oMI in Application.ActiveExplorer.Selection
Msgbox (oMI.RecievedTime)
Next
You will need to strip the date from the time.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub GetAllAttachments()
'Exports and saves all attachements in the inbox
Dim ns As namespace
Dim mailBox As folder
Dim myInbox As folder
Dim myItem As Object
Dim myItems As Items
Dim Atmt As Attachment
Dim FileName As String
Dim today As Date
today = Format(Now, "yyyy-mm-dd")
Debug.Print
Debug.Print Format(today, "yyyy-mm-dd hh:nn:ss AM/PM"), "midnight"
Set ns = GetNamespace("MAPI")
Set mailBox = ns.folders("Secondary")
Set myInbox = mailBox.folders("Inbox")
Set myItems = myInbox.Items
If myItems.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
myItems.Sort "[ReceivedTime]", True
For Each myItem In myItems
If myItem.Class = olMail Then
If myItem.ReceivedTime > today Then
Debug.Print myItem.ReceivedTime, myItem.subject
For Each Atmt In myItem.Attachments
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
Next Atmt
Else
Debug.Print
Debug.Print myItem.ReceivedTime, "** Exiting - prior to today **"
Exit For
End If
Else
' Mailitem properties may not apply
Debug.Print "Not a mailitem."
End If
Next myItem
End Sub
Reference material for the Outlook object model.
https://learn.microsoft.com/en-us/office/vba/api/overview/outlook/object-model
MailItem.ReceivedTime Property:
https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem