I am trying to loop through a selection or a folder of Outlook emails, attach the same file to each of them and forward them to the same email address.
I have previously tried to use a for loop but when there were many emails (100+), Outlook told me it ran out of memory and it was unable to forward the emails.
I am try to do this now with a while loop. Below is my code. It is not working. What should I change?
Sub ForwardSelectedItems()
Dim forwardmail As Outlook.mailItem
Dim Selection As Selection
Dim n As Integer
Set Selection = Application.ActiveExplorer.Selection
Set n = Selection.Count
Do While n > 0
Set forwardmail = Selection.Item(1).forward
'Email recipient address
forwardmail.Recipients.Add "test#test.com"
'File Path
forwardmail.Attachments.Add ("C:\temp\test.xlsx")
forwardmail.Send
Next
End Sub
Set is for objects.
Sub ForwardSelectedItems_V2()
'Dim forwardmail As outlook.mailItem
Dim forwardmail As mailItem
Dim itm As Object
'Dim Selection As Selection
Dim itmSel As Selection
'Dim n As Integer
Dim n As Long
'Set Selection = Application.ActiveExplorer.Selection
Set itmSel = ActiveExplorer.Selection
' Set is for objects
'Set n = Selection.count
n = itmSel.count
Do While n > 0
' The first item in the collection "Item(1)" never changes.
' This can be used if the first item
' is removed from the collection in each iteration.
' Not the case here.
' Set forwardmail = Selection.Item(1).forward
Set itm = itmSel.Item(n)
'If itm is not a mailitem, the object may not have a method you expect.
If itm.Class = olMail Then
Set forwardmail = itm.Forward
'Email recipient address
forwardmail.Recipients.Add "test#test.com"
'File Path
forwardmail.Attachments.Add ("C:\temp\test.xlsx")
forwardmail.Display
'forwardmail.Send
End If
' not a For Next loop so n has to be manipulated "manually"
n = n - 1
'Next
Loop
End Sub
The below code is working now. I have tried it when there are 80 emails in a subfolder. I am making it looping through a folder instead of a Selection.
Sub SendFolderItemsWithAttachments()
Dim MyFolder As MAPIFolder
Set MyFolder = Application.Session.Folders("Name").Folders("Inbox").Folders("Subfolder")
Dim forwarditems As Items
Set forwarditems = MyFolder.Items
Dim i As Long
For i = forwarditems.Count To 1 Step -1
Set forwardmail = forwarditems.Item(i).forward
'Email recipient address
forwardmail.Recipients.Add "test#test.com"
'File Path
forwardmail.Attachments.Add ("C:\Temp\filename.xlsx")
forwardmail.Send
Next
End Sub
Related
I am trying to create a code that will parse Inbox folder in Outlook and organize emails based on several criteria.
If there is a number between brackets. For example (123456)
If there are attachments in email item. Attachment should be more than 10000 to skip Signatures
Logic:
If both criteria match -> Send to Folder1
If one of them does not match (attachments are missing or there is no number between brackets), send to Archive
Criteria 1 is functioning correct, but I have problems adding criteria 2 for attachments.
Here is my current code:
Private Sub olInboxMainItems_ItemAdd(ByVal Item As Object)
'On Error Resume Next
Dim SubjectVar1 As String
Dim openPos1 As Integer
Dim closePos1 As Integer
Dim midBit1 As String
Dim objNamespace1 As Outlook.NameSpace
Dim destinationFolder1 As Outlook.MAPIFolder
Dim ArchiveFolder As Outlook.MAPIFolder
Dim objAttachments As Outlook.Attachments
Dim AttCount As Long
Set objNamespace1 = GetNamespace("MAPI")
Set destinationFolder1 = objNamespace1.Folders("mybox#mail.com").Folders("Inbox").Folders("Folder1")
Set ArchiveFolder = objNamespace1.Folders("mybox#mail.com").Folders("Archive")
Set objAttachments = Item.Attachments
' Check is there a number between brackets
SubjectVar1 = Item.Subject
openPos1 = InStr(SubjectVar1, "(")
closePos1 = InStr(SubjectVar1, ")")
midBit1 = Mid(SubjectVar1, openPos1 + 1, closePos1 - openPos1 - 1)
' Count number of attachments bigger than 10000 bytes
For s = lngCount To 1 Step -1
If objAttachments.Item(s).Size > 10000 Then
' Count attachments.
AttCount = objAttachments.Item(s).Count
End If
Next s
' Perform actions
If midBit1 = "" And AttCount < 1 Then
Item.Move ArchiveFolder
'GoTo EndOfScript
Else
'MsgBox (midBit)
Item.Move destinationFolder1
'GoTo EndOfScript
End If
EndOfScript:
Set destinationFolder1 = Nothing
Set objNamespace1 = Nothing
End Sub
EDIT:
Here is a simple version I am trying to get working for selected email message:
Sub CountAttachmentsinSelectedEmails()
Dim olSel As Selection
Dim oMail As Object
Dim s As Long
Dim AttCount As Long
Dim strMsg As String
Dim nRes
Dim lngCount As Long
Dim objAttachments As Outlook.Attachments
Dim strFile As String
Set olSel = Outlook.Application.ActiveExplorer.Selection
For Each oMail In olSel
For s = lngCount To 1 Step -1
If objAttachments.Item(s).Size > 10000 Then
strFile = objAttachments.Item(s).Count + 1
End If
Next s
Next
MsgBox ("There are " & strFile & " attachments in the ")
End Sub
Result is empty? No numbers at all
EDIT 2:
Sub CountAttachmentsinSelectEmails()
Dim olSel As Selection
Dim oMail As Object
Dim s As Long
Dim objAttachments As Outlook.Attachments
Dim NumFiles As Long
Dim oItem As Object
Set olSel = Outlook.Application.ActiveExplorer.Selection
Set objAttachments = oItem.Attachments
For Each oMail In olSel
For s = objAttachments.Count To 1 Step -1
If objAttachments.Item(s).Size > 10000 Then
NumFiles = NumFiles + 1
End If
Next s
Next
Debug.Print NumFiles
End Sub
Item.Attachments is a collection therefore so is objAttachments.
A collection can have zero or more members. objAttachments.Count is the number of members which you do not check.
You need to loop over the attachments to check their size and extension individually. Signatures, logos and so on count as attachments but I assume you are not interested in them. Could there be more than one interesting attachment? Do you want a total size of 10,000 or any one attachment being more than 10,000 bytes?
When accessing the size you need to specify which attachment you are checking: objAttachments.Item(Index).Size.
The above should you give you some pointers but I can explain in more detail if necessary.
Comments on edit 1
You do not set objAttachments to anything. Add Set objAttachments = oItem.Attachments.
In For s = lngCount To 1 Step -1 you do not set lngCount to a value so it defaults to zero and the for body is never performed. Try For s = objAttachments.Count To 1 Step -1.
strFile is a string but you are using it in a numeric expression. This will work because the interpreter will evaluate the expression and then convert it to a string. However, the value is objAttachments.Item(s).Count + 1. If there are five attachments and any one of them is larger than 10,000 bytes, the answer will be six.
You need something like Dim NumFiles As Long. This will be initialised to 0. Within the If you need NumFiles = NumFiles + 1.
I rarely use MsgBox for diagnostics. I find Debug.Print NumFiles more convenient. If I want to stop execution, I use Debug.Assert False.
Comments on Edit 2
This is the routine I use to test new email handling macros. The relevance is it show how to use Outlookâs Explorer correctly.
Sub TestNewMacro()
' Skeleton for testing a new mail item processing macro using Explorer
' Replace statement marked ##### with call of new macro.
' Add code to create parameters for new test macro and remove any code to
' create parameters for old test macro.
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Dim PathSave As String
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
PathSave = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Please select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call MacroToBeTested(ItemCrnt, PathSave) ' #####
Next
End If
End Sub
I have a Company Project where ~500 clients send Emails to the my project inbox. Those clients correspond to ~150 offices (I have an Excel-List of the email addresses & according offices).
Each office shall have one Outlook folder, so I can quickly check upon the past correspondence with a specific office.
The Project inbox is looked after and used by several co-workers, hence server- and not client based rules.
How do I set this up?
My simple idea in form of a pseudo code:
for each arriving email
if (from-adress is in "email & office-List")
move that email to outlook folder "according office name"
end if
end for
and the same for outgoing emails:
for each sent email
if (to-adress is in "email & office-List")
move that email to outlook folder "according office name"
end if
end for
Thanks for suggestions!
...and besides, can outlook folders be created programmatically from a list of names?
My solution is a skript i run daily on a manual basis since my employer doesnt allow scripts on arriving messages.
the logic in short is:
fetch list of emails & their corresponding offices (both string lists)
set up folder variables
loop through messages, and move them eventually
the code looks like
Option Compare Text ' makes string comparisons case insensitive
Sub sortEmails()
'sorts the emails into folders
Dim msg As Outlook.MailItem
Dim itm As Object
Dim adress As String
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
'1) fetch emails
GetEMailsFolders locIDs, emails, n
'1.5) fetch folder objects
'Create an instance of Outlook & inbox reference
Dim Inbox As Outlook.MAPIFolder
Dim outbox As Outlook.MAPIFolder
Set outlookApp = New Outlook.Application
Set NS = outlookApp.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("email#host.com")
objOwner.Resolve
'Set inbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Inbox = NS.Folders("email#host.com").Folders("Inbox")
Set outbox = NS.Folders("email#host.com").Folders("Sent Items")
Dim basefolder As Outlook.MAPIFolder
Dim bfName As String
bfName = "Offices" 'name of the folder for the offices
Set basefolder = MkDirConditional(Inbox.Folders("Project folder"), bfName)
'2)loop through inbox & outbox emails
Dim destination As Outlook.MAPIFolder
Dim fold(1 To 2) As Outlook.MAPIFolder
Set fold(1) = Inbox
Set fold(2) = outbox
Dim LocID As String
For Each fol In fold 'loop through inbox & outbox
Debug.Print fol
'reverse fo loop because otherwise moved messages modify indices of following messages
For i = fol.Items.Count To 1 Step -1 'Each itm In fol.Items
Set itm = fol.Items(i)
If TypeName(itm) = "MailItem" Then ' others are AppointmentItem, MeetingItem, or TaskItem
Set msg = itm
'Debug.Print " " & msg.Subject
If fol = Inbox Then
' there are two formats of email adrersses.
If msg.SenderEmailType = "EX" Then 'check two kinds of email adress formats
adress = msg.Sender.GetExchangeUser().PrimarySmtpAddress
ElseIf msg.SenderEmailType = "SMTP" Then 'SMTP case
adress = msg.SenderEmailAddress
Else
Debug.Print " neither EX nor SMTP" & msg.Subject;
End If
pos = Findstring(adress, emails) ' position in the email / standort list
ElseIf fol = outbox Then
For Each rec In msg.Recipients
Set pa = rec.PropertyAccessor
adress = pa.GetProperty(PR_SMTP_ADDRESS)
pos = Findstring(adress, emails)
If pos > 0 Then
Exit For
End If
Next rec
End If
'4.5) if folder doesnt exist, create it
'5) move message
If pos > 0 Then
'Debug.Print " Its a Match!!"
LocID = locIDs(pos)
Set destination = MkDirConditional(basefolder, LocID)
Debug.Print " " & Left(msg.Subject, 20), adress, pos, destination
msg.Move destination
Else
'Debug.Print " not found!"
End If
Else
'Debug.Print " " & "non-mailitem", itm.Subject
End If
Next i
Next fol
End Sub
'// Function - Check folder Exist
Private Function FolderExists(Inbox As Outlook.MAPIFolder, FolderName As String) As Boolean
Dim Sub_Folder As MAPIFolder
On Error GoTo Exit_Err
Set Sub_Folder = Inbox.Folders(FolderName)
FolderExists = True
Exit Function
Exit_Err:
FolderExists = False
End Function
Function MkDirConditional(basefolder As Outlook.MAPIFolder, newfolder As String) As Outlook.MAPIFolder
Debug.Print newfolder & " ";
If FolderExists(basefolder, newfolder) Then
'folder exists, so just skip
Set MkDirConditional = basefolder.Folders(newfolder)
Debug.Print "exists already"
Else
'folder doesnt exist, make it
Set MkDirConditional = basefolder.Folders.Add(newfolder)
Debug.Print "created"
End If
End Function
'function to compare two strings, min the option compare text at the top line
Function Findstring(str As String, arr As Variant) As Integer
'returns -1 if a string is not found, otherwise its index
Findstring = -1
Dim i As Integer
i = 1
For Each Item In arr
'Debug.Print Item
If str = Item Then
Findstring = i
Exit For
End If
i = i + 1
Next
End Function
' function to fetch the lists of emails and offices
Sub GetEMailsFolders(ByRef rng1 As Variant, ByRef rng2 As Variant, ByRef n As Variant)
'declare variables
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xExcelRange As Excel.Range
Dim TotalRows As Long
'declare SPOC xls file
xExcelFile = "adresses.xlsx"
'open the file
Set xExcelApp = CreateObject("Excel.Application")
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = xWb.Sheets(1)
'extract LocIDs (column A), emails (column O) and thir number
n = xWs.Range(xWs.Range("A2"), xWs.Range("A2").End(xlDown)).Count ' works
ReDim rng1(1 To n) As Variant
ReDim rng2(1 To n) As Variant
For i = 1 To n
rng1(i) = xWs.Cells(i + 1, 1)
rng2(i) = xWs.Cells(i + 1, 15)
'Debug.Print rng1(i), rng2(i)
Next
Debug.Print "done reading LocIDs & emails"
End Sub
In MS Outlook there are two accounts. For most incoming email the two accounts receive the same email, sometimes in CC or TO fields together. The two accounts are similar and have almost the same subfolders.
Application_NewMailEX triggers twice if email is sent to both accounts.
I need to handle only one account (Inbox folder and its subfolders) and not the second one.
My purpose is execute the code in the NewMailEx sub only one time and only for one of the two email accounts set up in Outlook and not for the other one.
The code after some jobs inserts some values in a SQL Server DB.
Something like:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim NS As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
Dim i as Integer
On Error Resume Next
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = NS.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
' Filter
If m.Sender = "Our Client" and Trim(m.Subject) = "12 AXR check" then
' operations
'....
' Insert DB
'....
End If
' Other things
End If
Next
End Sub
Without understanding why there is duplication I can suggest you verify the inbox first.
Option Explicit
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim NS As Outlook.NameSpace
'Dim itm As Mailitem
Dim itm As Object ' <---
Dim m As Outlook.mailitem
Dim i As Integer
'On Error Resume Next
' If you need this determine the exact place then
' turn error bypass off as soon as possible with
'On Error GoTo 0
Set NS = GetNamespace("MAPI")
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = NS.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
Debug.Print "mail received"
Debug.Print itm.Parent.Parent.name
If itm.Parent.Parent.name = "someone#somewhere.com" Then
' operations
Debug.Print " item in my inbox processed"
Else
Debug.Print " item in any other inbox not processed"
End If
End If
Next
End Sub
Update
I only made a small change and its working
If InStr(1, LCase(itm.Parent.Parent.FolderPath), "sharingaccount#123.abc") > 0 Then
Debug.Print "OK"
End If
I used that code because I have a structure, for the accounts, like the following and I wanted to handle only and exclusively incoming email in SharingAccount and its subfolder:
MyPersonalMail#123.abc
Inbox
Documents
FromLinux
FromAra
SharingAccount#123.abc
Inbox
Documents
FromLinux
FromAra
Thanks
I have designed a VBA code to retrieve the list of mails from the inbox of your outlook using the link Retrieve maillist from outlook
Here there is a line of code
ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
which specifies to get senders email Address but when it is stored in excel it shows as below
/O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=WIPRO365.ONMICROSOFT.COM-52823-C1374FA5
I would like to see it as knowledge#wipro.com mean to say in the proper email format. How to avail this option? Should I do changes at VBA code or excel.
I have tried this in many blogs still vain. Any suggestions will be helpful.
Firstly, this is multiple dot notation take to its extreme - Folder.Items.Item(iRow). This is a really bad idea, especially in a loop - each "." forces Outlook to create and return a brand new COM object. Cache Folder.Items before entering the loop, and retrieve MailItem using Items.Item(I) only once at the beginning of the loop.
That being said, what you get is a perfectly valid EX type address. Check the MailItem.SenderEmailType property first. If it is "EX", use MailItem.Sender.GetExchangeUser.PrimarySmtpAddress (be prepared to handle nulls). Otherwise just use MailItem.SenderEmailAddress property.
Have a look here for how to look at the Global Address Book
Outlook 2010 GAL with Excel VBA
Here is a very simple implementation that converts to the smtp address for Exchange accounts.
Option Explicit
Dim appOL As Object
Dim oGAL As Object
Dim i
Dim oContact
Dim oUser
Dim UserIndex
Dim arrUsers(1 To 65000, 2) As String
Sub test()
End Sub
Sub Download_Outlook_Mail_To_Excel()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Dim folders As Outlook.folders
Dim folder As Outlook.MAPIFolder
Dim iRow As Integer
Dim Pst_Folder_Name
Dim MailboxName
Set appOL = CreateObject("Outlook.Application")
'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailboxName = "your email address"
'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Inbox"
Set folder = Outlook.Session.folders(MailboxName).folders(Pst_Folder_Name)
If folder = "" Then
MsgBox "Invalid Data in Input"
GoTo end_lbl1:
End If
'Rad Through each Mail and export the details to Excel for Email Archival
Sheets(1).Activate
Dim mail As Outlook.MailItem
Dim oAccount As Outlook.Account
Dim stringAddress
FillAddress
For iRow = 1 To folder.Items.Count
If folder.Items.Item(iRow).Class = olMail Then
Set mail = folder.Items.Item(iRow)
Sheets(1).Cells(iRow, 1).Select
Sheets(1).Cells(iRow, 1) = mail.SenderName
Sheets(1).Cells(iRow, 2) = mail.Subject
Sheets(1).Cells(iRow, 3) = mail.ReceivedTime
Sheets(1).Cells(iRow, 4) = mail.Size
Select Case mail.SenderEmailType
Case "SMTP"
Sheets(1).Cells(iRow, 5) = mail.SenderEmailAddress
Case "EX"
'Set oAccount = Outlook.
stringAddress = FindAddress(mail.SenderEmailAddress)
Sheets(1).Cells(iRow, 5) = stringAddress
End Select
End If
'Set oAccount = mail.SenderEmailAddress
'Sheets(1).Cells(iRow, 6) = Folder.Items.Item(iRow).Body
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
end_lbl1:
End Sub
Function FindAddress(strAddress)
Dim address As String
For i = 1 To 65000
If UCase(arrUsers(i, 0)) = strAddress Then
address = arrUsers(i, 2)
Exit For
End If
Next
FindAddress = address
End Function
Sub FillAddress()
Set oGAL = appOL.GetNamespace("MAPI").AddressLists("Global Address List").AddressEntries
For i = 1 To oGAL.Count
Set oContact = oGAL.Item(i)
If oContact.AddressEntryUserType = 0 Then
Set oUser = oContact.GetExchangeUser
If Len(oUser.LastName) > 0 Then
UserIndex = UserIndex + 1
arrUsers(UserIndex, 0) = oUser.address
arrUsers(UserIndex, 1) = oUser.Name
arrUsers(UserIndex, 2) = oUser.PrimarySmtpAddress
End If
End If
Next i
End Sub
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.