Was muss ich denn jetzt tun?
LG
Code:
Sub Outlook_Import()
Dim appOutlook As Outlook.Application
Dim OutlookNameSpace As Outlook.Namespace
Dim OutlookMAPIFolder As Outlook.MAPIFolder
Dim OutlookItem As Outlook.MailItem
Dim arr As Variant
Dim strBody As String
Set appOutlook = CreateObject("Outlook.Application")
Set OutlookNameSpace = appOutlook.GetNamespace("MAPI")
Set OutlookMAPIFolder = OutlookNameSpace.GetDefaultFolder(olFolderInbox).Folders("00-emailfehler")
With OutlookMAPIFolder
For Each OutlookItem In .Items
strBody = strBody & OutlookItem.Body
Next OutlookItem
End With
arr = Email_Filter(strBody)
Range("A1").Resize(UBound(arr) + 1) = WorksheetFunction.Transpose(arr)
End Sub
Public Function Email_Filter(strMailtext As String) As Variant
Dim varTmp() As Variant
Dim Regex As Object
Dim M
Dim Treffer
Dim lngIndex As Long
Set Regex = CreateObject("Vbscript.regexp")
With Regex
.Pattern = "\b(\w[-.\w]*@\w[-.\w]*\.[a-zA-Z]{2,10})\b"
.IgnoreCase = True
.Global = True
If .test(strMailtext) = True Then
Set Treffer = .Execute(strMailtext)
ReDim varTmp(Treffer.Count - 1)
For Each M In Treffer
varTmp(lngIndex) = M.Value
lngIndex = lngIndex + 1
Next
End If
End With
Email_Filter = varTmp
End Function