Need help with VBA script

hmattert · Mar 3, 2011

I have office 07 and need a script that will export information from the body of my email to excel.

The information is in the body like this

Header info

 Contact Us" request from xxxxx.com, dated Mar 03, 2011

11.111.11.111
Al noname
4000 Edge St.
<none>
Philadelphia PA 19136
(555) 555-5555
anemailaddy@email.com

My wife and I are intrested in a this or that product or we have this complaint.

I need to get the name, street address, city and state, the phone number, and the email address into an excel sheet all with their own columns.

the column headers would look as such
Name Street City/State Phone Email Comments

Any help at all would be greatly appreciated.

Thank you so much,
Heather

Warship · Mar 3, 2011

It may be easier to use VBA in Outlook.
You should be able monitor emails as they come in and have Outlook do the dirty work.

Just a thought...

Have a look at: www.outlookcode.com

hmattert · Mar 3, 2011

Yes, That is what I want to do. Use a VBA script in Outlook 2007 to export the info from the emails in one of my folders to excel. I'm just not sure how to write a script and everything i've found so far only exports the header info.

Thank you,

Heather

Ruddles · Mar 3, 2011

This should do what you want: as it stands it exports all your mail to a worksheet but there's a bit of code (highlighted in blue) where you can filter on dates, subjects, sender, etc.

Create a new workbook and paste the code into a new standard module; add a reference to Microsoft Outlook Objects Library (Tools > References); change the variable RootFolder; and run the SelectOutlookMail.

Code:

[FONT=Courier New][SIZE=1]Option Explicit
Option Compare Text[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Dim RootFolder As String[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.Namespace
Dim oParentFolder As Outlook.MAPIFolder
Dim ws As Worksheet[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Dim intTotalItems As Long
Dim intRowPointer As Long[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Public Sub SelectOutlookMail()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim dteTimer As Date
  
  RootFolder = "[COLOR=red][B]Personal Folders[/B][/COLOR]"
   
  dteTimer = Now()
  
  Set OlApp = CreateObject("Outlook.Application")
  Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
  Set oParentFolder = oMAPI.Folders(RootFolder)
  
  Set ws = Sheets("[COLOR=red][B]Sheet1[/B][/COLOR]")
  ws.Activate
  ws.Columns("A:S").ClearContents
  
  intTotalItems = 0
  Call CountAllItems(oParentFolder)
  
  Call ColumnHeaders
    
  intRowPointer = 1
  Application.Cursor = xlWait
  Call ProcessFolder(oParentFolder)
  Application.Cursor = xlDefault
  
  MsgBox vbCrLf & "Done: " & CStr(intTotalItems) & " items scanned, " _
     & CStr(intRowPointer - 1) & " items selected" & Space(10) & vbCrLf & vbCrLf _
     & "Run time: " & Format(dteTimer - Now(), "hh:nn:ss"), vbOKOnly + vbInformation
     
  ActiveWindow.ScrollRow = 1
  
  Set OlApp = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub CountAllItems(StartFolder As Outlook.MAPIFolder)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim uFolder As Outlook.MAPIFolder
  Dim MailObject As Object
  
  If StartFolder.DefaultItemType = 0 And StartFolder.FolderPath <> "\\" & RootFolder Then
    intTotalItems = intTotalItems + StartFolder.Items.Count
  End If[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  If StartFolder.DefaultItemType = 0 Then
    For Each uFolder In StartFolder.Folders
      Call CountAllItems(uFolder)
    Next uFolder
  End If
      
  Set uFolder = Nothing
    
End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim uFolder As Outlook.MAPIFolder
  
  If StartFolder.DefaultItemType = 0 Then
    Call ProcessItems(StartFolder, StartFolder.Items)
    For Each uFolder In StartFolder.Folders
      Call ProcessFolder(uFolder)
    Next uFolder
  End If
       
  Set uFolder = Nothing
    
End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim MailObject As Object
  Dim intAttachment As Integer[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  For Each MailObject In Collection
    DoEvents
    If TypeOf MailObject Is MailItem Then
[/SIZE][/FONT][FONT=Courier New][SIZE=1][COLOR=green]      ' this is where we decide if we want to select the mail item
[/COLOR][COLOR=blue][B]      If MailObject.SentOn >= DateValue("01/01/2011") And _
         MailObject.SentOnBehalfOfName <> "Facebook" Then
[/B][/COLOR]        intRowPointer = intRowPointer + 1
        ws.Rows(intRowPointer).EntireRow.Select
        ws.Cells(intRowPointer, 1) = MailObject.SentOn
        ws.Cells(intRowPointer, 2) = MailObject.SenderName
        ws.Cells(intRowPointer, 3) = MailObject.SenderEmailAddress
        ws.Cells(intRowPointer, 3) = MailObject.SentOnBehalfOfName
        ws.Cells(intRowPointer, 5) = MailObject.To
        ws.Cells(intRowPointer, 6) = MailObject.CC
        ws.Cells(intRowPointer, 7) = MailObject.BCC
        ws.Cells(intRowPointer, 8) = MailObject.ReceivedByName
        ws.Cells(intRowPointer, 9) = MailObject.ReceivedOnBehalfOfName
        ws.Cells(intRowPointer, 10) = MailObject.ReplyRecipientNames
        ws.Cells(intRowPointer, 11) = MailObject.Subject
        ws.Cells(intRowPointer, 12) = MailObject.Body
        ws.Cells(intRowPointer, 13) = MailObject.HTMLBody
        ws.Cells(intRowPointer, 14) = MailObject.Importance
        ws.Cells(intRowPointer, 15) = MailObject.Attachments.Count
        ws.Cells(intRowPointer, 16) = ""
        For intAttachment = 1 To MailObject.Attachments.Count
          ws.Cells(intRowPointer, 16) = ws.Cells(intRowPointer, 16) & ";" & MailObject.Attachments(intAttachment).Filename
[/SIZE][/FONT][FONT=Courier New][SIZE=1][COLOR=green]          ' we may want to save some or all of the attachments
          ' MailObject.Attachments(intAttachment).SaveAsFile "C:\Temp\" & MailObject.Attachments(intAttachment).FileName
[/COLOR]        Next intAttachment
        ws.Cells(intRowPointer, 16) = Mid(ws.Cells(intRowPointer, 16), 2) ' remove leading semicolon
        ws.Cells(intRowPointer, 17) = CurrentFolder.FolderPath
        ws.Cells(intRowPointer, 18) = CurrentFolder.Name
        If MailObject.UnRead Then
          ws.Cells(intRowPointer, 19) = "N"
        Else
          ws.Cells(intRowPointer, 19) = "Y"
        End If
[/SIZE][/FONT][FONT=Courier New][SIZE=1][COLOR=green]        ' insert additional fields here if required
[/COLOR]        ws.Rows(intRowPointer).RowHeight = ws.Rows(1).RowHeight
        ActiveWindow.ScrollRow = IIf(intRowPointer <= 20, 1, intRowPointer - 20)
      End If
    End If
  Next MailObject
  
  Set MailObject = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub ColumnHeaders()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim ColumnHeads As Variant
  
  ColumnHeads = Array("SenderName", "SenderEmailAddress", "SentOnBehalfOfName", "To", "CC", _
        "BCC", "ReceivedByName", "ReceivedOnBehalfOfName", "ReplyRecipientNames", "Subject", _
        "SentOn", "Body", "HTMLBody", "Importance", "AttachmentsCount", "Attachments", _
        "FolderPath", "FolderName", "Read")
[/SIZE][/FONT][FONT=Courier New][SIZE=1][COLOR=green]  ' insert additional column headings in this array if required
[/COLOR] 
  ws.Range("A1").Resize(1, UBound(ColumnHeads) + 1) = ColumnHeads[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Rows("2").Select
  With ActiveWindow
    .SplitColumn = 0
    .SplitRow = 1
  End With
  ActiveWindow.FreezePanes = True
  
  ws.Rows("1").Font.Bold = True[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]

Ruddles · Mar 3, 2011

Obviously once it's working you can modify the procedure ProcessItems to output only the fields you're actually interested in, but I'd suggest you get it working as it stands before trying to customise it.

Warship · Mar 3, 2011

How do you search only in particular folder(s)?

Ruddles · Mar 4, 2011

Not sure... I imagine you'd change RootFolder but I'm not sure how to define it correctly when it's anything other than the actual root folder.

Alternatively you could check the name of the folder in ProcessFolder only process the folder you're interested in.

I shall have a play with the code...

Ruddles · Mar 4, 2011

The best I could come up with during my lunch hour is to check each folder's .FolderPath property when ProcessItems is called. Try this code, setting variables as follows:-

RootFolder: your Outlook root folder (mailbox name)
SingleFolderRequired: set to blank if you want all mail to be retrieved (always recurses through subfolders); or set to the full path of the folder you want to retrieve the mail from (recurses through subfolders depending on the value of RecurseThroughSingleFolder)
RecurseThroughSingleFolder: set to True if you want all subfolders scanned; set to False if you only want the actual folder scanned

Here's the new code:-

Code:

[FONT=Courier New][SIZE=1]Option Explicit
Option Compare Text[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Dim RootFolder As String[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.Namespace
Dim oParentFolder As Outlook.MAPIFolder[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]
Dim ws As Worksheet[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Dim intTotalItems As Long
Dim intRowPointer As Long[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Dim SingleFolderRequired As String
Dim RecurseThroughSingleFolder As Boolean
Dim SingleFolderFound As Boolean[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Public Sub SelectOutlookMail()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim dteTimer As Date
  
  RootFolder = "[COLOR=red][U]Mailbox - BLOGGS, Fred[/U][/COLOR]"
  SingleFolderRequired = "[/SIZE][/FONT][URL="file://\\Mailbox"][FONT=Courier New][SIZE=1][COLOR=red]\\Mailbox[/COLOR][/SIZE][/FONT][/URL][FONT=Courier New][SIZE=1][COLOR=red][U] - BLOGGS, Fred\Store\Requests\Pending[/U][/COLOR]"
[/SIZE][/FONT][FONT=Courier New][SIZE=1]  RecurseThroughSingleFolder = [COLOR=red][U]True
[/U][/COLOR]   
  dteTimer = Now()
  
  Set OlApp = CreateObject("Outlook.Application")
  Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
  Set oParentFolder = oMAPI.Folders(RootFolder)
  
  Set ws = Sheets("Sheet1")
  ws.Activate
  ws.Columns("A:S").ClearContents
  
  intTotalItems = 0
  Call CountAllItems(oParentFolder)
  
  Call ColumnHeaders
    
  SingleFolderFound = False
  intRowPointer = 1
  Application.Cursor = xlWait
  Call ProcessFolder(oParentFolder)
  Application.Cursor = xlDefault
  
  MsgBox vbCrLf & "Done: " & CStr(intTotalItems) & " items scanned, " _
     & CStr(intRowPointer - 1) & " items selected" & Space(10) & vbCrLf & vbCrLf _
     & "Run time: " & Format(dteTimer - Now(), "hh:nn:ss"), vbOKOnly + vbInformation
     
  ActiveWindow.ScrollRow = 1
  
  Set OlApp = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub CountAllItems(StartFolder As Outlook.MAPIFolder)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim uFolder As Outlook.MAPIFolder
  Dim MailObject As Object
  
  If StartFolder.DefaultItemType = 0 And StartFolder.FolderPath <> "\\" & RootFolder Then
    intTotalItems = intTotalItems + StartFolder.Items.Count
  End If[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  If StartFolder.DefaultItemType = 0 Then
    For Each uFolder In StartFolder.Folders
      Call CountAllItems(uFolder)
    Next uFolder
  End If
      
  Set uFolder = Nothing
    [/SIZE][/FONT][FONT=Courier New][SIZE=1]
End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim uFolder As Outlook.MAPIFolder
  
  If StartFolder.DefaultItemType = 0 Then
    Call ProcessItems(StartFolder, StartFolder.Items)
    For Each uFolder In StartFolder.Folders
      If SingleFolderFound = False Or RecurseThroughSingleFolder = True Then
        Call ProcessFolder(uFolder)
      End If
    Next uFolder
  End If
       
  Set uFolder = Nothing
    
End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim MailObject As Object
  Dim intAttachment As Integer
  
  If Len(SingleFolderRequired) > 0 Then
    If Left(CurrentFolder.FolderPath, Len(SingleFolderRequired)) = SingleFolderRequired Then
      SingleFolderFound = True
    Else
      Exit Sub
    End If
  End If[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  For Each MailObject In Collection
    DoEvents
    If TypeOf MailObject Is MailItem Then
[COLOR=green]      ' this is where we decide if we want to select the mail item
[/COLOR]      If MailObject.SentOn >= DateValue("01/09/2010") And _
         MailObject.SentOnBehalfOfName <> "Facebook" Then
        intRowPointer = intRowPointer + 1
        ws.Rows(intRowPointer).EntireRow.Select
        ws.Cells(intRowPointer, 1) = MailObject.SentOn
        ws.Cells(intRowPointer, 2) = MailObject.SenderName
        ws.Cells(intRowPointer, 3) = MailObject.SenderEmailAddress
        ws.Cells(intRowPointer, 3) = MailObject.SentOnBehalfOfName
        ws.Cells(intRowPointer, 5) = MailObject.To
        ws.Cells(intRowPointer, 6) = MailObject.CC
        ws.Cells(intRowPointer, 7) = MailObject.BCC
        ws.Cells(intRowPointer, 8) = MailObject.ReceivedByName
        ws.Cells(intRowPointer, 9) = MailObject.ReceivedOnBehalfOfName
        ws.Cells(intRowPointer, 10) = MailObject.ReplyRecipientNames
        ws.Cells(intRowPointer, 11) = MailObject.Subject
        ws.Cells(intRowPointer, 12) = MailObject.Body
        ws.Cells(intRowPointer, 13) = MailObject.HTMLBody
        ws.Cells(intRowPointer, 14) = MailObject.Importance
        ws.Cells(intRowPointer, 15) = MailObject.Attachments.Count
        ws.Cells(intRowPointer, 16) = ""
        For intAttachment = 1 To MailObject.Attachments.Count
          On Error Resume Next [COLOR=green]' trap unknown attachment types
[/COLOR]          ws.Cells(intRowPointer, 16) = ws.Cells(intRowPointer, 16) & ";" & MailObject.Attachments(intAttachment).Filename
[COLOR=green]          ' we may want to save some or all of the attachments
          ' MailObject.Attachments(intAttachment).SaveAsFile "C:\Temp\" &[/COLOR] MailObject.Attachments(intAttachment).FileName
          On Error GoTo 0
        Next intAttachment
        ws.Cells(intRowPointer, 16) = Mid(ws.Cells(intRowPointer, 16), 2) ' remove leading semicolon
        ws.Cells(intRowPointer, 17) = CurrentFolder.FolderPath
        ws.Cells(intRowPointer, 18) = CurrentFolder.Name
        If MailObject.UnRead Then
          ws.Cells(intRowPointer, 19) = "N"
        Else
          ws.Cells(intRowPointer, 19) = "Y"
        End If
        [COLOR=green]' insert additional fields here if required
[/COLOR]        ws.Rows(intRowPointer).RowHeight = ws.Rows(1).RowHeight
        ActiveWindow.ScrollRow = IIf(intRowPointer <= 20, 1, intRowPointer - 20)
      End If
    End If
  Next MailObject
  
  Set MailObject = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Private Sub ColumnHeaders()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim ColumnHeads As Variant
  
  ColumnHeads = Array("SenderName", "SenderEmailAddress", "SentOnBehalfOfName", "To", "CC", _
        "BCC", "ReceivedByName", "ReceivedOnBehalfOfName", "ReplyRecipientNames", "Subject", _
        "SentOn", "Body", "HTMLBody", "Importance", "AttachmentsCount", "Attachments", _
        "FolderPath", "FolderName", "Read")
  ' insert additional column headings in this array if required
 
  ws.Range("A1").Resize(1, UBound(ColumnHeads) + 1) = ColumnHeads[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Rows("2").Select
  With ActiveWindow
    .SplitColumn = 0
    .SplitRow = 1
  End With
  ActiveWindow.FreezePanes = True
  
  ws.Rows("1").Font.Bold = True[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][COLOR=green]'[/COLOR][/SIZE][/FONT]
[FONT=Courier New][SIZE=1][COLOR=green]' --------------------------------------------------------------------------------
'
' Bug reports should be accompanied by the following information:-
'
' - the name of your Outlook root folder
' - the value of the variable RootFolder
' - the value of the variable SingleFolderRequired
' - the value of the variable SingleFolderFound
' - the value of the variable RecurseThroughSingleFolder
'
' --------------------------------------------------------------------------------[/COLOR][/SIZE][/FONT]
[FONT=Courier New][SIZE=1][COLOR=green]'[/COLOR][/SIZE][/FONT]

I think I've tested every possibility but if it falls over, give me a shout!

hmattert · Mar 4, 2011

Thank you so much for the help. When I run the code I get a compile error. user defined type not defined for the line Dim ws As Worksheet in the below section.

Dim RootFolder As String
Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.NameSpace
Dim oParentFolder As Outlook.MAPIFolder

Dim ws As Worksheet
Dim intTotalItems As Long
Dim intRowPointer As Long

Any help is greatly appreciated.

Thanks
Heather

Ruddles · Mar 4, 2011

Ruddles said:
add a reference to Microsoft Outlook Objects Library (Tools > References)

You did this, yes?

Need help with VBA script

hmattert

New Member

Excel Facts

Warship

Well-known Member

hmattert

New Member

Ruddles

Well-known Member

Ruddles

Well-known Member

Warship

Well-known Member

Ruddles

Well-known Member

Ruddles

Well-known Member

hmattert

New Member

Ruddles

Well-known Member

Similar threads

Forum statistics

Share this page

Need help with VBA script

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock