Suche nach Email Adressen im Email Text

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

HAllo Stefan
Ich nutze kein Outlook daher kann ich dir nicht helfen die Emailtexte in eine Stringvariable zu laden.
Da gibts hier aber genug schlaue Köpfe die das können ;-)
Diese Funktion extrahiert dann alle gültigen Emailadressen aus der Variablen.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub aufruf()
    Dim arr As Variant
    Dim stext As String
    stext = "123@we.deko efg miuz.dfg234@lkiu.com lkki abc"
    arr = Email_Filter(stext)
    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

ransi

Hallo Stefan,
zusammen mit Ransis Funktion könnte das so aussehen:
"Mein Ordner" ist ein Unterordner des Posteingangs.
Der Mailinhalt aller Mails in "Mein Ordner" wird in die Variable strBody geschrieben.
Diese wird dann der Funktion von Ransi übergeben.

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("Mein  _
Ordner")
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

Gruß, Bastian

Beliebteste Forumthreads (12 Monate)

Suche nach Email Adressen im Email Text

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suche nach Email Adressen im Email Text

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread