Exporting body from outlook to excel

[kurifodo]

Hi Everyone!

I am trying to Export 4000 Marketing Messages to excel. My code works-ish. It seems to read it all but writes nothing other than the last email into Excel. Some help Troubleshooting my Loop would be super!


Sub ExportToExcel()
'On Error GoTo ErrHandler
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 vText As Variant
Dim sText As String
Dim vItem As Variant
Dim xlSheet As Excel.Worksheet
Dim rCount As Long
Dim i As Long

Dim itm As Object
strSheet = "OutlookItems.xls"
strPath = "C:\Examples\"
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
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
sText = itm.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
'rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
'rCount = rCount + 1
For i = UBound(vText) To 0 Step -1
rCount = wks.Range("B" & wks.Rows.Count).End(xlUp).Row
rCount = rCount + 1

If InStr(1, vText(i), "vname:") > 0 Then
vItem = Split(vText(i), Chr(58))
wks.Range("A" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "nname:") > 0 Then
vItem = Split(vText(i), Chr(58))
wks.Range("B" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "straeundhausnummer:") > 0 Then
vItem = Split(vText(i), Chr(58))
wks.Range("C" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "plzundort:") > 0 Then
vItem = Split(vText(i), Chr(58))
wks.Range("D" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "emailadresse:") > 0 Then
vItem = Split(vText(i), Chr(58))
wks.Range("E" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "nachricht:") > 0 Then
vItem = Split(vText(i), Chr(58))
wks.Range("F" & rCount) = Trim(vItem(1))
End If
Next i
wkb.Save

Next itm
wkb.Close SaveChanges:=True
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set xlSheet = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing

Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub


The Body of the email is a table that Looks like this:



Folgende Mitteilung wurde an Sie gesandt:
vname: Alpha
nname: Bravo
straeundhausnummer: Charlie 1
plzundort: 12345
emailadresse: alpha.bravo@web.de (alpha.bravo@web.de)
nachricht: Erste Nachricht


If we asume that is the last email the Output would be in row 2 and under coumns A to F respectively: Alpha, Bravo, Charlie 1, 12345, Alpha.bravo[at]web.de (Alpha.bravo@web.de), Erste Nachricht.

3999 emails got read and then ignored :(

No Errors are thrown, Excel opens and saves as intended.
You Need to activate the Excel Library from Outlook.

Many thanks everybody!

Kurifodo

[skatonni]

If this works, it is overwriting the same row.
Try uncommenting
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1

Change xlSheet to wks.