VBA сортировать список контактов Outlook

Question

Я успешно могу заполнить список из 2 столбцов содержимым моей папки контактов Outlook и отправить эту информацию в текстовое поле при нажатии ... увы, как я могу отсортировать список?

    Private Sub getOutlookContacts()
Dim i As Integer
Dim oOutlookApp As Outlook.Application
Dim oOutlookNameSpace As Outlook.NameSpace
Dim oContacts As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem

  On Error Resume Next

  Set oOutlookApp = GetObject(, "Outlook.Application")
  If Err <> 0 Then
    Set oOutlookApp = CreateObject("Outlook.Application")
  End If

  Set oOutlookNameSpace = oOutlookApp.GetNamespace("MAPI")
  'Get the contactfolder
  Set oContacts = oOutlookNameSpace.GetDefaultFolder(olFolderContacts)

  Set oContact = oContacts.Items
    'oContacts.Sort "[FullName]", False, olAscending
    For Each oContact In oContacts.Items
    Me.ListBox1.AddItem oContact.FullName
    Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = oContact.BusinessAddress
    i = i + 1
  Next

  Set oContact = Nothing
  Set oContacts = Nothing
  Set oOutlookNameSpace = Nothing
  Set oOutlookApp = Nothing

End Sub

Answer 1

Вы можете использовать встроенную функцию сортировки как (например):

oContacts.Items.Sort "[FullName]", False
Set oContact = oContacts.Items.GetFirst
Do
    ' Add oContact details to the listbox
    Set oContact = oContacts.Items.GetNext
Loop Until oContact Is Nothing

Это, скорее всего, будет быстрее, не говоря уже о том, что проще, чем сортировать список самостоятельно ...

Answer 2

Private Sub getOutlookContacts()
    Dim i As Integer
    Dim oOutlookApp As Outlook.Application
    Dim oOutlookNameSpace As Outlook.NameSpace
    Dim oContacts As Outlook.MAPIFolder
    Dim oContact As Outlook.ContactItem
    Dim vaContacts As Variant

    On Error Resume Next

    Set oOutlookApp = New Outlook.Application

    Set oOutlookNameSpace = oOutlookApp.GetNamespace("MAPI")
    'Get the contactfolder
    Set oContacts = oOutlookNameSpace.GetDefaultFolder(olFolderContacts)

    Set oContact = oContacts.Items
    ReDim vaContacts(0 To oContacts.Items.Count - 1, 0 To 1)

    'oContacts.Sort "[FullName]", False, olAscending
    For Each oContact In oContacts.Items
        vaContacts(i, 0) = oContact.FullName
        vaContacts(i, 1) = oContact.BusinessAddress
        i = i + 1
    Next oContact

    SortArray vaContacts

    Me.ListBox1.Clear
    Me.ListBox1.List = vaContacts

    Set oContact = Nothing
    Set oContacts = Nothing
    Set oOutlookNameSpace = Nothing
    Set oOutlookApp = Nothing

End Sub

Private Sub SortArray(ByRef vaArray As Variant)

    Dim i As Long
    Dim j As Long
    Dim sTemp As String
    Dim sTemp2 As String

    'Bubble sort the array on the first value
    For i = LBound(vaArray, 1) To UBound(vaArray, 1) - 1
        For j = i + 1 To UBound(vaArray, 1)
            If vaArray(i, 0) > vaArray(j, 0) Then
                'Swap the first value
                sTemp = vaArray(i, 0)
                vaArray(i, 0) = vaArray(j, 0)
                vaArray(j, 0) = sTemp

                'Swap the second value
                sTemp2 = vaArray(i, 1)
                vaArray(i, 1) = vaArray(j, 1)
                vaArray(j, 1) = sTemp2
            End If
        Next j
    Next i

End Sub

См. Также http://www.dailydoseofexcel.com/archives/2004/05/24/sorting-a-multicolumn-listbox/