Creating a VBA program to process emails

  • Thread starter Thread starter Dave Reed
  • Start date Start date
Here is some code that takes contact information and puts it into
Excel. It could be used as a starting point for putting email
information into Excel.

If the information is in the body of the emails you would get each
email item (Outlook.MailItem) and parse the MailItem.Body property to
get at the information and then use string functions to parse it.

Public Sub OutlookContactsToExcel()
'Excel definitions
Dim oExcel As Excel.Application
Dim oRange As Excel.range
Dim oSheet As Excel.Worksheet
'Number of sheets in new WorkBook
Dim lSheets As Long

'Outlook definitions
Dim oOutlook As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oItem As Object

Dim sRange As String
Dim sCol As String
Dim iRow As Integer

'Get an Outlook Application object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
If oOutlook Is Nothing Then
Set oOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo OutlookContactsToExcelError

'Initialize Outlook items
Set oNS = oOutlook.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderContacts)
Set oItems = oFolder.Items

'Get an Excel Application object
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If oExcel Is Nothing Then
Set oExcel = CreateObject("Excel.Application")
End If
On Error GoTo OutlookContactsToExcelError

'Initialize Excel items
'Save the previous setting for the number of Sheets
'in a new WorkBook
lSheets = oExcel.SheetsInNewWorkbook
'Only 1 sheet in this WorkBook
oExcel.SheetsInNewWorkbook = 1
'Create a new WorkBook and make it active
oExcel.Workbooks.Add
'Activate Sheet 1
Set oSheet = oExcel.ActiveWorkbook.Sheets(1)
oSheet.Activate
oExcel.Visible = True

'Column A, Row 1 Sheet Title - Bold, 14 pt, underlined
Set oRange = oSheet.range("A1")
SetSheetHeadings oRange, "Outlook Contacts", True, 14, _
xlHairline, xlLineStyleNone, xlUnderlineStyleSingle

'Column headings - Bold, 12 pt, thick bottom border
'Column A heading
Set oRange = oSheet.range("A2")
SetSheetHeadings oRange, "Last Name", True, 12, xlThick, _
xlContinuous, xlUnderlineStyleNone

'Column B heading
Set oRange = oSheet.range("B2")
SetSheetHeadings oRange, "First Name", True, 12, xlThick, _
xlContinuous, xlUnderlineStyleNone

'Column C heading
Set oRange = oSheet.range("C2")
SetSheetHeadings oRange, "Mailing Address", True, 12, xlThick, _
xlContinuous, xlUnderlineStyleNone

'Column D heading
Set oRange = oSheet.range("D2")
SetSheetHeadings oRange, "Phone", True, 12, xlThick, _
xlContinuous, xlUnderlineStyleNone

'Column E heading
Set oRange = oSheet.range("E2")
SetSheetHeadings oRange, "Fax", True, 12, xlThick, _
xlContinuous, xlUnderlineStyleNone

'Start adding data at Column A, Row 3
iRow = 2 'this number will be incremented in the For Each loop

For Each oItem In oItems
If oItem.Class = olContact Then
Set oContact = oItem
With oContact
'Each call to SetRangeData increments the Column,
'so we have to start out at A - 1
sCol = "A"
sCol = Chr(Asc(sCol) - 1)
'Start a new data Row
iRow = iRow + 1

SetRangeData oSheet, sCol, iRow, .LastName
SetRangeData oSheet, sCol, iRow, .FirstName

'Get the MailingAddress property
'If there is a newline in MailingAddress, it
'will appear as a box shape in Excel.
SetRangeData oSheet, sCol, iRow, .MailingAddress

SetRangeData oSheet, sCol, iRow, .BusinessTelephoneNumber
SetRangeData oSheet, sCol, iRow, .BusinessFaxNumber
End With
End If
Next oItem

'Set up a string variable for the last cell
sCol = "E"
sRange = sCol & CStr(iRow)

'Set a Range covering all the data in the Sheet
Set oRange = oSheet.range("A3", sRange)

'Sort the Sheet by Last Name, then First Name
oRange.Sort Key1:=oSheet.range("A3"), _
Key2:=oSheet.range("B3")

'Set a Range covering all the headings and data in the Sheet
sRange = "A2:" & sRange

'AutoFit the Columns
oSheet.range(sRange).Columns.AutoFit
'AutoFit the Rows
oSheet.range(sRange).Rows.AutoFit

'Restore the old setting for number of Sheets
'in a new WorkBook
oExcel.SheetsInNewWorkbook = lSheets

OutlookContactsToExcelExit:
Set oSheet = Nothing
Set oRange = Nothing
Set oExcel = Nothing
Set oContact = Nothing
Set oItem = Nothing
Set oItems = Nothing
Set oFolder = Nothing
Set oNS = Nothing
Set oOutlook = Nothing
Exit Sub

OutlookContactsToExcelError:
MsgBox "Error occurred: " & Err.Description, , "Wrox"
GoTo OutlookContactsToExcelExit
End Sub

Private Sub SetSheetHeadings(oRange As Excel.range, _
sValue As String, blnBold As Boolean, lFontSize As Long, _
lBorderWeight As Long, lLineStyle As Long, _
lUnderLine As Long)
With oRange
.Value = sValue
.Font.Bold = blnBold
.Font.Size = lFontSize
.Font.Underline = lUnderLine
.Borders(xlEdgeBottom).LineStyle = lLineStyle
.Borders(xlEdgeBottom).Weight = lBorderWeight
End With
End Sub

Private Sub SetRangeData(oSheet As Excel.Worksheet, sCol As String, _
iRow As Integer, sValue As String)
Dim oRange As Excel.range
Dim sRange As String

sCol = Chr(Asc(sCol) + 1)
sRange = sCol & CStr(iRow)
Set oRange = oSheet.range(sRange)
oRange.Value = sValue

Set oRange = Nothing
End Sub




 
Back
Top