OutLookSendMex

Option Explicit
Public Sub RefreshQuickTos()
Dim oContacts As Items
Dim oQuickContact As Object 'maybe ContactItem or DistListItem
Dim cbStandard As CommandBar
Dim cbcQuickTo As CommandBarPopup
Dim cbcTest As CommandBarButton
Dim cbb As CommandBarButton
Dim oInsp As Inspector
Dim bDontClose As Boolean
Dim bCouldNotDeleteRefresh As Boolean
Dim Pos As Integer
'check whether we are called from the toolbar

If Not ActiveInspector Is Nothing Then
If TypeName(ActiveInspector.CurrentItem) = "MailItem" Then
Set oInsp = ActiveInspector
bDontClose = True
End If
End If
If oInsp Is Nothing Then
'open the appropriate inspector

Set oInsp = Application.CreateItem(olMailItem).GetInspector
End If
'prepare the command bar button "To"

On Error Resume Next
Set cbStandard = oInsp.CommandBars("Standard")
Set cbcQuickTo = cbStandard.Controls("To")
On Error Goto 0
'if the button is found we remove it because it appears at

'the wrong location

If Not cbcQuickTo Is Nothing Then
cbcQuickTo.Delete
End If
'put it after the "Check Names" item (ID=361)

Set cbb = cbStandard.FindControl(ID:=361)
If cbb Is Nothing Then
'if this is missing, try the "Address book" item (ID=353)

Set cbb = cbStandard.FindControl(ID:=353)
End If
If cbb Is Nothing Then
'if both are missing, put it to the end

Set cbcQuickTo = cbStandard.Controls.Add(msoControlPopup)
Else
Set cbcQuickTo = cbStandard.Controls.Add(msoControlPopup, , , cbb.Index + 1)
End If
cbcQuickTo.Caption = "To"
cbcQuickTo.TooltipText = "Add your favorite recipients"
'add contacts to the popup

Set oContacts = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Items
Set oQuickContact = oContacts.Find("[Categories] = 'Quick To'")
Pos = 1
Do While Not oQuickContact Is Nothing
Set cbb = cbcQuickTo.CommandBar.Controls.Add(Type:=msoControlButton, before:=Pos)
cbb.Caption = oQuickContact
cbb.OnAction = "AddQuickTo"
If TypeName(oQuickContact) = "DistListItem" Then
cbb.Parameter = "[MAPIPDL:" & oQuickContact.DLName & "]"
Else
cbb.Parameter = GetEmail(oQuickContact)
End If
cbb.TooltipText = "Add this person to the ""To:"" list"
'proceed

Set oQuickContact = oContacts.FindNext
Pos = Pos + 1
Loop
'add Refresh and About only if they couldn't be deleted

If Not bCouldNotDeleteRefresh Then
With cbcQuickTo.CommandBar.Controls.Add(Type:=msoControlButton)
.Caption = "Refresh list"
.BeginGroup = True
.OnAction = "RefreshQuickTos"
End With
'add our About

With cbcQuickTo.CommandBar.Controls.Add(Type:=msoControlButton)
.Caption = "About"
.BeginGroup = True
.OnAction = "About"
End With
End If
'close inspector if it was opened in this proc

If Not bDontClose Then
oInsp.Close olDiscard
End If
End Sub

Public Function GetEmail(Contact As ContactItem)
'Extract the best email address which is resolves offline

With Contact
GetEmail = Contact & "[" & .Email1AddressType & ":" & .Email1Address & "]"
#If 0 Then
If .Email1Address Like "*@*" Then
GetEmail = .Email1Address
ElseIf .Email2Address Like "*@*" Then
GetEmail = .Email2Address
ElseIf .Email3Address Like "*@*" Then
GetEmail = .Email3Address
Else
GetEmail = Contact & "[" & .Email1AddressType & ":" & .Email1Address & "]"
End If
#End If
End With
End Function

Private Sub AddQuickTo()
'add the selected email address to the "To:"

With ActiveInspector
If Len(.CurrentItem.To) = 0 Then
.CurrentItem.To = .CommandBars.ActionControl.Parameter
Else
.CurrentItem.To = .CurrentItem.To & ";" & .CommandBars.ActionControl.Parameter
End If
End With
End Sub

Private Sub About()
MsgBox "Quick To's by Klemens Schmid." & vbCrLf _
& vbCrLf & "Presents all contacts With category 'Quick To' In a quick access list." _
& vbCrLf & "For more Outlook enhancements visit http://www.schmidks.de.", vbInformation
End Sub