Attribute VB_Name = "basChangeCompanyName"
Public Sub UpdateCompanyName(ByRef strFrom As String, ByRef strTo As String)

  Dim fdrContacts As Outlook.MAPIFolder
  Dim objContactItem As Outlook.ContactItem

  'Create an instance of the Contacts folder
  Set fdrContacts = _
    Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
  
  'Loop through the appropriate Contact items changing the Company Name
  For Each objContactItem In _
    fdrContacts.Items.Restrict("[CompanyName] = '" & strFrom & "'")
    objContactItem.CompanyName = strTo
    objContactItem.Save
  Next
    
End Sub

Public Function ChangeCompany()
  Dim strFrom As String
  Dim strTo As String
    
  If frmCompanyNameChange.Load(strFrom, strTo) Then
    UpdateCompanyName strFrom, strTo
  End If
  
End Function

Sub AddToolbar()
  Dim tlbCustomBar As CommandBar
  Dim btnNew As CommandBarButton
  Dim btnNewCustom As CommandBarButton
  
  Set tlbCustomBar = Application.ActiveExplorer.CommandBars _
    .Add(Name:="Custom Applications", Position:=msoBarTop, _
    Temporary:=True)
  
  tlbCustomBar.Visible = True
  
  Set btnNew = tlbCustomBar.Controls.Add(Type:=msoControlButton)

  Set btnNew = tlbCustomBar.Controls.Add(Type:=msoControlButton, _
    ID:=ActiveExplorer.CommandBars("Edit").Controls("Paste").ID)

  Set btnNewCustom = tlbCustomBar.Controls.Add(Type:=msoControlButton)

  btnNewCustom.OnAction = "ChangeCompany"
  btnNewCustom.Style = msoButtonIconAndCaption
  btnNewCustom.Caption = "Change Company Name"

End Sub

Public Sub ExportContacts(strCompany As String)
  Dim fdrContacts As Outlook.MAPIFolder
  Dim fdrContactsByCompany As Outlook.Items
  Dim objExcel As Excel.Application
  Dim objWorkbook As Excel.Workbook
  Dim objWorksheet As Excel.Worksheet
  
  Dim itmContacts As Outlook.ContactItem
  Dim iCol As Integer
  Dim iRow As Integer
  
  Set fdrContacts = _
    Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
  
  Set fdrContactsByCompany = _
    fdrContacts.Items.Restrict("[CompanyName] = '" & strCompany & "'")
  
  Set objExcel = New Excel.Application
  Set objWorkbook = objExcel.Workbooks.Add
  Set objWorksheet = objWorkbook.Worksheets.Add
  objWorksheet.Name = "Contacts for " & strCompany
  
  Set itmContacts = fdrContactsByCompany.GetFirst

  If itmContacts Is Nothing Then
    MsgBox "There are no contacts for that company. " & _
           "Please enter a different company name."
    Exit Sub
  End If

  iRow = 1
  For iCol = 0 To itmContacts.ItemProperties.Count - 1
    objWorksheet.Cells(iRow, iCol + 1) = itmContacts.ItemProperties(iCol).Name
  Next iCol

  iRow = iRow + 1
  
  For Each itmContacts In _
    fdrContacts.Items.Restrict("[CompanyName] = '" & strCompany & "'")
    
    For iCol = 0 To itmContacts.ItemProperties.Count - 1
      Debug.Print itmContacts.ItemProperties(iCol).Name
      If itmContacts.ItemProperties(iCol).Type = olText Then
        objWorksheet.Cells(iRow, iCol + 1) = _
        itmContacts.ItemProperties(iCol).Value
      End If
    Next iCol
    iRow = iRow + 1
  Next
  
  objExcel.Visible = True
  
End Sub