Sub AddAddressEntry_Click()
On Error Resume Next
Set MyNameSpace = Application.GetNameSpace("MAPI")
Set MyAddressList = MyNameSpace.AddressLists("Personal Address Book")
If MyAddressList Is Nothing Then
    MsgBox "Personal Address Book Unavailable!", vbExclamation
    Exit Sub
End If
Set MyEntries = MyAddressList.AddressEntries
Set myEntry = MyEntries.Add("SMTP", "John Doe", "johndoe@microsoft.com")
myEntry.Update
End Sub