Get web page address from e-mail address

You have entered in your contacts the e-mail address but not the web page address.

Normally the web page address can be retrieved from the e-mail address (e. g. e-mail address = somebody@microsoft.com => web page = http://www.microsoft.com). The following code example does this job for you and gets the web page address by the 1st e-mail address. If a web page already exists the program will not overwrite it.

To use this example please read the important notes and have a look to the workshop Use VBA in Outlook®. Please insert this code into a new module (Insert -> Module in the VBA-Editor).

For Outlook® 2000, Outlook® 2002, Outlook® 2003, Outlook® 2007

Option Explicit
 
Public Sub InsertWebPage()
 
    '=====================================================================
    ' Gets the web page address from the 1st e-mail address and insert it
    ' into the field "Webpage" if it is empty.
    ' (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
 
    '---------------------------------------------------------------------
    ' Choose an contact folder
    '---------------------------------------------------------------------
    Set objFolder = ChooseFolder
 
    '---------------------------------------------------------------------
    ' Nothing choosen?
    '---------------------------------------------------------------------
    If objFolder Is Nothing Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Reference all items in the folder
    '---------------------------------------------------------------------
    Set objItems = objFolder.Items
 
    '---------------------------------------------------------------------
    ' Work on all contacts
    '---------------------------------------------------------------------
    For Each objItem In objItems
 
        '-----------------------------------------------------------------
        ' Reset flag that a contact has been changed
        '-----------------------------------------------------------------
        blnSave = False
 
        '-----------------------------------------------------------------
        ' Work on only contacts - no distlists
        '-----------------------------------------------------------------
        If objItem.Class = olContact Then
 
            '-------------------------------------------------------------
            ' Get the @ sign
            '-------------------------------------------------------------
            lngAt = InStr(objItem.Email1Address, "@")
 
            '-------------------------------------------------------------
            ' Does the contact has a 1st e-mail address?
            '-------------------------------------------------------------
            If lngAt Then
 
                '---------------------------------------------------------
                ' If no web page exists she will be insert
                '---------------------------------------------------------
                If Trim(objItem.WebPage) = "" Then
 
                    '-----------------------------------------------------
                    ' Insert web page
                    '-----------------------------------------------------
                    objItem.WebPage = _
                        "http://www." & Mid(objItem.Email1Address, lngAt + 1)
 
                    '-----------------------------------------------------
                    ' Changes should be saved
                    '-----------------------------------------------------
                    blnSave = True
 
                End If
 
            End If
 
        End If
 
        '-----------------------------------------------------------------
        ' Save contact?
        '-----------------------------------------------------------------
        If blnSave Then
            objItem.Save
            lngChanged = lngChanged + 1
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Message to user
    '---------------------------------------------------------------------
    MsgBox "Changed contacts: " & lngChanged, vbInformation, "Insert web page"
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objItem = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
 
End Sub
 
Private Function ChooseFolder() As Outlook.MAPIFolder
 
    '=====================================================================
    ' Returns a choosen contact folder
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-12-11 Version 1.0.0
    '=====================================================================
 
    Dim objFolder As Object
 
    '---------------------------------------------------------------------
    ' Show a hint
    '---------------------------------------------------------------------
    If MsgBox("Please choose in the next dialog the" & vbCrLf & _
        "contact folder with the desired reciepients.", vbInformation _
        + vbOKCancel, "Insert web page") = vbCancel Then Exit Function
 
    '---------------------------------------------------------------------
    ' Stay in loop until a valid contact folder was choosen or the user
    ' breaked the dialog
    '---------------------------------------------------------------------
    Do
 
        '-----------------------------------------------------------------
        ' Show the folder picker
        '-----------------------------------------------------------------
        Set objFolder = Nothing
        Set objFolder = Outlook.Session.PickFolder
 
        '-----------------------------------------------------------------
        ' User cancled?
        '-----------------------------------------------------------------
        If objFolder Is Nothing Then Exit Function
 
        '-----------------------------------------------------------------
        ' Wrong folder type?
        '-----------------------------------------------------------------
        If InStr(objFolder.DefaultMessageClass, "IPM.Contact") = 0 Then
            Set objFolder = Nothing
            If MsgBox("Please choose a folder for contacts." _
                , vbCritical + vbOKCancel, "Choose contact folder") = vbCancel Then
                Exit Function
            End If
        End If
 
    Loop While objFolder Is Nothing
 
    '---------------------------------------------------------------------
    ' Return folder and/or nothing
    '---------------------------------------------------------------------
    Set ChooseFolder = objFolder
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objFolder = Nothing
 
End Function