Excel Receiving emails straight off the internet

Hi

I was given the following  VBA code to send mail from Excel without using my Outlook.
I want to find similar code to process incoming mail using CDO. Thanks

Sub A()
    Call CDO_Mail_Small_Text_3("Johannesburg")
End Sub



Sub CDO_Mail_Small_Text_3(Location As String)
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String

    On Error GoTo SendingFailed

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    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") = "doppiosending@gmail.com"
        '.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "d0pp10sending"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "murbro9@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "mypassword"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
    End With
    
    'Adding In
    
    'If Val(Application.Version) >= 12 Then
    '    If wb.FileFormat = 51 And wb.HasVBProject = True Then
    '        MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
    '               "Save the file first as xlsm and then try the macro again.", vbInformation
    '        Exit Sub
    '    End If
    'End If

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


    
    strbody = "From Doppio" & vbNewLine & vbNewLine & _
              Location

    With iMsg
        Set .Configuration = iConf
        .To = "admin@macros-vba.com"
        '.CC = "nomusa@excelintegration.co.za"
        '.BCC = "davidt@excelintegration.co.za"
        ' Note: The reply address is not working if you use this Gmail example
        ' It will use your Gmail address automatic. But you can add this line
        ' to change the reply address  .ReplyTo = "Reply@something.nl"
        .From = """Murray"" <murbro9@gmail.com>"
        .Subject = "Doppio Cashup" & Date
        .TextBody = strbody
        '.AddAttachment Location
        .Send
    End With
    
    'If you not want to delete the file you send delete this line

    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Exit Sub
SendingFailed:
    MsgBox ("Email Could not send")
End Sub

Open in new window

Murray BrownMicrosoft Cloud Azure/Excel Solution DeveloperAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

sdwalkerCommented:
This is not great code, but it might get you started.  I use this to extract the body or attachment of an email and print it or put it in a spreadsheet tab or something.  I haven't gone back and cleaned it up because I haven't needed to and there might be some extraneous code.  But it works for us.

Good luck,

sdwalker
Public Function ExtractFromEmail(txtSubject, WhatDoYouWantToDo, Optional varDate, Optional txtFileName, Optional txtSender, Optional txtSheetName, Optional txtOutputFileName, Optional bDefaultToLatest As Boolean, Optional useSchedInbox As Boolean, Optional txtAttachmentName)

'The following code imports appropriate data from an e-mail with a specific subject to a text file
'   and performs a specified function on that email.
'
'   txtSubject = a subset of the subject line of the email (it doesn't have to be an exact match)
'
'   If WhatDoYouWantToDo = 1 then Print the body of the email
'   If WhatDoYouWantToDo = 2 then copy the body of the email to a specified tab
'   If WhatDoYouWantToDo = 3 then Print the Word document attachment(s) of the email
'   If WhatDoYouWantToDo = 4 then Open the attachment(s) of the email
'
'   varDate = (Optional) the earliest date for which a filtered result is valid
'
'   txtFileName = (Optional) the temporary name you'd like to save the attachment as
'
'   txtSender = (Optional) the name of the sender you expect the email from
'
'   txtSheetName = (Optional) the name of the sheet you'd like to copy the email to
'
'   txtOutputFileName = (Optional) the name of the file you'd like to copy the attachment to
'
'   bDefaultToLatest = (Optional) if 2 or more emails matching the criteria are found, then
'                                 automatically use the first (most recently received) one found
'
'   useSchedInbox = (Optional) if set to 'true', then look for the email in the Scheduler Inbox instead of the
'                              default Inbox
'
'   txtAttachmentName = (Optional) some text in the name of the attachment you're looking for

On Error Resume Next

Const olFolderInbox = 6
  Const olTxt = 0
  
  Set objOutlook = CreateObject("Outlook.Application")
  Set objNamespace = objOutlook.GetNamespace("MAPI")
  
  If useSchedInbox = "True" Then
    Set objFolder = objNamespace.Folders("Mailbox - Scheduler").Folders("Inbox")
  Else
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
  End If

  Set colItems = objFolder.Items
  
  sFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & txtSubject & "%'"
  Set colFilteredItems = colItems.Restrict(sFilter)
  
  numFilteredResults = colFilteredItems.Count
  
  If numFilteredResults = 0 Then
    strMsg = "Couldn't find an email with '" & txtSubject & "' in the Subject.  Please try again later."
    intError = MsgBox(strMsg, vbInformation, "No match found")
    ExtractFromEmail = False
    GoTo 990
  End If
  
  If Not IsMissing(txtSender) Then
    sFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:sendername" & Chr(34) & " like '%" & txtSender & "%'"
    Set colFilteredItems = colFilteredItems.Restrict(sFilter)
  End If
  
  If Not IsMissing(varDate) Then
    Set colFilteredItems = colFilteredItems.Restrict("[ReceivedTime] >= '" & CDate(varDate) & "'")
  End If
  
  numFilteredResults = colFilteredItems.Count
  
  If numFilteredResults = 0 Then
    
    strMsg = "Subject contains '" & txtSubject & "'" & vbCrLf
    If Not IsMissing(txtSender) Then
      strMsg = strMsg & "Sender = " & txtSender & vbCrLf
    End If
    If Not IsMissing(varDate) Then
      strMsg = strMsg & "Date Received > '" & varDate & "'"
    End If
     
    strMsg = "Couldn't find an email to match all your criteria.  Please insure there is an email with" & _
              " the following criteria:" & vbCrLf & vbCrLf & strMsg

    intError = MsgBox(strMsg, vbInformation, "No match found")
    ExtractFromEmail = False
    GoTo 990
  ElseIf numFilteredResults > 1 And numFilteredResults <= 10 Then
  
    If bDefaultToLatest = True Then
      intError = 1
    Else
      strMsg = "There are " & colFilteredItems.Count & " items which match the criteria specified." & vbCrLf & vbCrLf & _
                   "Please enter the number corresponding to the correct item displayed below." & vbCrLf & vbCrLf
  
      For i = 1 To colFilteredItems.Count
        strLine1 = i & ") Sender: " & colFilteredItems(i).SenderName
        strLine2 = "     Date: " & colFilteredItems(i).ReceivedTime
        strLine3 = "     " & colFilteredItems(i).Subject & vbCrLf & vbCrLf
        strPartb = strPartb & strLine1 & vbCrLf & strLine2 & vbCrLf & strLine3
      Next i
      
      strMsg = strMsg & strPartb
      
      intError = InputBox(strMsg, "Multiple Matches", 1)
    End If
    
    If IsNumeric(intError) Then
      intError = CInt(intError)
      If intError > 0 And intError <= numFilteredResults Then
        itemReturned = intError
      ElseIf numFilteredResults > 10 Then
        strMsg = "There are too many matches for the specified criteria.  Please remove duplicate messages from your inbox and try again."
        intError = MsgBox(strMsg, vbInformation, "Too Many Matches")
        ExtractFromEmail = False
        GoTo 990
      Else
        strMsg = "You didn't select a valid option.  Try this step again."
        intError = MsgBox(strMsg, vbInformation, "Invalid Entry")
        ExtractFromEmail = False
        GoTo 990
      End If
    
    Else
      strMsg = "You didn't select a valid option.  Try this step again."
      intError = MsgBox(strMsg, vbInformation, "Invalid Entry")
      ExtractFromEmail = False
      GoTo 990
    End If
  
  Else
    itemReturned = 1
  End If


  Select Case WhatDoYouWantToDo
    Case 1
    
      For Each objMessage In colFilteredItems
        x = x + 1
        If x = itemReturned Then
          colFilteredItems(itemReturned).PrintOut
          Exit For
        End If
      Next
    
    Case 2
    
      tmpFileName = "C:\windows\temp\" & txtFileName
      
      x = 0
      
      For Each objMessage In colFilteredItems
        x = x + 1
        If x = itemReturned Then objMessage.SaveAs tmpFileName, olTxt
      Next
     
    'The following code imports the text file and pastes it on the appropriate sheet.
    
      If txtSheetName = "" Then
        strMsg = "Tab name not provided."
        MsgBox (strMsg)
        Exit Function
      End If
    
      Sheets(txtSheetName).Select
      Cells.ClearContents
      
      Const ForReading = 1
      Set objFSO = CreateObject("Scripting.FileSystemObject")
      Set objfile = objFSO.OpenTextFile(tmpFileName, ForReading)
      
      ' Loop through all lines in file
      '
      Do Until objfile.AtEndOfStream
        strLine = objfile.ReadLine
        x = x + 1
        Range("A" & x).Value = strLine
      Loop
      
      Set objFSO = Nothing
      Set objfile = Nothing
      
      On Error Resume Next
        Kill tmpFileName
      On Error GoTo 0
    Case 3, 4
    
      numAttachments = colFilteredItems(itemReturned).Attachments.Count
      
      If numAttachments > 0 Then
        For Each atmt In colFilteredItems(itemReturned).Attachments
          If LCase(Right(atmt.Filename, 3)) = "doc" Or LCase(Right(atmt.Filename, 4)) = "docx" Or LCase(Right(atmt.Filename, 4)) = "docm" Then
            
            ' Word document
            Filename = "C:\windows\temp\" & atmt.Filename
            atmt.SaveAsFile Filename
            
              Set wrdApp = CreateObject("Word.Application")
              Set wrdDoc = wrdApp.Documents.Open(Filename)
              
              If WhatDoYouWantToDo = 3 Then
                wrdApp.Visible = False
                wrdDoc.PrintOut
                wrdDoc.Close
                wrdApp.Quit
              Else
                wrdApp.Visible = True
              End If
              
              On Error Resume Next
                Kill Filename
              On Error GoTo 0
          ElseIf LCase(Right(atmt.Filename, 3)) = "xls" Or LCase(Right(atmt.Filename, 4)) = "xlsx" Or LCase(Right(atmt.Filename, 4)) = "xlsm" Then
            
            ' Word document
            myFilename = "C:\windows\temp\" & atmt.Filename
            atmt.SaveAsFile myFilename
            
            Workbooks.Open myFilename
              
              On Error Resume Next
                Kill myFilename
              On Error GoTo 0
          ElseIf LCase(Right(atmt.Filename, 3)) = "pdf" Then
            
            ' pdf document
            ' currently, this will only open the file, it can't just print it
            Filename = "C:\windows\temp\" & atmt.Filename
            atmt.SaveAsFile Filename
            
            ActiveWorkbook.FollowHyperlink Filename
              
              On Error Resume Next
                Kill Filename
              On Error GoTo 0
          End If
        
        Next atmt
      
      End If
    
    
    Case 5
    
      numAttachments = colFilteredItems(itemReturned).Attachments.Count
    
      If numAttachments > 0 Then
        For Each atmt In colFilteredItems(itemReturned).Attachments
            
            If InStr(1, LCase(atmt.Filename), LCase(txtAttachmentName)) Then
              strFileName = "C:\windows\temp\" & atmt.Filename
              atmt.SaveAsFile strFileName
              
              If strFileName <> txtOutputFileName Then
                FileCopy strFileName, txtOutputFileName
                  
                  On Error Resume Next
                    Kill strFileName
                  On Error GoTo 0
              End If
              
            End If
          
        Next atmt
      
      End If
  End Select

  ExtractFromEmail = True

990:

End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Murray BrownMicrosoft Cloud Azure/Excel Solution DeveloperAuthor Commented:
Thanks very much
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.