Karen Schaefer
asked on
Download attached files from Gmail by VBA (Excel 2016)
My company is currently using GMAIL, I do not have access to Outlook. I currently have VBA code the generates Gmail emails. I was hoping that I may be able to modify this in some way so that I can grab email attachments from a specific email. I get several gmail emails with attachments that currently need to be manually downloaded then moved to the various files. I may even consider add-in for Excel.
After researching the web without much success, I am turning to you guys to point me in the right direction.
Here is my current code:
After researching the web without much success, I am turning to you guys to point me in the right direction.
Here is my current code:
Public Sub Email()
On Error GoTo Email_Error
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim strSubject As String
Dim Flds As Variant
Dim FilePath As String
Dim FilePath1 As String
Dim FilePath2 As String
Dim nMth As String
Dim curDate As String
Dim nDate As String
Dim nName As String
Dim strContact As String
Dim strTo As String
Dim strFrom As String
Dim aCell As Range
Dim bolFound As Boolean
Dim ws As Worksheet
nDate = Format(Date, "mmddyyyy")
nMth = Format(DateSerial(Year(Date), Month(Date), 1) - 1, "mmm yyyy")
curDate = Format(Date, "mmm dd, yyyy")
bolFound = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "ContactList" Then bolFound = True
Next ws
If bolFound = False Then
MsgBox "Couldn't find the required sheet." & Chr(10) & _
"Aborting..."
End If
With ThisWorkbook.Worksheets("ContactList")
For Each aCell In .Range("A:E")
If aCell.Offset(1, 0).Value2 = .Range("M2").Value2 Then
nName = aCell.Offset(1, 1).Value2
nName = ReplaceAll(nName, " ", "_")
If aCell.Offset(1, 2).Value2 = "From" Then
strFrom = aCell.Offset(1, 3).Value2
End If
Select Case aCell.Offset(1, 2).Value2
Case "Val"
strTo = "'" & aCell.Offset(0, 3).Value2 & "'"
strContact = aCell.Offset(0, 4).Value2
GoTo cont:
Case "Invoice"
strTo = strTo & "'" & aCell.Offset(0, 3).Value2 & _
";" & "'"
End Select
End If
Next aCell
cont:
End With
nName = Sheets("MainForm").Range("B3").Value2 & "_" & Sheets("MainForm").Range("D3").Value2
FilePath = ""
FilePath = Sheets("MainForm").Range("B3").Value & "\" & nMth & "\" & _
nName & "_" & ReplaceAll(nMth, " ", "_") & "_" & "Invoice.pdf"
' FilePath = Sheets("ContactList").Range("Q2").Value & "\" & nMth
FilePath1 = FilePath & "\" & nName & "_" & ReplaceAll(nMth, " ", "_") & _
"_" & "Invoice.pdf"
FilePath2 = FilePath & "\" & nName & "_" & nDate & "_Invoice.xlsx"
' FilePath = Sheets("ContactList").Range("Q2").Value & "\" & nMth & "\" & nName & "_" & nDate & "_Invoice.xlsx"
If FileFolderExists(FilePath) = False Then
CreateNewDirectory (FilePath)
End If
If Dir(FilePath1, vbDirectory) = vbNullString Or Dir(FilePath2, _
vbDirectory) = vbNullString Then
If _
MsgBox("File not found, do you wish to create the files for " _
& nName & "_" & nDate & "_Invoice.xlsx and " & nName & "_" _
& ReplaceAll(nMth, " ", "_") & "_" & "Invoice.pdf ?", _
vbYesNo, "Create New File") = vbYes Then
'SaveFinalData
CreatePDF
End If
End If
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") _
= True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") _
= 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") _
= strFrom
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "aspmx.l.google.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") _
= 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") _
= 25
.Update
End With
'Sends Validation Email prior to emailing Invoice to Customer
If ActiveSheet.OLEObjects("CheckBox1").Object.Value = True Then
strSubject = "Quotewizard" & " " & nMth & ", Invoice for " & _
ReplaceAll(nName, "_", " ") & " Review"
strbody = strContact & "," & vbNewLine & vbNewLine & _
"Please find attached the invoice for" & " " & nMth & "." & _
vbNewLine & vbNewLine & _
"Please validate changes and indicate any discrepancies." & _
vbNewLine & vbNewLine & "Thank you," & vbNewLine & vbNewLine & _
"Karen"
Else
strSubject = "Quotewizard" & " " & nMth & ", Invoice for " & nName _
& ""
strbody = "Please find attached the invoice for" & " " & nMth & "." & _
vbNewLine & vbNewLine & _
"Should you have any questions please contact your account representative." & _
vbNewLine & vbNewLine & "Thank you," & vbNewLine & vbNewLine & _
"KFS & vbNewLine & _
"Financial Operations Analyst"
End If
On Error GoTo 0
If Len(strTo) > 0 Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.TO = strFrom 'strTo
.From = strFrom
.Subject = strSubject
.TextBody = strbody
'Attaches the PDF file to Email
.AddAttachment FilePath1
'Attacheds the xlsx file to Email
.AddAttachment FilePath2
.Send
' .Display
End With
Set iMsg = Nothing
End If
On Error GoTo 0
Exit Sub
Email_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Email of Sub modSaveFinalData"
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
thanks for your input, however, no longer on project
ASKER