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
Related
I have tried everything to read a mail from office 365 outlook but I am not able to read it. Every time Sender address is coming empty.
Error That I am getting is :
Run-time error: ‘287’
Application-defined or object-defined error.
Please find the code that I am using.
Option Explicit
Sub Mail()
Dim xNameSpace As Outlook.Namespace
Dim xFolder As Outlook.Folder
Dim xOutlookApp As Outlook.Application
Set xOutlookApp = New Outlook.Application
Set xNameSpace = xOutlookApp.Session
Set xFolder = xNameSpace.GetDefaultFolder(olFolderInbox)
Set xFolder = xFolder.Folders("Retail")
' Set Outlook application object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objNSpace As Object ' Create and Set a NameSpace OBJECT.
' The GetNameSpace() method will represent a specified Namespace.
Set objNSpace = objOutlook.GetNamespace("MAPI")
Dim myFolder As Object ' Create a folder object.
Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox)
Dim objItem As Object
Dim iRows, iCols As Integer
iRows = 2
' Loop through each item in the folder.
For Each objItem In xFolder.Items
If objItem.Class = olMail Then
Dim GetSenderAddress As String
Dim objMail As Outlook.MailItem
Set objMail = objItem
Dim mailType As String
mailType = objMail.SenderEmailType
If mailType = "EX" Then
' GetSenderAddress = GetExchangeSenderAddressNew(objMail)
FindAddress (objMail.SenderEmailAddress)
Else
GetSenderAddress = objMail.SenderEmailAddress
End If
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
End If
iRows = iRows + 1
Next
Set objMail = Nothing
' Release.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
End Sub
Private Function GetExchangeSenderAddress(objMsg As MailItem) As String
Dim oSession As Object
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
Dim sEntryID As String
Dim sStoreID As String
Dim oCdoMsg As Object
Dim sAddress As String
Const g_PR_SMTP_ADDRESS_W = &H39FE001F
sEntryID = objMsg.EntryID
sStoreID = objMsg.Parent.StoreID
Set oCdoMsg = oSession.GetMessage(sEntryID, sStoreID)
sAddress = oCdoMsg.Sender.Fields(g_PR_SMTP_ADDRESS_W).Value
Set oCdoMsg = Nothing
oSession.Logoff
Set oSession = Nothing
GetExchangeSenderAddress = sAddress
End Function
Another Code is:
Sub Mail()
Dim jsObj As New ScriptControl
jsObj.Language = "JScript"
With jsObj
.AddCode "outlookApp = new ActiveXObject('Outlook.Application'); nameSpace = outlookApp.getNameSpace('MAPI'); nameSpace.logon('','',false,false); mailFolder = nameSpace.getDefaultFolder(6); var Inbox = mailFolder.Folders; var box = Inbox.Item('Retail').Items; "
End With
End Sub
Please let me know if i can read sender address of a mail in office 365 outlook.
First of all, the following lines of code iterates over all items in the folder:
' Loop through each item in the folder.
For Each objItem In xFolder.Items
If objItem.Class = olMail Then
Where you don't check whether it is received or composed item. Composed emails may not have the Sender-related properties set yet, so you can use the CurrentUser property which returns the display name of the currently logged-on user as a Recipient object.
Note, in case of Exchange accounts configured you may use the AddressEntry.GetExchangeUser property which returns an ExchangeUser object that represents the AddressEntry if the AddressEntry belongs to an Exchange AddressList object such as the Global Address List (GAL) and corresponds to an Exchange user.
The ExchangeUser.PrimarySmtpAddress property returns a string representing the primary Simple Mail Transfer Protocol (SMTP) address for the ExchangeUser.
I have code that extracts the body of email which has the subject line "Volume data".
Let's say I have 10 emails in my inbox folder which has the subject line "Volume data".
I want to loop through all the emails, find which email has subject line "Volume data" and then extract the email body from those 10 emails.
My code is stopping at the first instance where it finds the mentioned subject.
Option Explicit
Sub impOutlookTable()
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
Exit For
End If
Next oItem
If Not oItem Is Nothing Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
'import in Excel
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
End If
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.SaveAs "C:\Users\Desktop\New_email.xlsm"
End Sub
Put all of the "Action" code inside the If statement inside your loop instead of after it, and then remove the Exit For.
You will also need a counter or something so that you aren't just saving overtop of the same file for each iteration.
UNTESTED
Option Explicit
Sub impOutlookTable()
Dim iCounter As Integer
iCounter = 1
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
'import in Excel
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.SaveAs "C:\Users\Desktop\New_email_" & iCounter & ".xlsm"
iCounter = iCounter + 1
End If
Next oItem
End Sub
I'm trying to extract first table of each mail of a specific folder to Excel. If there is more than one table in the mail we can exclude it and move to next mail item. Below is the code I have at the moment. Could you please help?
Public Sub Import_Tables_From_Outlook_Emails()
Dim oApp As Outlook.Application, oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem, HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection, table As MSHTML.HTMLTable
Dim objExcelApp As Excel.Application, x As Long, y As Long, destCell As Range
Dim objExcelWorkbook As Excel.Workbook, objExcelWorksheet As Excel.Worksheet
Set objExcelApp = CreateObject("Excel.Application") 'Create a new excel workbook
Set objExcelWorkbook = objExcelApp.Workbooks.Add
objExcelApp.Visible = True
Set destCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If oApp Is Nothing Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").PickFolder
If Not oMapi Is Nothing Then
For Each oMail In oMapi.items
'Get HTML tables from email object
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oMail.HTMLBody
Set tables = .getElementsByTagName("table")
End With
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = _
table.Rows(x).Cells(y).innerText
Next y
Next x
Sheets.Add After:=ActiveSheet
Range("A1").Activate
Set destCell = ActiveSheet.Range("A1")
Next
Next
End If
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
MsgBox "Finished"
End Sub
The following macro prompts the user to select a folder from Outlook, loops though each item in the folder, and copies the first table from each item to a separate worksheet in a newly created workbook.
Edit
The code has been edited to 1) restrict the mail items based on ReceivedTime, 2) sort the restricted items by ReceivedTime, and in descending order, 3) loop through the items from earliest to latest date.
Option Explicit
Public Sub Import_Tables_From_Outlook_Emails()
Dim oMapiFolder As Folder
Dim oMail As Object
Dim oMailItems As Object
Dim oRestrictItems As Object
Dim oHTMLDoc As Object
Dim oHTMLTable As Object
Dim xlApp As Object
Dim xlWkb As Object
Dim r As Long
Dim c As Long
Dim i As Long
Set oMapiFolder = Application.GetNamespace("MAPI").PickFolder
If oMapiFolder Is Nothing Then
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
End If
On Error GoTo 0
Set xlWkb = xlApp.workbooks.Add(-4167) 'xlWBATWorksheet
Set oHTMLDoc = CreateObject("htmlfile")
Set oMailItems = oMapiFolder.Items
Set oRestrictItems = oMailItems.Restrict("[ReceivedTime] >= '" & Format("1/1/17 12:00am", "ddddd h:nn AMPM") & "'")
oRestrictItems.Sort "[ReceivedTime]", olDescending
For i = 1 To oRestrictItems.Count
Set oMail = oRestrictItems(i)
With oHTMLDoc
.Body.innerHTML = oMail.HTMLBody
Set oHTMLTable = .getElementsByTagName("table")(0)
End With
If Not oHTMLTable Is Nothing Then
xlWkb.Worksheets.Add after:=xlWkb.activesheet
For r = 0 To oHTMLTable.Rows.Length - 1
For c = 0 To oHTMLTable.Rows(r).Cells.Length - 1
xlWkb.activesheet.Range("A1").Offset(r, c).Value = _
oHTMLTable.Rows(r).Cells(c).innerText
Next c
Next r
Set oHTMLTable = Nothing
End If
Next i
xlApp.DisplayAlerts = False
xlWkb.Worksheets(1).Delete
xlApp.DisplayAlerts = True
Application.ActiveExplorer.Activate
Set oMapiFolder = Nothing
Set oMail = Nothing
Set oHTMLDoc = Nothing
Set oHTMLTable = Nothing
Set xlApp = Nothing
Set xlWkb = Nothing
MsgBox "Finished"
End Sub
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
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