VBA/Excel/Access/Word/Outlook/Outlook Contact

add a contact through VBA

 
Sub AddAContact()
   Dim myOutlook As Outlook.Application
   Dim myItems As ContactItem
   Set myOutlook = CreateObject("Outlook.Application")
   Set myItems = myOutlook.CreateItem(olContactItem)
   With myItems
      .FirstName = "John"
      .LastName = "Smith"
      .Email1Address = "j@yourserver.ru"
      .Save
    End With
End Sub

Add new contact item to Outlook

 
Sub AddAContact()
   Dim myOutlook As Outlook.Application
   Dim myItems As ContactItem
   Set myOutlook = CreateObject("Outlook.Application")
   Set myItems = myOutlook.CreateItem(olContactItem)
   With myItems
      .FirstName = "John"
      .LastName = "Smith"
      .Email1Address = "johnsmith@yoursite.ru"
      .Save
    End With
End Sub

Add recipient

 
Public Sub AddRecipient()
    Dim oSelect As Outlook.SelectNamesDialog
    Dim colRecipients As Outlook.Recipients
    Dim oRecip As Outlook.Recipient
    Dim oMail As Outlook.MailItem
    
    Set oMail = Application.CreateItem(olMailItem)
    Set oSelect = Application.Session.GetSelectNamesDialog
    
    With oSelect
    .AllowMultipleSelection = False
            .SetDefaultDisplayMode OlDefaultSelectNamesDisplayMode.olDefaultMail
            .ForceResolution = True
            .Caption = "My Mail Selector Dialog"
            .ToLabel = "My To Selector"
            .NumberOfRecipientSelectors = OlRecipientSelectors.olShowTo
            .Display
            If .Recipients.Count = 1 Then
                Set oRecip = oMail.Recipients.Add(.Recipients.Item(1).Name)
            End If
    End With
    oMail.Display
End Sub

Create Outlook.Application

 
Sub myAddressBook()
   Dim myOutlook As Outlook.Application
   Dim myInformation As Namespace
   Dim mycontacts As Items
   Dim myItems As ContactItem
   Set myOutlook = CreateObject("Outlook.Application")
   Set myInformation = myOutlook.GetNamespace("MAPI")
   Set mycontacts = myInformation.GetDefaultFolder(olFolderContacts).Items
   For Each myItems In mycontacts
      Debug.Print myItems.FirstName, myItems.LastName, myItems.Email1Address
    Next
End Sub

Delete a contact from Outlook

 
Sub DeleteaContact()
   Dim myOutlook As Outlook.Application
   Dim myInformation As Namespace
   Dim myContacts As Items
   Dim myItems As ContactItem
   Set myOutlook = CreateObject("Outlook.Application")
   Set myInformation = myOutlook.GetNamespace("MAPI")
   Set myContacts = myInformation.GetDefaultFolder(olFolderContacts).Items
   For Each myItems In myContacts
      If myItems.Email1Address = "j@yoursite.ru" Then
         myItems.Delete
       End If
     Next
End Sub

Print all names from your contact list in Outlook

 
Sub myAddressBook()
   Dim myOutlook As Outlook.Application
   Dim myInformation As Namespace
   Dim mycontacts As Items
   Dim myItems As ContactItem
   Set myOutlook = CreateObject("Outlook.Application")
   Set myInformation = myOutlook.GetNamespace("MAPI")
   Set mycontacts = myInformation.GetDefaultFolder(olFolderContacts).Items
   For Each myItems In mycontacts
      Debug.Print myItems.FirstName, myItems.LastName, myItems.Email1Address
    Next
End Sub