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/

VBA对Outlook联系人的列表框进行排序

2 个答案: