The following updated code sorts the combobox named ddlCategories
Can anyone show me what to change/add to sort the comobox named ddl.Contacts as it only sorts the contacts alphabetically from each folder he contacts come from.
Private Sub ddlCategories_Change()
Dim objOutlook As outlook.Application
Dim objNS As outlook.NameSpace
Dim objFolder As outlook.MAPIFolder
Dim ctc As ContactItem
Dim FolderName As String
Dim fldr As folder
Dim flder As outlook.folder
Dim flderr As outlook.folder
Dim myContacts As outlook.items
Dim Category As String
Category = Me.ddlCategories.Text
Set objOutlook = CreateObject("Outlook.Application")
Set objFolder = objOutlook.Session.GetDefaultFolder(OlDefaultFolde rs.olFolderContacts)
Me.ddlContacts.Clear
If objFolder.Folders.Count > 0 Then
Set myContacts = objFolder.items.Restrict("[Categories] = '" & Category & "'")
If myContacts.Count > 0 Then
myContacts.Sort "[Fullname]", False
For Each ctc In myContacts
Me.ddlContacts.addItem ctc.FullName
Next
End If
For Each fldr In objFolder.Folders
Set myContacts = fldr.items.Restrict("[Categories] = '" & Category & "'")
If myContacts.Count > 0 Then
myContacts.Sort "[Fullname]", False
For Each ctc In myContacts
Me.ddlContacts.addItem ctc.FullName
Next
End If
For Each flder In fldr.Folders
Set myContacts = flder.items.Restrict("[Categories] = '" & Category & "'")
If myContacts.Count > 0 Then
myContacts.Sort "[Fullname]", False
For Each ctc In myContacts
Me.ddlContacts.addItem ctc.FullName
Next
End If
For Each flderr In flder.Folders
Set myContacts = flderr.items.Restrict("[Categories] = '" & Category & "'")
If myContacts.Count > 0 Then
myContacts.Sort "[Fullname]", False
For Each ctc In myContacts
Me.ddlContacts.addItem ctc.FullName
Next
End If
Next
Next
Next
End If
End Sub
Private Sub UserForm_Initialize()
Dim objOutlook As outlook.Application
Dim objNS As outlook.NameSpace
Dim objFolder As outlook.MAPIFolder
Dim Category
Dim arrCategories()
Dim i As Long
Dim lngCount As Long
Dim arrSorted() As Variant
Dim First As Integer
Dim Last As Integer
Set objOutlook = CreateObject("Outlook.Application")
i = 0
lngCount = Application.Session.Categories.Count
ReDim arrCategories(lngCount)
ReDim arrSorted(lngCount)
For Each Category In Application.Session.Categories
arrCategories(i) = Category
i = i + 1
Next
arrSorted = f_SortArray(arrCategories)
First = LBound(arrSorted)
Last = UBound(arrSorted)
For i = First To Last - 1
Me.ddlCategories.addItem arrSorted(i)
Next i
End Sub
Function f_SortArray(ArrayToSort() As Variant) As Variant
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim Temp As String
First = LBound(ArrayToSort)
Last = UBound(ArrayToSort)
For i = First To Last - 1
For j = i + 1 To Last
If ArrayToSort(i) > ArrayToSort(j) Then
Temp = ArrayToSort(j)
ArrayToSort(j) = ArrayToSort(i)
ArrayToSort(i) = Temp
End If
Next j
Next i
f_SortArray = ArrayToSort
End Function
Private Sub ddlContacts_Change()
Dim objOutlook As outlook.Application
Dim objNS As outlook.NameSpace
Dim ctcItems As outlook.items
Dim ctc As ContactItem
Dim objFolder As outlook.MAPIFolder
Dim ctcFolder As outlook.MAPIFolder
Dim FolderName As String
Dim ContactName As String
Dim FoundFolder As outlook.folder
Set objOutlook = CreateObject("Outlook.Application")
Set objFolder = objOutlook.Session.GetDefaultFolder(OlDefaultFolde rs.olFolderContacts)
ContactName = Me.ddlContacts.Text
If objFolder.Folders.Count > 0 Then
Set ctcItems = objFolder.items.Restrict("[FullName] = '" & ContactName & "'")
If ctcItems.Count > 0 Then
Me.Hide
For Each ctc In ctcItems
ctc.Display
Next
Exit Sub
Else
For Each fldr In objFolder.Folders
Set ctcItems = fldr.items.Restrict("[FullName] = '" & ContactName & "'")
If ctcItems.Count > 0 Then
Me.Hide
For Each ctc In ctcItems
ctc.Display
Next
Exit Sub
Else
For Each flder In fldr.Folders
Set ctcItems = flder.items.Restrict("[FullName] = '" & ContactName & "'")
If ctcItems.Count > 0 Then
Me.Hide
For Each ctc In ctcItems
ctc.Display
Next
Exit Sub
Else
For Each flderr In flder.Folders
Set ctcItems = flderr.items.Restrict("[FullName] = '" & ContactName & "'")
If ctcItems.Count > 0 Then
Me.Hide
For Each ctc In ctcItems
ctc.Display
Next
Exit Sub
End If
Next
End If
Next
End If
Next
End If
End If
End Sub
Private Function FullFolderName(ByVal FolderName As String) As outlook.folder
End Function
|