Fehler bei Makro auslesen von Text aus Outloock

Sub TestOutlookMails()
Dim olApp      As Object   ' das Outlook-Objekt
Dim objFolder  As Object   ' der Standard-Posteingangsordner
Dim objItem    As Object   ' ein Objekt in objFolder
Dim i          As Long     ' Zeilennummer
Dim objRe      As Object   ' ein Regular-Expression Objekt
Dim objMc      As Object   ' eine MatchCollection, das Ergebnis von objRe.Execute
Dim objMatch   As Object   ' ein Match, d.h. ein Eintrag der Form "irgendwas:sonstwas"
Dim objDic     As Object   ' ein Dictionary-Objekt, Key sind die möglichen Werte vor dem  _
Doppelpunkt, Item ist die Spaltenummer wo das hinsoll
Dim varKey     As Variant  ' ein Key im Dictionary
Dim strKey     As String   ' dito
Set objDic = CreateObject("scripting.dictionary")
i = 1
Cells(1, 1).Value = "Betreff"
For Each varKey In Array("Auftragsnummer", "Kundenname", "Kundenanschrift", "Mitarbeiter", "  _
_
Bewertung", "Datum")
i = i + 1
objDic(varKey) = i
Cells(1, i).Value = varKey
Next
Set objRe = CreateObject("vbscript.regexp")
objRe.Global = True
objRe.MultiLine = True
objRe.Pattern = "^(.*?):[ \t]*(.*?)[\r\n]?$"
Set olApp = CreateObject("outlook.application")
'Set objFolder = olApp.GetNameSpace("MAPI").GetDefaultFolder(6) ' 6 = olFolderInbox   '  _
Posteingang
Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6).Folders("Kappelhoff"). _
Folders("Extra")  'mit Unterordner
i = 2
For Each objItem In objFolder.Items
If TypeName(objItem) = "MailItem" Then
Set objMc = objRe.Execute(objItem.Body)
If objMc.Count > 0 Then
Cells(i, 1).Value = objItem.Subject
i = i + 1
For Each objMatch In objMc
strKey = objMatch.Submatches(0)
If objDic.Exists(strKey) Then Cells(i, objDic(strKey)) = objMatch.Submatches(1)
Next
End If
End If
Next
objDic.RemoveAll
Set objDic = Nothing
Set objMc = Nothing
Set objRe = Nothing
Set objFolder = Nothing
Set olApp = Nothing
End Sub