| VBA-Beispiel 029 | |
|
|
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 |
|
relevante Links:
|
|
| |