Sub Mail_Connection()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim OutApp As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
Dim objSentFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim sFilter As String
Dim mySubject As String
Dim myItem As Outlook.MailItem
Dim Mail_count As Integer
Set objSentFolder = _
OutApp.GetNamespace("MAPI").GetDefaultFolder(6).Folders("temp")
Set myItems = objSentFolder.Items
mySubject = "Good Morning"
sFilter = "[Subject] = '" & mySubject & "'"
myItem = myItems.Find(sFilter)
Mail_count = myItems.Count
For i = 1 To Mail_count
If mySubject = myItems(i).Subject Then
ThisWorkbook.Worksheets("temp").Range("A" & i).Value = myItems(i).Body
End If
Next i
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
No comments:
Post a Comment