Attribute VB_Name = "Addr2Contact"
Option Explicit
'Module Addr2Contact
'Copyright 2000 Klemens Schmid
'This module contains some functions for converting address book entries
'into Outlook Contact items. Adding this module to an Outlook 2000 VBA project
'makes the public subs available as macros in Outlook.
'Change history:
'17-Jan-00:  published

Private Sub CopyFields(Address As MAPI.AddressEntry, Contact As ContactItem)
'Copy fields from Address Book entry to contact item.
'This is an auxiliary function used by the functions
'Create_Contacts_From_Addresses and Refresh_Contacts_From_Addresses.

Dim oField As MAPI.Field
Dim oFields As MAPI.Fields

On Error Resume Next
Set oFields = Address.Fields
With Contact
   For Each oField In oFields
      Debug.Print oField.ID, oField.Value
      Select Case oField.ID
         Case 974651422
            .Department = oField.Value
         Case 974716958
            .OfficeLocation = oField.Value
         Case 975372318
            .BusinessFaxNumber = oField.Value
         Case 973602846
            .BusinessTelephoneNumber = oField.Value
         Case 974913566
            .MobileTelephoneNumber = oField.Value
         Case 972947486
            .Email1Address = oField.Value
         Case 974520350
            .CompanyName = oField.Value
         Case 974192670
            .LastName = oField.Value
         Case 973471774
            .FirstName = oField.Value
         Case 973078558
            .NickName = oField.Value
         Case 975634462
            .BusinessAddressCity = oField.Value
         Case 975831070
            .BusinessAddressPostalCode = oField.Value
         Case 975568926
            .BusinessAddressCountry = oField.Value
      End Select
   Next
End With
End Sub

Public Sub Create_Contacts_From_Addresses()
'bring up the address book dialog to choose any addresses
'create contact item for each of theses addresses.

Dim oSession As MAPI.Session
Dim oRecps As MAPI.Recipients
Dim oRecp As MAPI.Recipient
Dim oAddr As MAPI.AddressEntry
Dim oContact As ContactItem

'open a CDO session
Set oSession = New Session
'take the same session
oSession.Logon , , , False
'get the same item
Set oRecps = oSession.AddressBook(, , , , , "Create Contact")
If MsgBox("Are you sure you want to create Contact items for the selected " & oRecps.Count & " addresses?", vbQuestion + vbYesNo) <> vbYes Then
   Exit Sub
End If
'loop thru recipient
For Each oRecp In oRecps
   Set oAddr = oRecp.AddressEntry
   'create a new contact for each recipient
   Set oContact = Application.CreateItem(olContactItem)
   'do the copy
   CopyFields oAddr, oContact
   oContact.Save
Next
End Sub

Public Sub Refresh_Contacts_From_Addresses()
'refresh existing contact items from the corresponding address book entries

Dim oSession As MAPI.Session
Dim oRecps As MAPI.Recipients
Dim oRecp As MAPI.Recipient
Dim oAddr As MAPI.AddressEntry
Dim oField As MAPI.Field
Dim oFields As MAPI.Fields
Dim oItems As Object                            'collection to loop thru
Dim cntItems As Long                            'number of items found
Dim oContact As Object                          'ContactItem
Dim oContactFolder As Outlook.MAPIFolder
Dim oAddrEntries As MAPI.AddressEntries         'CDO address list
Dim strFileAs$

'open a CDO session
Set oSession = New Session
'take the currently active session
oSession.Logon , , , False
'get the contact folder
Set oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Set oAddrEntries = oSession.AddressLists(1).AddressEntries
'If some contact items are selected we process these.
'if not, we ask the user whether he wants to process the whole folder
On Error Resume Next
Set oItems = Application.ActiveExplorer.Selection
cntItems = oItems.Count
On Error GoTo 0
If oContactFolder <> Application.ActiveExplorer.CurrentFolder Or cntItems = 0 Then
   If MsgBox("There are no Contacts selected. Do you want to process the whole contact folder?", vbYesNo) = vbYes Then
      Set oItems = oContactFolder.Items
   Else
      Exit Sub
   End If
End If
'walk thru contacts
For Each oContact In oItems
   Set oAddr = oAddrEntries(oContact.FileAs)
   If Err.Number <> 0 Then GoTo continue
   'the following only works when the address book has 'last name, first name' as key
   If oAddr.Fields(973078558).Value = oContact.NickName Then
      'it's the right one
      CopyFields oAddr, oContact
      oContact.Save
   End If
   'proceed
continue:
   Err.Clear
Next
End Sub

Public Sub Get_FAX_Numbers_Of_Selected_Items()
Dim oItem As ContactItem
Dim strRecipientList As String
Dim strFaxNo As String
Dim oContactFolder As Outlook.MAPIFolder

'check whether we are dealing with the contacts folder
Set oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
If oContactFolder <> Application.ActiveExplorer.CurrentFolder Then
   MsgBox "There are no Contacts selected. "
   Exit Sub
End If
'extract the FAX numbers
On Error Resume Next
For Each oItem In Application.ActiveExplorer.Selection
   strFaxNo = oItem.BusinessFaxNumber
   If Len(strFaxNo) > 0 Then
      strFaxNo = Replace(strFaxNo, "-", "")
      strFaxNo = Replace(strFaxNo, "/", "")
      strFaxNo = Replace(strFaxNo, "", "")
      strRecipientList = strRecipientList & "[FAX:" & strFaxNo & "];"
   End If
Next
'Tell the result
InputBox "Copy this to the recipient list ...", "FAX Recipients", strRecipientList
Application.c
End Sub