How can I send mails automatically based on criteria?
I want to open the mail based on the subject provided in column A, add default content and forward this mail to the email address provided in Column B.
I know how to open an Outlook mail based on the subject.
Sub Test()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "") <> 0 Then
olMail.Display
i = i + 1
End If
Next olMail
End Sub
Subject (column A) Send to (Column B)
SP12345667 aaa#gmail.com
SP12345668 bbb#gmail.com
SP12345669 xxx#abc.com
SP12345670 yyy#abc.com
SP12345671 mmm#abc.com
SP12345672 nnn#abc.com
SP12345673 yyy#abc.com
Here is an Example on how to loop...
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As MailItem
Dim MsgFwd As MailItem
Dim Items As Outlook.Items
Dim Recip As Recipient
Dim Email As String
Dim ItemSubject As String
Dim lngCount As Long
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
i = 2 ' i = Row 2
With Worksheets("Sheet1") ' Sheet Name
Do Until IsEmpty(.Cells(i, 1))
ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1)
Email = .Cells(i, 2).Value '(i, 2) = (Row 2,Column 2)
'// Loop through Inbox Items backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items.Item(lngCount)
If Item.Subject = ItemSubject Then ' if Subject found then
Set MsgFwd = Item.Forward
Set Recip = MsgFwd.Recipients.Add(Email) ' add Recipient
Recip.Type = olTo
MsgFwd.Display
End If
Next ' exit loop
i = i + 1 ' = Row 2 + 1 = Row 3
Loop
End With
Set olApp = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set Item = Nothing
Set MsgFwd = Nothing
Set Items = Nothing
End Sub
Related
I want to retrieve the content of an email with a certain subject which is linked to a cell value in a different column.
Code from If Outlook Subject and Date Received works with the exception of range.
Instead of one cell value (ex. A1) I want to retrieve from the full column A. So that for each value in column A (which is in this case the date) the content of the e-mail which contains as subject "always the same title" & "date of cells in column A".
Example
A1 = 16/08/2019 ==> e-mail subject = 16/08Title ==> B2 = content of said e-mail
A2 = 20/08/2019 ==> e-mail subject = 20/08Title ==> B2 = content of said e-mail
Sub GetFromInbox ()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = OlFldr.Items
olItms.Sort "Subject"
i =1
For Each olMail In olItms
If InStr (1, olMail.Subject, "Subject" & Range ("A1") > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i,2).Value = olMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
I tried changing Range ("A1") to range ("A:A").
This gives
runtime error 13: Type mismatch
I tried different ways to offset.
Sub GetFromInbox ()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = OlFldr.Items
olItms.Sort "Subject"
i =1
For Each olMail In olItms
If InStr (1, olMail.Subject, "Subject" & Range ("A1") > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i,2).Value = olMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Create a for loop that will loop through all of the rows of column A.
LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
'Finding the last row in Column A
For Each olMail In olItms
For j = 1 To LastRow
If InStr (1, olMail.Subject, "Subject" & Range ("A" & j) > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i,2).Value = olMail.Body
i = i + 1
End If
Next j
Next olMail
How do I get the top 50 emails from Outlook using Excel VBA from new to old?
I am using the code below, however this is fetching the emails from last to first.
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
i = 1
x = Date
For Each olMail In Fldr.Items
ActiveSheet.Cells(i, 1).Value = olMail.Subject
ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.SenderName
i = i + 1
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Sort a collection of the items in the folder.
Option Explicit
Sub GetFromInbox()
Dim olApp As outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim sortItems As Items
Dim olObj As Object
Dim i As Long
Dim maxIter As Long
Set olApp = New outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
' Sort a collection of items, not Fldr.Items
Set sortItems = Fldr.Items
sortItems.Sort "[Received]", True
If sortItems.count > 50 Then
maxIter = 50
Else
maxIter = sortItems.count
End If
For i = 1 To maxIter
Set olObj = sortItems(i)
If olObj.Class = olMail Then
ActiveSheet.Cells(i, 1).Value = olObj.subject
ActiveSheet.Cells(i, 2).Value = olObj.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olObj.senderName
End If
Next
Set olObj = Nothing
Set sortItems = Nothing
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
If this grabs the wrong 50 emails you can try stepping through items the opposite way like:
For i = Fldr.Items.Count To Fldr.Items.Count - 50 Step -1
ActiveSheet.Cells(i, 1).Value = Fldr.Items(i).Subject
etc...
Add an exit once you hit 50, for ex:
If counter = 50 Then Exit For
Also, you can alternatively keep your existing code, then add a function to sort the emails by received date and only keep the top 50
I'm trying to get the .To email address from my sent box using Excel-VBA. However, To only returns the name not the email address. After some search found that the recipient should be what I'm looking for. Tried by following the msdn guide, but the code does not seem to work.
Sub test()
Dim objoutlook As Object
Dim objNamespace As Object
Dim olFolder As Object
Dim OutlookMail As outlook.MailItem
Set objoutlook = CreateObject("Outlook.Application")
Set objNamespace = objoutlook.GetNamespace("MAPI")
Set olFolder = objNamespace.GetDefaultFolder(olFolderSentMail)
Set OutlookMail = objoutlook.CreateItem(olMailItem)
Dim recips As outlook.Recipients
Dim recip As outlook.Recipient
Dim pa As outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = OutlookMail.Recipients
For Each recip In recips 'Something is wrong here
Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
Next
Set olFolder = Nothing
Set objNamespace = Nothing
Set objoutlook = Nothing
End Sub
I'm not really familiar with VBA, please guide along.
You can try this:
Private Sub GetRecipientSMTP(objAllRecip As Outlook.Recipients)
Dim objRecip As Outlook.Recipient
Dim objExUser As Outlook.ExchangeUser
Dim objExDisUser As Outlook.ExchangeDistributionList
For Each objRecip In objAllRecip
Select Case objRecip.AddressEntry.AddressEntryUserType
Case 0, 10
Set objExUser = objRecip.AddressEntry.GetExchangeUser
If Not objExUser Is Nothing Then _
Debug.Print objExUser.PrimarySmtpAddress '/* or copy somewhere */
Case 1
Set objExDisUser = objRecip.AddressEntry.GetExchangeDistributionList
If Not objExDisUser Is Nothing Then _
Debug.Print objExDisUser.PrimarySmtpAddress '/* or copy somewhere */
Case Else
'/* Do nothing, recipient not recognized */
End Select
Next
End Sub
You can run it in your sub like below using recips from your code (or see sample usage).
GetRecipientSMTP recips
Basically, this will check on the each Recipient on Recipients you supplied. Then will check if it is an ExchangeUser type or ExchangeDistributionList before returning the PrimartSMTPAddress. HTH.
Sample Usage:
Sub marine()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olMail As Outlook.MailItem
Dim i As Integer
Set olApp = GetObject(, "Outlook.Application") '/* assuming OL is running */
Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
With olFolder
For i = .Items.Count To 1 Step -1
If TypeOf .Items(i) Is MailItem Then
Set olMail = .Items(i)
GetRecipientSMTP olMail.Recipients
End If
Exit For '/* I just want to process the first mail */
Next
End With
End Sub
Note: I used early binding and set reference to Outlook Object Library.
Quick Example
Option Explicit
Public Sub Example()
Dim OUTLOOK_APP As Outlook.Application
Dim olNs As Outlook.Namespace
Dim SENT_FLDR As MAPIFolder
Dim Items As Outlook.Items
Dim olRecip As Outlook.Recipient
Dim olRecipAddress As String
Dim i As Long
Set OUTLOOK_APP = New Outlook.Application
Set olNs = OUTLOOK_APP.GetNamespace("MAPI")
Set SENT_FLDR = olNs.GetDefaultFolder(olFolderSentMail)
Set Items = SENT_FLDR.Items
For i = Items.Count To 1 Step -1
DoEvents
If Items(i).Class = olMail Then
For Each olRecip In Items(i).Recipients
olRecipAddress = olRecip.Address
Debug.Print olRecipAddress
Next
End If
Next
End Sub
this is my way of getting Recipient email Address. I hope it would help you.
Sub CopyCurrentContact()
Dim objRcp As Outlook.Recipient
Dim objRcpS As Outlook.Recipients
Dim rcpStr As String
Set outLookObj = CreateObject("Outlook.Application")
Set InspectorObj = outLookObj.ActiveInspector
Set ItemObj = InspectorObj.CurrentItem
Set objRcpS = ItemObj.Recipients
For Each objRcp In objRcpS
rcpStr = objRcp.Address & "; " & rcpStr
Debug.Print rcpStr
Next objRcp
End Sub
I'm trying to export Outlook messages with tables to Excel.
All mails are in the same mailbox, have the same subject and can contain multiple tables with varying number of rows.
I get the first mail, but it won't loop through the entire mailbox.
Option Explicit
Sub impToExcel()
' point to the desired email
Const strMail As String = "jonfo#company.com"
Dim oApp As Outlook.Application
Dim Nsp As Namespace
Dim Fldr As MAPIFolder
Dim oMail As Outlook.MailItem
Dim Var As Variant
Set oApp = New Outlook.Application
Set Nsp = oApp.GetNamespace("MAPI")
Set Fldr = Nsp.GetDefaultFolder(olFolderInbox).Folders("Svar")
Set oMail = Fldr.Items(Fldr.Items.Count)
' get html table from email object
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim oElColl As MSHTML.IHTMLElementCollection
With oHTML
.body.innerHTML = oMail.HTMLBody
Set oElColl = .getElementsByTagName("table")
End With
'import in Excel
Dim x As Long, y As Long
For Each Var In Fldr.Items
For x = 0 To oElColl(0).Rows.Length - 1
For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
Range("A1").Offset(x, y).Value = oElColl(0).Rows(x).Cells(y).innerText
Next y
Next x
Next Var
Set oApp = Nothing
Set Fldr = Nothing
Set oMail = Nothing
Set oHTML = Nothing
Set oElColl = Nothing
End Sub
I am to write a VBA code that would retrive emails from Outlook based on certain conditions. The problem I have is that I have to denote a certain folder in my code (in the example below the folder denoted is "PRE Costumer". I would like to retrive all emails from my 'inbox' or in better case from all outlook folders. The problem is that my inbox consists of many subfolders (because of rules0. My problem is that I may not know all the subfolders names (as many useres are going to use the macro and even someone can have the e mails in Personal Folders).
Could you please advise is there a way to overcome this problem?
Please let me know if this question is vague (as I am newcomer)
Please find the line that I have probelm with marked with a comment.
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
'Below is the line I have problem with
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
i = 1
x = Date
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
ActiveSheet.Cells(i, 1).Value = olMail.Subject
ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.SenderName
i = i + 1
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Just loop through all the folders in Inbox.
Something like this would work.
Edit1: This will avoid blank rows.
Sub test()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Set ws = Activesheet '~~> or you can be more explicit using the next line
'Set ws = Thisworkbook.Sheets("YourTargetSheet")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
'Debug.Print eFolder.Name
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
With ws
lrow = .Range("A" & .Rows.Count).End(xlup).Row
.Range("A" & lrow).Offset(1,0).value = olMail.Subject
.Range("A" & lrow).Offset(1,1).Value = olMail.ReceivedTime
.Range("A" & lrow).Offset(1,2).Value = olMail.SenderName
End With
End If
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
Above takes care of all subfolders in Inbox.
Is this what you're trying?
To fix your error (olFolderInbox is a Outlook only constant, so you need to define it in vba that is not Outlook):
Const olFolderInbox = 6
'...
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Also to prevent missing Reference when run from another computer, I would:
Dim olApp As Object
Dim olNs As Object
Dim Fldr As Object
Dim olMail As Object
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
'...
You might also want to disable ScreenUpdating, then enable it in Excel if you expect a long list.
UPDATE (Solution for all folders from a Root Folder)
I used something slightly different for comparing the dates.
Option Explicit
Private lRow As Long, x As Date, oWS As Worksheet
Sub GetFromInbox()
Const olFolderInbox = 6
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object ' Root folder to start
Dim lCalcMode As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Set oWS = ActiveSheet
x = Date
lRow = 1
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
GetFromFolder oRootFldr
Application.ScreenUpdating = True
Application.Calculation = lCalcMode
Set oWS = Nothing
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub GetFromFolder(oFldr As Object)
Dim oItem As Object, oSubFldr As Object
' Process all mail items in this folder
For Each oItem In oFldr.Items
If TypeName(oItem) = "MailItem" Then
With oItem
If InStr(1, .Subject, "transactions", vbTextCompare) > 0 And DateDiff("d", .ReceivedTime, x) = 0 Then
oWS.Cells(lRow, 1).Value = .Subject
oWS.Cells(lRow, 2).Value = .ReceivedTime
oWS.Cells(lRow, 3).Value = .SenderName
lRow = lRow + 1
End If
End With
End If
Next
' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub