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