Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Excel Receiving emails straight off the internet

Posted on 2011-04-20
2
Medium Priority
?
293 Views
Last Modified: 2012-05-11
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

0
Comment
Question by:Murray Brown
2 Comments
 
LVL 12

Accepted Solution

by:
sdwalker earned 2000 total points
ID: 35432851
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
 

Author Closing Comment

by:Murray Brown
ID: 35440231
Thanks very much
0

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

810 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question