VBA import gmail emails into Excel

VBA import gmail emails into Excel

This Excel Macro will allow you to connect to your google email (gmail) account via pop/imap and then you can pull all your gmail emails into Excel.  You have to change a few settings in GMAIL before the macro will work, 1) Allow pop/imap and 2) Allow less secure apps.   You also have to install reference library eagetmail: EAgetmail (723 downloads)

If the macro is able to successfully connect to your GMAIL account it will display "Connected to server: success".  If you get this error message "[AUTH] Web login required: https://support.google.com/mail/bin/answer.py?answer=78754" it likely means your GMAIL security settings are blocking the sign in attempt from the macro and you will need to change your GMAIL settings before the macro will work.

 

Download Files:

Pull GMAIL Data V2 (425 downloads)

EAgetmail (723 downloads)

Change your Google  GMAIL Security Settings:
  1. Setting allow pop/imap - click gear icon -> settings -> Forwarding and POP/IMAP -> Select enable POP for all mail and Enable IMAP.
  2. Allow less secure apps - Click square in top right corner -> My Account -> Sign-in & Security -> Flip Allow less secure apps: to ON.  (This will allow the macro to connect to your gmail account)  I would recommend flipping this setting back to OFF after your have pulled all your emails.
  3. Also make sure dual authentication is disabled.
EAGetMail library:

Install eagetmail.exe and then Enable Reference Library: EAGetMailObj ActiveX Object 1.0 Type Library

Open Excel -> hit Alt F11 -> Click Tools -> References -> Click EAGetMailObj ActiveX Object 1.0 Type Library -> hit Ok.

VBA GMAIL EMAIL IMPORT

Sub GetEmails()
Application.DisplayStatusBar = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'https://www.emailarchitect.net/eagetmail/ex/b/7.aspx

Sheets(1).Select
Cells.ClearContents



Dim curpath As String
 Dim mailbox As String
 Dim oTools As New EAGetMailObjLib.Tools

Const MailServerPop3 = 0
 Const MailServerImap4 = 1
 Const MailServerEWS = 2
 Const MailServerDAV = 3
Dim usern, pw As String

usern = Sheets("Login").Cells(1, 2).Value
pw = Sheets("Login").Cells(2, 2).Value

Dim oServer As New EAGetMailObjLib.MailServer
 oServer.Server = "pop.gmail.com"
 oServer.User = usern
 oServer.Password = pw
 
 oServer.Protocol = MailServerPop3
 oServer.SSLConnection = True
 oServer.Port = 995
 
 ' If your POP3 requires SSL connection
 ' Please add the following codes
 Sheets(1).Select
 Cells(1, 1).Value = "Subject"
 Cells(1, 2).Value = "From"
 Cells(1, 3).Value = "Recieved"
 Cells(1, 4).Value = "CC"
 Cells(1, 5).Value = "Body"
 Cells(1, 6).Value = "Size"



On Error GoTo ErrorHandle:
 Dim oClient As New EAGetMailObjLib.MailClient
 oClient.LicenseCode = "TryIt"

oClient.Connect oServer
 MsgBox "Connected to server: success"
 
 Dim infos
 'oClient.GetMailInfosParam.GetMailInfosOptions = GetMailInfosOptionType.All
 
 infos = oClient.GetMailInfos()
 MsgBox UBound(infos) + 1 & " emails"
 Dim i As Integer
 
 i = 1
 
 For i = LBound(infos) To UBound(infos)
 
 Dim info As EAGetMailObjLib.MailInfo
 Set info = infos(i)
 ' MsgBox "Index: " & info.Index & "; Size: " & info.Size & _
 ' "; UIDL: " & info.UIDL

' Receive email from POP3 server
 Dim oMail As EAGetMailObjLib.Mail
 Set oMail = oClient.GetMail(info)
 Dim subJ, txtBody, emlBody, recFrom As String
 Dim recDate, ccList As Variant
 
 subJ = oMail.Subject
 recFrom = oMail.From.Address
 emlBody = oMail.HtmlBody
 recDate = oMail.ReceivedDate
 txtBody = oMail.TextBody
 ccList = oMail.Cc
 
 Sheets(1).Select
 Cells(i + 2, 1).Value = subJ
 Cells(i + 2, 2).Value = recFrom
 Cells(i + 2, 3).Value = recDate
 Cells(i + 2, 4).Value = ccList
 Cells(i + 2, 5).Value = txtBody
 Cells(i + 2, 6).Value = info.Size

Next


 Cells.Select
 Selection.RowHeight = 18.75
 
 Exit Sub
 
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

ErrorHandle:
 MsgBox Err.Description
End Sub

Excel VBA insert Excel table into body of email message

 

*Update the rng to be the range of the table

 Set rng = Range(Cells(1, 1), Cells(rws, cols))

*Update your email details

 With OutMail
 .To = ""
 .CC = ""
 .BCC = ""
 .Subject = "This is the Subject line"

 

Range to HTML - Insert Excel table into body of email

Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
 Dim rng As Range
 Dim OutApp As Object
 Dim OutMail As Object

Set rng = Nothing
 On Error Resume Next
 'Only the visible cells in the selection
 rws = ActiveSheet.UsedRange.Rows.Count
 cols = ActiveSheet.UsedRange.Columns.Count
 Set rng = Range(Cells(1, 1), Cells(rws, cols))
 rng.Select
 'You can also use a fixed range if you want
 'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
 On Error GoTo 0

If rng Is Nothing Then
 MsgBox "The selection is not a range or the sheet is protected" & _
 vbNewLine & "please correct and try again.", vbOKOnly
 Exit Sub
 End If

With Application
 .EnableEvents = False
 .ScreenUpdating = False
 End With

Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
 With OutMail
 .To = ""
 .CC = ""
 .BCC = ""
 .Subject = "This is the Subject line"
 .HTMLBody = RangetoHTML(rng)
 .Display
 End With
 On Error GoTo 0

With Application
 .EnableEvents = True
 .ScreenUpdating = True
 End With

Set OutMail = Nothing
 Set OutApp = Nothing
End Sub



Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
 Dim fso As Object
 Dim ts As Object
 Dim TempFile As String
 Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
 rng.Copy
 Set TempWB = Workbooks.Add(1)
 With TempWB.Sheets(1)
 .Cells(1).PasteSpecial Paste:=8
 .Cells(1).PasteSpecial xlPasteValues, , False, False
 .Cells(1).PasteSpecial xlPasteFormats, , False, False
 .Cells(1).Select
 Application.CutCopyMode = False
 On Error Resume Next
 .DrawingObjects.Visible = True
 .DrawingObjects.Delete
 On Error GoTo 0
 End With

'Publish the sheet to a htm file
 With TempWB.PublishObjects.Add( _
 SourceType:=xlSourceRange, _
 Filename:=TempFile, _
 Sheet:=TempWB.Sheets(1).Name, _
 Source:=TempWB.Sheets(1).UsedRange.Address, _
 HtmlType:=xlHtmlStatic)
 .Publish (True)
 End With

'Read all data from the htm file into RangetoHTML
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
 RangetoHTML = ts.readall
 ts.Close
 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
 "align=left x:publishsource=")

'Close TempWB
 TempWB.Close savechanges:=False

'Delete the htm file we used in this function
 Kill TempFile

Set ts = Nothing
 Set fso = Nothing
 Set TempWB = Nothing
End Function

Excel VBA get File Attached to Outlook Email

Save Outlook Attachment from 1 email

This VBA will connect to an Outlook folder and save the attachment to a folder.

*Update ipath to filepath where you want to save the attachment to

*Update .Item("BoxName").Folders("Inbox") with your Outlook Folders name.

*Update .Items(1) to be the email number of the email your trying to grab

Dim myAttachments As Outlook.Attachments
 
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders.Item("BoxName").Folders("Inbox")
'myFolder.Display

Set myItem = myFolder.Items(1)
myItem.Display

Set myAttachments = myItem.Attachments
ipath = "Z:\Dylan\"
myAttachments.Item(1).SaveAsFile ipath & myAttachments.Item(1).DisplayName

MsgBox myAttachments.Item(1).DisplayName & " has been saved to " & ipath

 

Save All Outlook Email Attachments from Folder

If you want to save the attachments of all emails in the folder then just add a for loop replacing items(1) with items(i).

Dim myAttachments As Outlook.Attachments
 
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders.Item("BoxName").Folders("Inbox")
'myFolder.Display

itemsCount = myFolder.Items.Count
i = 0
For i = 1 To itemsCount

Set myItem = myFolder.Items(i)
myItem.Display

Set myAttachments = myItem.Attachments
If myItem.Attachments.Count > 0 Then
 ipath = "Z:\Dylan\attachments\"
 On Error Resume Next
 myAttachments.Item(i).SaveAsFile ipath & myAttachments.Item(i).DisplayName
 ' MsgBox myAttachments.Item(i).DisplayName & " has been saved to " & ipath
 On Error GoTo 0
End If