VBA排序Outlook联系人列表框

Question

我成功地能够填充我的Outlook联系人文件夹的内容的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 

    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/