Visual Basic Forum

TheCoder_ · Verfasst am: 04.08.2007, 19:22

Hi,

Ich hab mal wieder ne Frage. Ich hab mir jetzt mit bissl kopfzerbrechen einen Email filter gemacht. Funktioniert kurz gesagt so:
Suche nach "@" geh nach rechts bis zum ersten ungütligen zeichen (zb. space) und dasselbe nochmal nach links. Suche nach dem nächsten @
Das klappt auch wunderbar. Nur dummerweise ist mein Programm dadurch nicht schlau. Ich denke ein beispiel macht das deutlich:

Viktor · Verfasst am: 04.08.2007, 19:25

Splitte nocheinmal nach den " . " und stell da ne Regel auf, also nur Endungen wie: .de oder .com
_________________

TheCoder_ · Verfasst am: 04.08.2007, 19:30

Hab ich mir auch schon überlegt. Nur da bleibt immer noch der drecksstring vorne und außerdem wäre die liste ziemlich lang weil wer weiß schon was es da für kranke endungen gibt.
_________________

Viktor · Verfasst am: 04.08.2007, 19:32

Die Domains wären ja kein Problem, da guckst du einfach auf United Domains.

TheCoder_ · Verfasst am: 04.08.2007, 19:39

Ok danke. Ich werd mal drüber schlafen. Ich glaub mir is da wieder was eingefallen. Naja mal schauen obs klappt. Wer immer noch ideen/sources hat solls posten ich bin für alles dankbar
_________________

ZiG_ · Überflieger Anmeldedatum: 07.03.2007 Beiträge: 1248

Keine Ahnung ob es dir vielleicht ein bisschen hilft. Aber ich poste dir mal einen source, den ich für jemanden bei dark-codez gemacht habe.

[code]
Public Function RipMails(ByVal Filepath As String)
If Len(Filepath) <> 0 Then
If FileExists(Filepath) Then
Dim PosMiddle As Long, PosLeft As Long, PosRight As Long
Dim buffer As String, i As Long, mailbuffer As String

Open Filepath For Binary As #1

'Wenn die Datei zu groß ist, dann erst garnicht einlesen
If (LOF(1) / 10240) > 10 Then
Close
Exit Function
End If

'Datei komplett einlesen
buffer = Space(LOF(1))
If Len(buffer) <> 0 Then
Get #1, , buffer

DoEvents

'Überprüfen wieviele MailAddys drin sind
Dim f1 As Long, f2 As Long, buffer2 As String, x_count As Long

buffer2 = Replace(buffer, Chr$(64), "")
f1 = Len(buffer)
f2 = Len(buffer2)

x_count = f1 - f2
If x_count = 0 Then
Close
Exit Function
End If

ReDim Preserve mails(m_count + x_count)

'Code zum auslesen der Addys
PosRight = 0
Do
PosMiddle = InStr(PosRight + 1, buffer, Chr$(64), vbTextCompare)
If PosMiddle = 0 Then Exit Do

Dim char As String, pos As Long
'Immer ein Zeichen nach links auslesen, bis es ein Zeichen ist, das nicht zu einer mailaddy gehören kann
pos = PosMiddle
Do
If pos <> 1 Then
pos = pos - 1
char = LCase$(Mid$(buffer, pos, 1))
If Len(char) <> 0 Then
Select Case Asc(char)
Case 97 To 122

Case 45 To 46

Case 95

Case 48 To 57

Case Else
PosLeft = pos
Exit Do
End Select
Else
PosLeft = pos
Exit Do
End If
Else
PosLeft = pos
Exit Do
End If
Loop

'Immer ein Zeichen nach rechts auslesen, bis es ein Zeichen ist, das nicht zu einer mailaddy gehören kann
pos = PosMiddle
Do
pos = pos + 1
char = LCase$(Mid$(buffer, pos, 1))

If Len(char) <> 0 Then
Select Case Asc(char)
Case 97 To 122

Case 45 To 46

Case 95

Case 48 To 57

Case Else
PosRight = pos - 1
Exit Do
End Select
Else
PosRight = pos - 1
Exit Do
End If
Loop

DoEvents

mailbuffer = Mid$(buffer, PosLeft + 1, PosRight - PosLeft)

If Len(mailbuffer) >= 6 Then

'Überprüfen ob links und rechts vom @ kein . oder - oder _ ist
pos = InStr(1, mailbuffer, Chr$(64))
If pos <> Len(mailbuffer) Then
If pos <> 1 Then
char = Mid$(mailbuffer, pos - 1, 1)
If Asc(char) <> 45 And Asc(char) <> 95 And Asc(char) <> 46 Then
char = Mid$(mailbuffer, pos + 1, 1)
If Asc(char) <> 45 And Asc(char) <> 95 And Asc(char) <> 46 Then
'Überprüfen ob ein Punkt vorhanden ist.
pos = InStrRev(mailbuffer, Chr$(46))
If pos <> 0 Then
'Überprüfen ob nach dem Punkt min. 2 Zeichen sind.
If pos = (Len(mailbuffer) - 2) Or pos = (Len(mailbuffer)) - 3 Then
'Überprüfung auf doppelte Einträge einfügen
Dim check As Boolean

For i = 0 To m_count - 1
If StrComp(mails(i), mailbuffer, vbTextCompare) = 0 Then
check = True
DoEvents
Exit For
Else
check = False
End If
Next i

If Not check Then
m_count = m_count + 1
mails(m_count) = mailbuffer
End If

DoEvents
End If
End If
End If
End If
End If
End If
End If
Loop
End If

Close
End If
End If
End Function
[/code]

Überprüft werden Sachen wie:
Links und rechts vom @ darf kein Punkt, Binde- oder Unterstrich sein.
Die email darf nur aus zugelassenen Zeichen bestehen.
Nach dem Punkt müssen mindestens 2 Zeichen sein.
Es wird überprüft ob überhaupt ein Punkt vorhanden ist.
usw.

Aber dein Problem ist ja wirklich komplex.
Das einzige was ich mir vorstellen kann ist, das du es irgenwie ausnutzt, dass die email immer wieder vorkommt im Text.

Richte dich nach dem @ Zeichen. Nach rechts kannst du dann ja schonmal bis zum Punkt auslesen.
Dann liest du in einer Schleife solange nach rechts aus und suchst dann immer wieder diesen String im ganzen Text per InStr ob er nochmal vorhanden ist, bis dieser String nicht mehr gefunden wird.
Das gleiche dann nach links.
Wie gesagt wird das nur funktionieren wenn die email öfter, bzw. mindestens zweimal im Text vorkommt und bei jeder mail vorne und hinten verschiedene Zeichen sind.

mfg
_________________
Wer nicht auf seine Weise denkt, denkt überhaupt nicht. (Oscar Wilde)