Hi there,
Im struggling with VBA and am new to this tipe of thing. I need a vba code to extract email to a excel file, but I need all the information on the email enterd into excel so I can build a report from that. I have a code to extract the email but the code does not enter all the email body into excel, and I have tried numerious things and can't get it right.
Here is the code I use.
Sub SaveMessagesToExcel()
On Error GoTo ErrorHandler
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 i As Integer
Dim j As Integer
Dim lngCount As Long
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String
strTemplatesPath = "C:\Documents and Settings\Desktop\" strSheet = "excel macros.xlsx"
strSheet = strTemplatesPath & strSheet
Debug.Print "Excel workbook: " & strSheet
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Messages.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If
If fld.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain mail messages"
GoTo ErrorHandlerExit
End If
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No messages to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " messages to export"
End If
i = 3
For Each itm In fld.Items
If itm.Class = olMail Then
Set msg = itm
i = i + 1
j = 1
Set rng = wks.Cells(i, j)
If msg.To <> "" Then rng.Value = msg.To
j = j + 1
Set rng = wks.Cells(i, j)
If msg.cc <> "" Then rng.Value = msg.cc
j = j + 1
Set rng = wks.Cells(i, j)
If msg.SenderEmailAddress <> "" Then
rng.Value = msg.SenderEmailAddress
End If
j = j + 1
Set rng = wks.Cells(i, j)
If msg.Subject <> "" Then rng.Value = msg.Subject
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.SentOn
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.ReceivedTime
j = j + 1
'This is my problem all the other stuff works and gets inserted into the excel sheet but the body gets formated and shows ?
Set rng = wks.Cells(i, j)
rng.Value = msg.body
j = j + 1
Set rng = wks.Cells(i, j)
On Error Resume Next
If msg.UserProperties("CustomField") <> "" Then
rng.Value = msg.UserProperties("CustomField")
End If
j = j + 1
End If
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub
I would appreciate any help.
Thank you
Im struggling with VBA and am new to this tipe of thing. I need a vba code to extract email to a excel file, but I need all the information on the email enterd into excel so I can build a report from that. I have a code to extract the email but the code does not enter all the email body into excel, and I have tried numerious things and can't get it right.
Here is the code I use.
Sub SaveMessagesToExcel()
On Error GoTo ErrorHandler
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 i As Integer
Dim j As Integer
Dim lngCount As Long
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String
strTemplatesPath = "C:\Documents and Settings\Desktop\" strSheet = "excel macros.xlsx"
strSheet = strTemplatesPath & strSheet
Debug.Print "Excel workbook: " & strSheet
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Messages.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If
If fld.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain mail messages"
GoTo ErrorHandlerExit
End If
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No messages to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " messages to export"
End If
i = 3
For Each itm In fld.Items
If itm.Class = olMail Then
Set msg = itm
i = i + 1
j = 1
Set rng = wks.Cells(i, j)
If msg.To <> "" Then rng.Value = msg.To
j = j + 1
Set rng = wks.Cells(i, j)
If msg.cc <> "" Then rng.Value = msg.cc
j = j + 1
Set rng = wks.Cells(i, j)
If msg.SenderEmailAddress <> "" Then
rng.Value = msg.SenderEmailAddress
End If
j = j + 1
Set rng = wks.Cells(i, j)
If msg.Subject <> "" Then rng.Value = msg.Subject
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.SentOn
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.ReceivedTime
j = j + 1
'This is my problem all the other stuff works and gets inserted into the excel sheet but the body gets formated and shows ?
Set rng = wks.Cells(i, j)
rng.Value = msg.body
j = j + 1
Set rng = wks.Cells(i, j)
On Error Resume Next
If msg.UserProperties("CustomField") <> "" Then
rng.Value = msg.UserProperties("CustomField")
End If
j = j + 1
End If
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub
I would appreciate any help.
Thank you