Homepage aus E-Mail-Adresse ermitteln
Sie haben in Ihren Kontakten zwar die E-Mail-Adresse, jedoch nicht die Homepage (Feld "Webseite") eingegeben.
Mit Ausnahme von Freemailadressen lässt sich die Homepage in der Regel aus dem Domainnamen der E-Mail-Adresse ermitteln (z. B. E-Mail-Adresse = irgendwer@microsoft.com => Homepage = http://www.microsoft.com). Das folgende Codebeispiel nimmt Ihnen diese Arbeit ab und ermittelt die Homepage anhand der 1. E-Mail-Adresse. Sofern bereits eine Homepage manuell eingetragen wurde, wird diese nicht überschrieben, sondern bleibt erhalten.Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor).
Ab Outlook® 2000
Option Explicit Public Sub InsertWebPage() '===================================================================== ' Ermittelt aus der 1. E-Mail-Adresse die Homepage und trägt diese in ' das Feld "Webseite" ein, sofern es noch leer ist. ' (c) Peter Marchert - http://www.outlook-stuff.com ' 2008-12-11 Version 1.0.0 '===================================================================== Dim objFolder As Outlook.MAPIFolder Dim objItem As Object Dim objItems As Outlook.Items Dim lngAt As Long Dim lngChanged As Long Dim blnSave As Boolean '--------------------------------------------------------------------- ' Kontakteordner auswählen '--------------------------------------------------------------------- Set objFolder = ChooseFolder '--------------------------------------------------------------------- ' Nichts ausgewählt? '--------------------------------------------------------------------- If objFolder Is Nothing Then Exit Sub '--------------------------------------------------------------------- ' Alle Elemente im ausgewählten Ordner referenzieren '--------------------------------------------------------------------- Set objItems = objFolder.Items '--------------------------------------------------------------------- ' Alle Kontakte bearbeiten '--------------------------------------------------------------------- For Each objItem In objItems '----------------------------------------------------------------- ' Merker, dass ein Kontakt geändert wurde, zurücksetzen '----------------------------------------------------------------- blnSave = False '----------------------------------------------------------------- ' Nur Kontakte, keine Verteilerlisten bearbeiten '----------------------------------------------------------------- If objItem.Class = olContact Then '------------------------------------------------------------- ' @-Zeichen ermitteln '------------------------------------------------------------- lngAt = InStr(objItem.Email1Address, "@") '------------------------------------------------------------- ' Hat der Kontakt eine 1. E-Mail-Adresse? '------------------------------------------------------------- If lngAt Then '--------------------------------------------------------- ' Ist noch keine Homepage vorhanden, wird sie eingetragen '--------------------------------------------------------- If Trim(objItem.WebPage) = "" Then '----------------------------------------------------- ' Homepage eintragen '----------------------------------------------------- objItem.WebPage = _ "http://www." & Mid(objItem.Email1Address, lngAt + 1) '----------------------------------------------------- ' Änderung soll gespeichert werden '----------------------------------------------------- blnSave = True End If End If End If '----------------------------------------------------------------- ' Kontakt speichern? '----------------------------------------------------------------- If blnSave Then objItem.Save lngChanged = lngChanged + 1 End If Next '--------------------------------------------------------------------- ' Meldung an Benutzer '--------------------------------------------------------------------- MsgBox "Geänderte Kontakte: " & lngChanged, vbInformation, "Webseite ergänzen" '--------------------------------------------------------------------- ' Clean Up '--------------------------------------------------------------------- Set objItem = Nothing Set objItems = Nothing Set objFolder = Nothing End Sub Private Function ChooseFolder() As Outlook.MAPIFolder '===================================================================== ' Gibt einen ausgewählten Kontakteordner zurück ' (c) Peter Marchert - http://www.outlook-stuff.com ' 2008-12-11 Version 1.0.0 '===================================================================== Dim objFolder As Object '--------------------------------------------------------------------- ' Hinweis anzeigen '--------------------------------------------------------------------- If MsgBox("Bitte wählen Sie im nächsten Dialog einen Kontakteordner aus." _ , vbInformation + vbOKCancel, "Webseite ergänzen") = vbCancel Then Exit Function '--------------------------------------------------------------------- ' Schleife wird solange durchlaufen, bis ein gültiger Ordner ausgewählt ' oder die Auswahl abgebrochen wird. '--------------------------------------------------------------------- Do '----------------------------------------------------------------- ' Ordnerauswahl anzeigen '----------------------------------------------------------------- Set objFolder = Nothing Set objFolder = Outlook.Session.PickFolder '----------------------------------------------------------------- ' Wurde die Auswahl abgebrochen? '----------------------------------------------------------------- If objFolder Is Nothing Then Exit Function '----------------------------------------------------------------- ' Falscher Ordnertyp ausgewählt? '----------------------------------------------------------------- If InStr(objFolder.DefaultMessageClass, "IPM.Contact") = 0 Then Set objFolder = Nothing If MsgBox("Bitte wählen Sie einen Ordner für Kontakte aus." _ , vbCritical + vbOKCancel, "Kontakteordner auswählen") = vbCancel Then Exit Function End If End If Loop While objFolder Is Nothing '--------------------------------------------------------------------- ' Ordner bzw. Nothing zurückgeben '--------------------------------------------------------------------- Set ChooseFolder = objFolder '--------------------------------------------------------------------- ' Clean Up '--------------------------------------------------------------------- Set objFolder = Nothing End Function