Outlook macro to parse emails into an Excel sheet

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

‹ Ascending Post Order for Category Pages in Wordpress 2012

Value-driven User Stories ›

Posted in Uncategorized