Option Explicit Sub Test() Dim myFolder As MAPIFolder Dim Item As Variant 'MailItem Dim xlApp As Object 'Excel.Application Dim xlWB As Object 'Excel.Workbook Dim xlSheet As Object 'Excel.Worksheet Dim xlRow As Long Dim Lines() As String Dim aLine As String Dim FileName As String FileName = "C:\Data\inbox.xls" Dim I As Long 'Try access to excel On Error Resume Next Set xlApp = GetObject(, "Excel.Application" ) If xlApp Is Nothing Then Set xlApp = CreateObject( "Excel.Application" ) If xlApp Is Nothing Then MsgBox "Excel is not accessable" Exit Sub End If End If On Error GoTo 0 'Add a new workbook Set xlWB = xlApp.Workbooks.Add Set xlSheet = xlWB.ActiveSheet 'Access the outlook inbox folder Set myFolder = GetNamespace( "MAPI" ).GetDefaultFolder(olFolderInbox) 'Visit all mails For Each Item In myFolder.Items If TypeOf Item Is MailItem Then If Item.Subject Like "*keyword*" Then xlRow = xlRow + 1 Lines = Split(Item.Body, "," ) For I = 0 To UBound(Lines) aLine = Trim(Lines(I)) aLine = Replace(aLine, vbCr, "" ) aLine = Replace(aLine, vbLf, "" ) xlSheet.Cells(xlRow, I + 1) = aLine Next End If End If Next With xlApp With xlWB .SaveAs FileName:=FileName .Close End With .Quit ' Close our copy of Excel End With Set xlApp = Nothing ' Clear reference to Excel End Sub
Advertisements
Leave a Reply