VBA-Beispiel 029
mail schreiben
mail schreiben

Mailadresse in Unicode

Wer seine Mailadresse im Internet z.B. auf seiner Homepage veröffentlicht, kennt vermutlich das Problem:

Spam-Robots haben die Mailadresse gefunden und es folgen unerwünschte Werbemails ohne Ende.

Um das zu vermeiden können sie mit diesem vba-Code die Mailadresse ins Unicode-Format konvertieren und dann in den Quelltext der Html-Dokumente einfügen. Mit dem Unicode-Format kommen Spam-Robots nicht (oder noch nicht) klar.

Die Mailadresse funktioniert beim anklicken aber wie gewohnt. Sie können auch einen Betreff (subject) sowie für die Browseransicht einen alternativen Text festlegen.

Der vba-Code ist ellenlang. Verlieren Sie sich nicht auf dieser Html-Seite und laden sich besser die Exceldatei hier runter.



Für vba-Interessierte:

Falls Sie das Beispiel nachbauen wollen brauchen Sie eine UserForm mit dem Namen usfMail. Diese enthält drei Textfelder (txtMail, txtBetr und txtBrowser) außerdem zwei CommandButtons (OK und Abbrechen) sowie ein Label mit dem Namen labEnde in dem zum Schluß das Ergebnis der Konvertierung angezeigt wird.


zum Ablauf:

Zunächst muß die UserForm mit usfMail.show (der Code steht nur hier) angezeigt werden. Der Anwender macht in der UserForm die Angaben:

    1.     txtMail enthält die original Mailadresse
    2.     txtBetr enthält den Betreff der späteren Mail
    3.     txtBrowser enthält alternativen Text für die Browseransicht

Durch klick auf OK wird das Makro konvertieren aufgerufen. In der If-Abfrage des Makros wird die Mailadresse (jetzt Variable talt) an die Funktion Wandel übergeben und da in einer For-Next-Schleife konvertiert.
Zum Schluß wird die konvertierte Mailadresse (talt) von der Funktion Wandel an die aufrufende Prozedur konvertieren zurückgegeben und im Label labEnde als Unicode angezeigt.
Option Explicit
Dim MyData As DataObject

Sub konvertieren()
Dim talt As String, Betr As String, Browser As String
Set MyData = New DataObject

talt = usfMail.txtMail.Text
Betr = usfMail.txtBetr.Text
Browser = usfMail.txtBrowser.Text

If usfMail.txtBrowser = "" Then
    usfMail.labEnde = _
        "<a href=""mailto:" & Wandel(talt) & "?subject=" _
        & Betr & """" & ">" & Wandel(talt) & "</a>"
Else
    usfMail.labEnde = _
        "<a href=""mailto:" & Wandel(talt) & "?subject=" _
        & Betr & """" & ">" & Browser & "</a>"
End If

usfMail.Height = 200
usfMail.labEnde.Visible = True
'Text von labEnde in Zwischenablage legen
    MyData.SetText usfMail.labEnde
    MyData.PutInClipboard

MsgBox "Fügen sie den Link jetzt in ihr Html-Dokument ein." _
       , , "Hyperlink ist in Zwischenablage"

End Sub

Function Wandel(talt As String) As String
Dim i As Integer
Dim Zeichen As String

For i = 1 To Len(talt)
Zeichen = Mid$(talt, i, 1)
Select Case Zeichen
    Case "a"
    Wandel = Wandel & "a"
    Case "b"
    Wandel = Wandel & "b"
    Case "c"
    Wandel = Wandel & "c"
    Case "d"
    Wandel = Wandel & "d"
    Case "e"
    Wandel = Wandel & "e"
    Case "f"
    Wandel = Wandel & "f"
    Case "g"
    Wandel = Wandel & "g"
    Case "h"
    Wandel = Wandel & "h"
    Case "i"
    Wandel = Wandel & "i"
    Case "j"
    Wandel = Wandel & "j"
    Case "k"
    Wandel = Wandel & "k"
    Case "l"
    Wandel = Wandel & "l"
    Case "m"
    Wandel = Wandel & "m"
    Case "n"
    Wandel = Wandel & "n"
    Case "o"
    Wandel = Wandel & "o"
    Case "p"
    Wandel = Wandel & "p"
    Case "q"
    Wandel = Wandel & "q"
    Case "r"
    Wandel = Wandel & "r"
    Case "s"
    Wandel = Wandel & "s"
    Case "t"
    Wandel = Wandel & "t"
    Case "u"
    Wandel = Wandel & "u"
    Case "v"
    Wandel = Wandel & "v"
    Case "w"
    Wandel = Wandel & "w"
    Case "x"
    Wandel = Wandel & "x"
    Case "y"
    Wandel = Wandel & "y"
    Case "z"
    Wandel = Wandel & "z"
'===============================
    Case "A"
    Wandel = Wandel & "A"
    Case "B"
    Wandel = Wandel & "B"
    Case "C"
    Wandel = Wandel & "C"
    Case "D"
    Wandel = Wandel & "D"
    Case "E"
    Wandel = Wandel & "E"
    Case "F"
    Wandel = Wandel & "F"
    Case "G"
    Wandel = Wandel & "G"
    Case "H"
    Wandel = Wandel & "H"
    Case "I"
    Wandel = Wandel & "I"
    Case "J"
    Wandel = Wandel & "J"
    Case "K"
    Wandel = Wandel & "K"
    Case "L"
    Wandel = Wandel & "L"
    Case "M"
    Wandel = Wandel & "M"
    Case "N"
    Wandel = Wandel & "N"
    Case "O"
    Wandel = Wandel & "O"
    Case "P"
    Wandel = Wandel & "P"
    Case "Q"
    Wandel = Wandel & "Q"
    Case "R"
    Wandel = Wandel & "R"
    Case "S"
    Wandel = Wandel & "S"
    Case "T"
    Wandel = Wandel & "T"
    Case "U"
    Wandel = Wandel & "U"
    Case "V"
    Wandel = Wandel & "V"
    Case "W"
    Wandel = Wandel & "W"
    Case "X"
    Wandel = Wandel & "X"
    Case "Y"
    Wandel = Wandel & "Y"
    Case "Z"
    Wandel = Wandel & "Z"
'=============================
'Zahlen sind nicht übersetzt
    Case "1"
    Wandel = Wandel & "1"
    Case "2"
    Wandel = Wandel & "2"
    Case "3"
    Wandel = Wandel & "3"
    Case "4"
    Wandel = Wandel & "4"
    Case "5"
    Wandel = Wandel & "5"
    Case "6"
    Wandel = Wandel & "6"
    Case "7"
    Wandel = Wandel & "7"
    Case "8"
    Wandel = Wandel & "8"
    Case "9"
    Wandel = Wandel & "9"
    Case "0"
    Wandel = Wandel & "0"
'==============================
'Sonderzeichen
    Case "@"
    Wandel = Wandel & "@"
    Case "."
    Wandel = Wandel & "."
    Case ":"
    Wandel = Wandel & ":"
    Case ","
    Wandel = Wandel & ","
    Case ";"
    Wandel = Wandel & ";"
    Case "-"
    Wandel = Wandel & "-"
    Case "_"
    Wandel = Wandel & "_"
    Case "+"
    Wandel = Wandel & "+"
    Case "*"
    Wandel = Wandel & "*"

    Case "!"
    Wandel = Wandel & "!"
    Case """"
    Wandel = Wandel & """
    Case "§"
    Wandel = Wandel & "§"
    Case "$"
    Wandel = Wandel & "$"
    Case "%"
    Wandel = Wandel & "%"
    Case "&"
    Wandel = Wandel & "&"
    Case "/"
    Wandel = Wandel & "/"
    Case "("
    Wandel = Wandel & "("
    Case ")"
    Wandel = Wandel & ")"
    Case "="
    Wandel = Wandel & "="
    Case "?"
    Wandel = Wandel & "?"

End Select

Next i

End Function

Download:   vba029.zip