Alle EMail-Adressen eines Textes ausfiltern Eine kleine aber nützliche Funktion, welche alle EMail-Adressen aus einem String (Text) ausfiltert.
Autor:   Godo Lange-Hilmers	Bewertung:     [ Jetzt bewerten ]	Views:  23.320
www.bobofox.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 32 Bewertung insgesamt: gut Durchschnittliche Bewertung: 3.7 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Heute stellen wir Ihnen eine kleine aber nützliche Funktion vor, um alle EMail-Adressen aus einem String (Text) auszufiltern.

Anwendungsbereich ist zum Beispiel das Auslesen von "Maildelivery Subsystem Mails", die nicht explizit die falsche Emailadresse ausweisen, sondern diese im Body der Email "verstecken".

Zum Testen erstellen Sie bitte ein neues Projekt mit zwei MutliLine-Textboxen (txtSource und txtMailList). Weiterhin benötigen Sie noch eine Schaltfläche (Command1). Beim Klicken auf den Button werden dann alle in txtSource vorhandenen EMail-Adressen ausgefiltert und in der zweiten TextBox "txtMailList" ausgegeben.

Und hier der Code:

' In einem vorgegebenen Text alle EMail-Adressen
' ausfiltern
Private Function FilterEMail(ByVal sText As String) As String
  Dim sTemp As String
  Dim lPosLeft As Long
  Dim lPosRight As Long
  Dim lStartPos As Long
  Dim sResult As String
 
  ' Start-Position
  lStartPos = 0
  Do
    ' nach dem @-Zeichen suchen
    lStartPos = InStr(lStartPos + 1, sText, "@")
    If lStartPos > 1 Then
      ' Jepp - @-Zeichen gefunden
 
      ' Beginn der EMail-Adresse suchen
      lPosLeft = lStartPos
      sTemp = Mid$(sText, lPosLeft - 1, 1)
      Do While bCharOK(sTemp) And sTemp <> ""
        lPosLeft = lPosLeft - 1
        sTemp = Mid$(sText, lPosLeft - 1, 1)
      Loop
 
      ' "lPosLeft" enthält nun die Position
      ' vom Beginn der Emailadresse
 
      ' Ende der EMail-Adresse suchen
      lPosRight = lStartPos
      sTemp = Mid$(sText, lPosRight + 1, 1)
      Do While bCharOK(sTemp) And sTemp <> ""
        lPosRight = lPosRight + 1
        sTemp = Mid$(sText, lPosRight - 1, 1)
      Loop
 
      ' "lPosRight" enthält nun die Position
      ' vom Ende der Emailadresse
 
      ' jetzt EMail-Adresse extrahieren und
      ' im Rückgabewert der Funktion speichern
      If lPosLeft <> lStartPos And lPosRight <> lStartPos Then
        sResult = sResult & Mid$(sText, lPosLeft, _
          lPosRight - lPosLeft - 1) & vbCrLf
      End If
    End If
  Loop Until lStartPos = 0
 
  FilterEMail = sResult
End Function

' Prüft, ob sChar ein erlaubtes Zeichen innerhalb
' einer Emailadresse ist
Private Function bCharOK(sChar As String) As Boolean
  bCharOK = True
 
  If sChar <> "" Then
    Select Case Asc(sChar)
      Case 0 To 37, 39 To 43
        bCharOK = False
      Case 58 To 63, 91 To 94, 96, 123 To 222
        bCharOK = False
    End Select
  End If
End Function

Private Sub Command1_Click()
  ' EMail-Adressen ausfiltern
  txtMailList.Text = FilterEMail(txtSource.Text)
End Sub