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

add a contact through VBA

   <source lang="vb">

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

</source>
   
  

Add new contact item to Outlook

   <source lang="vb">

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

</source>
   
  

Add recipient

   <source lang="vb">

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

</source>
   
  

Create Outlook.Application

   <source lang="vb">

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

</source>
   
  

Delete a contact from Outlook

   <source lang="vb">

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

</source>
   
  

Print all names from your contact list in Outlook

   <source lang="vb">

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

</source>