I took at a look at MailItem and didn't see anything that would indicate that I could shift select items.
I have code that functions however, the Set objItem = GetCurrentItem() line only takes one mail.
I'm looking to either ForEach through a folder, or ForEach through a selection.
I tried something like
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
I don't have any idea what I'm doing.
Here is the code I'm trying to execute on multiple emails:
Sub HelpdeskNewTicket()
Dim helpdeskaddress As String
Dim objMail As Outlook.MailItem
Dim strbody As String
Dim oldmsg As String
Dim senderaddress As String
Dim addresstype As Integer
' Set this variable as your helpdesk e-mail address
helpdeskaddress = "danielbelamiinc#gmail.com"
Set objItem = GetCurrentItem()
Set objMail = objItem.Forward
' Sender E=mail Address
senderaddress = objItem.SenderEmailAddress
strbody = objItem.Body
objMail.To = helpdeskaddress
objMail.Subject = objItem.Subject
objMail.Body = strbody
'Automatically Send the ticket
objMail.Send
Set objItem = Nothing
Set objMail = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = _
objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = _
objApp.ActiveInspector.CurrentItem
Case Else
End Select
End Function
To loop through selection items use For...Next Statement Loop [MSDN]
Syntax
For counter = initial_value To end_value [Step step-counter]
Example on Selection Items
Option Explicit
Public Sub Example()
Dim Item As Outlook.mailitem
Dim i As Long
For i = ActiveExplorer.Selection.Count To 1 Step -1
Set Item = ActiveExplorer.Selection.Item(i)
Debug.Print Item.Subject
' Call Sub
Next
End Sub
Example on Folder Items
Option Explicit
Public Sub Example()
Dim Inbox As Outlook.folder
Set Inbox = Application.Session.GetDefaultFolder( _
olFolderInbox _
)
Dim Items As Outlook.Items
Set Items = Inbox.Items
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i) 'Print on Immediate Window
Next
End Sub
DoEvents MSDN & Debug.Print SO Link
Description
loop executes a given number of times, as determined by a loop counter. To use the For...Next loop, you must assign a numeric value to a counter variable. This counter is either incremented or decremented automatically with each iteration of the loop. In For statement, you specify the value that is to be assigned to the counter initially and the maximum value the counter will reach for the block of code to be executed. The Next statement marks the end of the block of code that is to execute repeatedly, and also serves as a kind of flag that indicates the counter variable is to be modified.
CurrentFolder Property
Returns or sets a MAPIFolder object that represents the current folder displayed in the explorer. Use this property to change the folder the user is viewing.
Related
I'm trying to export sender email address and recipient email addresses (to and cc) to Excel. I adapted code I found online. It does most of what I need but there are two problems:
It only works with a single recipient. If there are two or more recipients, it provides names (e.g. Jo Bloggs) instead of email addresses.
It only includes people in the 'To' field, not those in the 'CC' field.
I think the bit that needs fixing is:
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
Full code:
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim obj As Object
Dim olItem 'As Outlook.MailItem
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("Sheet1")
On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
xlSheet.Range("A1") = "Sender Name"
xlSheet.Range("B1") = "Sender Email"
xlSheet.Range("C1") = "Subject"
xlSheet.Range("D1") = "Body"
xlSheet.Range("E1") = "Sent To"
xlSheet.Range("F1") = "Date"
End If
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each obj In objItems
Set olItem = obj
'collect the fields
strColA = olItem.SenderName
strColB = olItem.SenderEmailAddress
strColC = olItem.Subject
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime
' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColB)
If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF
'Next row
rCount = rCount + 1
xlWB.Save
Next
' don't wrap lines
xlSheet.Rows.WrapText = False
xlWB.Save
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Iterating through all items in the folder is not really a good idea. I'd recommend starting from the Find/FindNext or Restrict methods instead. Please note that there are some item properties that you can’t use for the filter. You can read more about the properties not allowed in the filter string and string formats used for the search criterion on MSDN.
The following example uses the Restrict method to get all Inbox items of Business category and moves them to the Business folder. To run this example, create or make sure a subfolder called 'Business' exists under Inbox:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Categories] = 'Business'")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Please remember that you can set a suitable filter (View | View Settings |filter) on a folder and study the filter string on the SQL tab of the Filter dialog. Then you can construct any required filter string in the code.
If woudl be nice to use Items.Find/FindNext or Items.Restrict, but I cannot think of a query that would let you do what you want. If it is a one time thing, you have no choice but to loop through all items in a folder and for each item loop through all recipients and compare each recipient's entry id (Recipient.EntryID) with the sender entry id (MailItem.Sender.EntryId).
I am trying to download the email attachments in Outlook inbox based on received date. My code downloads attachments, however it skips files.
For example: I was trying to loop the email from the latest email (Received date:01/14/2019). After looping around 10-15 emails, it suddenly jumps to read the email received on 12/07/2018.
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Outlook.MailItem
Set olmail = objOL.CreateItem(olMailItem)
Dim olattachment As Outlook.Attachment
Dim i As Long
Dim filename As String
Dim VAR As Date
'Loop through all item in Inbox
For i = olfolder.Items.Count To 1 Step -1 'Iterates from the end backwards
Set olmail = olfolder.Items(i)
For Each olmail In olfolder
VAR = Format(olmail.ReceivedTime, "MM/DD/YYYY")
filename = olmail.Subject
If VAR = "1/14/2019" Then
For Each olattachment In olmail.Attachments
olattachment.SaveAsFile "C:\Users\Rui_Gaalh\Desktop\Email attachment\" & olattachment.filename
Next
Else
End If
'Mark email as read
olmail.UnRead = False
DoEvents
olmail.Save
Next
Next
MsgBox "DONE"
End Sub
Do not loop through all items in a folder - some folders can have ten of thousands of messages. Use Items.Find/FindNext or Items.Restrict with a query like "[ReceivedTime] >= '2019-01-14' AND [ReceivedTime] < '2019-01-15'".
In case of Items.Find/FindNext, you won't have a problem with skipped emails. In case of Items.Restrict, use a down loop from count down to 1 step -1.
If you are just trying to save Email Attachments that was received on "1/14/2019" then No need for
For Each olmail In olfolder
Next
When you are already using
For i = olfolder.Items.Count To 1 Step -1
next
Here is another one objOL.CreateItem(olMailItem)?? remove it, also Dim olmail as a generic Object - there are objects other than MailItem in your Inbox.
Dim olmail As Outlook.MailItem
Set olmail = objOL.CreateItem(olMailItem)
Set olMail with in the loop then check if the olMail is MailItem
Example
Option Explicit
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.NameSpace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Object
Dim olattachment As Outlook.attachment
Dim i As Long
Dim filename As String
Dim VAR As Date
'Loop through all item in Inbox
For i = olfolder.items.Count To 1 Step -1 'Iterates from the end backwards
DoEvents
Set olmail = olfolder.items(i)
If TypeOf olmail Is Outlook.MailItem Then
VAR = Format(olmail.ReceivedTime, "MM/DD/YYYY")
filename = olmail.Subject
If VAR = "1/14/2019" Then
For Each olattachment In olmail.Attachments
olattachment.SaveAsFile _
"C:\Users\Rui_Gaalh\Desktop\Email attachment\" _
& olattachment.filename
Next
'Mark email as read
olmail.UnRead = False
End If
End If
Next
MsgBox "DONE"
End Sub
You should also look into Items.Restrict method
https://stackoverflow.com/a/48311864/4539709
Items.Restrict method is an alternative to using the Find method or FindNext method to iterate over specific items within a collection. The Find or FindNext methods are faster than filtering if there are a small number of items. The Restrict method is significantly faster if there is a large number of items in the collection, especially if only a few items in a large collection are expected to be found.
Filtering Items Using a String Comparison that DASL filters support includes equivalence, prefix, phrase, and substring matching. Note that when you filter on the Subject property, prefixes such as "RE: " and "FW: " are ignored.
Thanks for all your suggestions. The code works perfectly. Please find the final code below:
Option Explicit
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Object
Dim olattachment As Outlook.Attachment
Dim i As Long
Dim InboxMsg As Object
Dim filename As String
'Set variables
Dim Sunday As Date
Dim Monday As Date
Dim Savefolder As String
Dim VAR As Date
Dim Timestamp As String
Monday = ThisWorkbook.Worksheets(1).Range("B2")
Sunday = ThisWorkbook.Worksheets(1).Range("B3")
Savefolder = ThisWorkbook.Worksheets(1).Range("B4")
'Loop through all item in Inbox
For i = olfolder.Items.Count To 1 Step -1 'Iterates from the end backwards
DoEvents
Set olmail = olfolder.Items(i)
Application.Wait (Now + TimeValue("0:00:01"))
'Check if olmail is emailitem
If TypeOf olmail Is Outlook.MailItem Then
'Set time fram
VAR = olmail.ReceivedTime 'Set Received time
Timestamp = Format(olmail.ReceivedTime, "YYYY-MM-DD-hhmmss") 'Set timestamp format
If VAR <= Sunday And VAR >= Monday Then
For Each olattachment In olmail.Attachments
Application.Wait (Now + TimeValue("0:00:01"))
'Download excel file and non-L10 file only
If (Right(olattachment.filename, 4) = "xlsx" Or Right(olattachment.filename, 3) = "xls")Then
'Set file name
filename = Timestamp & "_" & olattachment.filename
'Download email
olattachment.SaveAsFile Savefolder & "\" & filename
Application.Wait (Now + TimeValue("0:00:02"))
End If
Next
Else
End If
'Mark email as read
olmail.UnRead = False
DoEvents
olmail.Save
Else
End If
Next
MsgBox "DONE"
End Sub
I created a rule, that starts a VBA-script depending on the subject of a received email (Rule: Subject "MY_SUBJECT" -> start script).
The VBA script is then doing some stuff and then it should finally delete the original email.
This part is easy:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
Item.Delete
End Sub
Now the email will sit in the deleted-items-folder. But what I need to achieve is, to also delete this mail from the deleted-items folder. Since I know the subject of this mail (because this triggered my rule in the first place), I tried the following approach:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
Item.Delete
End Sub
' delete email from deleted items-folder
Dim deletedFolder As Outlook.Folder
Set deletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
Dim i As Long
For i = myFolder.Items.Count To 1 Step -1
If (deletedFolder.Items(i).Subject) = "MY_SUBJECT" Then
deletedFolder.Items(i).Delete
Exit For
End If
Next if
End Sub
Well, this basically works: The mail with this subject will be found in the deleted-items-folder and it will be deleted, yes.
But sadly it does not work as expected:
This permanent deletion only works once I start the script a second time.
So the email which is triggering my script will never be deleted permanently in this script's actual run, but only in the next run (once the next email with the trigger-subject for my rule is received - but then this very next email won't be deleted, again).
Do you have any idea what I am doing wrong here? It somehow looks like I need to refresh my deleted-items folder somehow. Or do I have to comit my first Item.Delete somehow explicitly?
The problem was not recreated, but try stepping through this then run normally if it appears to do what you want.
Sub doWorkAndDeleteMail(Item As mailitem)
Dim currFolder As Folder
Dim DeletedFolder As Folder
Dim i As Long
Dim mySubject As String
Set currFolder = ActiveExplorer.CurrentFolder
mySubject = Item.Subject
Debug.Print mySubject
Set DeletedFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems)
Set ActiveExplorer.CurrentFolder = DeletedFolder
Debug.Print "DeletedFolder.count before delete: " & DeletedFolder.Items.count
' delete email from deleted items-folder
Item.Delete
Debug.Print "DeletedFolder.count after delete: " & DeletedFolder.Items.count
' If necessary
'DoEvents
For i = DeletedFolder.Items.count To 1 Step -1
Debug.Print DeletedFolder.Items(i).Subject
If (DeletedFolder.Items(i).Subject) = mySubject Then
Debug.Print DeletedFolder.Items(i).Subject & " *** found ***"
DeletedFolder.Items(i).Delete
Exit For
End If
Next
Set ActiveExplorer.CurrentFolder = currFolder
End Sub
Tim Williams suggested another existing thread. I had a look at that already before and decided that appoach would be exactly the same representation of my bug. I did try it out, though (to show my motiviation :) ), but the behaviour is - as expected - exactly the same: Again the final deletion only works once the next time the script is triggered via rule:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim objDeletedFolder As Outlook.Folder
Dim objItem As Object
Dim objProperty As Variant
Set objDeletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.Items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
I would be really glad to get some help here. I also wanted to comment on that other thread, but my reputation is not enough, yet.
Try something like this, code goes under ThisOutlookSession
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Set Items = DeletedFolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Filter As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Filter = "[Subject] = 'MY_SUBJECT'"
Set Items = DeletedFolder.Items.Restrict(Filter)
If TypeOf Item Is Outlook.MailItem Then
For i = Items.Count To 1 Step -1
DoEvents
Items.Remove i
Next
End If
End Sub
Edit
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Filter As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Filter = "[Subject] = 'MY_SUBJECT'"
Set Items = DeletedFolder.Items.Restrict(Filter)
If TypeOf Item Is Outlook.MailItem Then
For i = Items.Count To 1 Step -1
DoEvents
Items.Remove i
Next
End If
End Sub
the Mailbox folder that you get can be used as a collection, meaning that you can remove the item directly, you will need the collection to be sent to the function but that should be managable :)
Sub doWorkAndDeleteMail(Mailbox As Outlook.Folder, Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
For Ite = 1 To Mailbox.Items.Count
If Mailbox.Items(Ite).EntryID = Item.EntryID Then
Mailbox.Items.Remove Ite
Exit For
End If
Next
End Sub
Remember that IF you want to Delete more than 1 Item per call of "For Ite = 1 To Mailbox.Items.Count", you will need to subtract 1 from the check of the item within the For segment since when you remove a mail from it, it will reduce the rest of the mails index number by 1.
Hope you can still use this :)
Regards Sir Rolin
I'm trying to move the bottom 20 emails to another folder in Outlook to another folder where the macro runs. I'm able to move then when selected but I don't want to have to select 20 from the bottom (oldest) first. I'd like to automate this bit too.
Any help would be appreciated.
Here's what I have so far but it moves the most recent mail only, regardless of how the inbox is sorted:
Public Sub Move_Inbox_Emails()
Dim outApp As Object
Dim outNS As Object
Dim inboxFolder As Object
Dim destFolder As Object
Dim outEmail As Object
Dim inboxItems As Object
Dim i As Integer
Dim inputNumber As String
Dim numberToMove As Integer
inputNumber = InputBox("Enter number of emails to move")
On Error Resume Next
numberToMove = CInt(inputNumber)
On Error GoTo 0
If numberToMove < 1 Then Exit Sub
Set outApp = CreateObject("Outlook.Application")
Set outNS = outApp.GetNamespace("MAPI")
Set inboxFolder = outNS.GetDefaultFolder(olFolderInbox)
Set destFolder = inboxFolder.Parent.Folders("Mobus") 'Test folder at same level as Inbox
'Sort Inbox items by Received Time
Set itemsCol = inboxFolder.Items
itemsCol.Sort "[ReceivedTime]", False
'Loop through sorted items for the number entered by the user, up to the number of items in the Inbox
For i = inboxFolder.Items.Count To inboxFolder.Items.Count - numberToMove + 1 Step -1
If inboxFolder.Items(i).Class = OlObjectClass.olMail Then
Set outEmail = inboxFolder.Items(i)
'Debug.Print outEmail.ReceivedTime, outEmail.subject
outEmail.Move destFolder
End If
Next
End Sub
I've solved this now with some ideas from the commentors, thanks very much. This code now prompts for how many to move and takes them from the oldest first:
Public Sub Move_Inbox_Emails_From_Excel()
Dim outApp As Object
Dim outNS As Object
Dim inboxFolder As Object
Dim destFolder As Object
Dim outEmail As Object
Dim inboxItems As Object
Dim i As Integer
Dim inputNumber As String
Dim numberToMove As Integer
inputNumber = InputBox("Enter number of emails to move")
On Error Resume Next
numberToMove = CInt(inputNumber)
On Error GoTo 0
If numberToMove < 1 Then Exit Sub
Set outApp = CreateObject("Outlook.Application")
Set outNS = outApp.GetNamespace("MAPI")
Set inboxFolder = outNS.GetDefaultFolder(olFolderInbox)
Set destFolder = inboxFolder.Parent.Folders("Mobus") 'Test folder at same level as Inbox
'Sort Inbox items by Received Time
Set inboxItems = inboxFolder.Items
'inboxItems.Sort "[ReceivedTime]", False 'ascending order (oldest first)
inboxItems.Sort "[ReceivedTime]", True 'descending order (newest first)
'Loop through sorted items for the number entered by the user, up to the number of items in the Inbox
For i = inboxFolder.Items.Count To inboxFolder.Items.Count - numberToMove + 1 Step -1
Set outEmail = inboxItems(i)
'Debug.Print i, outEmail.Subject
outEmail.Move destFolder
Next
End Sub
Sort the Items collection by ReceivedTime property, loop though the last 20 items (use a down loop - step -1) and move the items.
I receive a random run-time error 13 (type mismatch). This routine works most of the time. The folder passed as an argument is legitimate at the time of the failure.
From what I can see in the debugger, objitem is missing some of the fields during runtime. After it break-points in the debugger, I can immediately single-step (re-executing the offending line) and there is no error.
I attempted using on error goto to sleep then retry various lines, and the error persists until it stops in the debugger.
I also attempted changing between the For ii and For Each forms of the loop commands.
I also temporarily disabled by anti-virus.
I iterate over a large number of public folders. My Outlook client is 2003 running under XP, and I am attached to Exchange Server version 7654.
Sub SearchFolders(objFolder As Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders
Dim subFolder As Outlook.MAPIFolder
Dim objitem As MailItem
Dim ii As Integer
' Recurse through all subfolders
Set objFolders = objFolder.Folders
For Each subFolder In objFolders
Call SearchFolders(subFolder)
Next subFolder
' Search the emails
For ii = 1 To objFolder.Items.Count
If objFolder.Items(ii).Class = olMail Then
If TypeName(objFolder.Items(ii)) <> "MailItem" Then
MsgBox ("Type mismatch: object s/b MailItem and is " & TypeName(objFolder.Items(ii)))
GoTo NextdblLoop
End If
Set objitem = objFolder.Items(ii)
CheckEmailForErrorReports (objFolder.Items(ii))
End If
NextdblLoop:
Next ii
End Sub
Code below is modified per #dmitry suggestions and now works.
Sub SearchFolders(objFolder As Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders
Dim subFolder As Outlook.MAPIFolder
Dim Objitem As Outlook.MailItem
Dim ii As Integer
Dim ThisItem As Object
Dim Items As Outlook.Items
' Recurse through all subfolders
Set objFolders = objFolder.Folders
For Each subFolder In objFolders
Call SearchFolders(subFolder)
Next subFolder
' Search the emails
Set Items = objFolder.Items
For ii = 1 To Items.Count
Set ThisItem = Items.item(ii)
If ThisItem.Class = olMail Then
If VarType(ThisItem) = 9 Then GoTo NextdblLoop
Set Objitem = ThisItem
CheckEmailForErrorReports (objFolder.Items(ii))
Set Objitem = Nothing
End If
Set ThisItem = Nothing
NextdblLoop:
Next ii
Set Items = Nothing
End Sub
Firstly, do not use multiple dot notation; cache the Items collection before entering the loop.
Secondly, release the variables as soon as you are done with them
dim item As Object
dim Items as Outlook.Items
set Items = objFolder.Items
For ii = 1 To Items.Count
set item = Items.Item(ii)
If item.Class = olMail Then
If TypeName(item) <> "MailItem" Then
'THIS CAN NEVER HAPPEN. The check above is sufficient
MsgBox ("Type mismatch: object s/b MailItem and is " & TypeName(item))
GoTo NextdblLoop
End If
Set objitem = item
CheckEmailForErrorReports (objitem)
Set objitem = Nothing
End If
Set item = Nothing
NextdblLoop:
Next ii
End Sub