Thursday 26 July 2012

A bit of script to export emails to excel file




A bit of script to export emails to excel files:
 
<pre class='brush: vb'>
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "OutlookItems6.xlsx"
strPath = "C:\Test\"
strSheet = strPath & strSheet
Debug.Print strSheet  'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder  'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
    ElseIf fld.Items.Count = 0 Then
    End If  'Open and activate Excel workbook.

Set appExcel = CreateObject("Excel.Application")

'appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.Workbooks.Add()


wkb.Activate


Set wks = wkb.Worksheets.Add()
wks.Activate

appExcel.Application.Visible = True  'Copy field items in mail folder.
   
    For Each itm In fld.Items
        intColumnCounter = 1
        Set msg = itm
        intRowCounter = intRowCounter + 1

        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.To
        intColumnCounter = intColumnCounter + 1
        rng.Value = msg.SenderEmailAddress
        rng.Value = msg.Subject
        rng.Value = msg.SentOn
        rng.Value = msg.ReceivedTime
        rng.Value = msg.Body

    Next itm

   
wkb.SaveAs (strSheet)
wkb.Close
   
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub

ErrHandler:
If Err.Number = 1004 Then
    wkb.Close
    MsgBox strSheet & " doesn't exist", vbOKOnly, _
    Error
Else
    wkb.Close
    MsgBox Err.Number & "; Description: ", vbOKOnly
End If

</pre>

No comments: