VB and VBA Users Source Code: Sorting value items in a Listview
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Sorting value items in a Listview
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Monday, December 17, 2001
Hits:
4058
Category:
Windows API
Article:
Unfortunately, the Listview control only sorts it's list items as strings. The following routines can be used to overcome this limitation and sort Date, Numeric and Currency list items. Note, when sorting the list using callbacks the underlying collection of listitems will become out of sync with the visible listitems. To retrieve the listitems the API-method of obtaining the selected list item must be used (see http://www.vbusers.com/code/codeget.asp?ThreadID=154&PostID=1&NumReplies=0) Option Explicit Private ztFind As LV_FINDINFO Private ztItem As LV_ITEM 'variable to hold the sort order (ascending or descending) Private zbSortAscending As Boolean 'variable to hold sort column Private zlColumnIndex As Long Private Type POINT x As Long y As Long End Type Private Type LV_FINDINFO flags As Long psz As String lParam As Long pt As POINT vkDirection As Long End Type Private Type LV_ITEM mask As Long iItem As Long iSubItem As Long state As Long stateMask As Long pszText As String cchTextMax As Long iImage As Long lParam As Long iIndent As Long End Type 'Constants Private Const LVFI_PARAM = 1 Private Const LVIF_TEXT = &H1 Private Const LVM_FIRST = &H1000 Private Const LVM_FINDITEM = LVM_FIRST + 13 Private Const LVM_GETITEMTEXT = LVM_FIRST + 45 Private Const LVM_SORTITEMS = LVM_FIRST + 48 'API declarations Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long '------------------------------------------ '------------------------------------------ 'Main sorting routines '------------------------------------------ Sub LvSortDate(lvw As ListView, ColIndex As Long) lvw.Sorted = False If lvw.SortKey = ColIndex - 1 Then 'Swap the sort over If lvw.SortOrder = lvwAscending Then lvw.SortOrder = lvwDescending Else lvw.SortOrder = lvwAscending End If Else lvw.SortKey = ColIndex - 1 lvw.SortOrder = lvwAscending End If zlColumnIndex = ColIndex - 1 zbSortAscending = (lvw.SortOrder = lvwAscending) 'Start the sort SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf zCompareDates End Sub Sub LvSortLong(lvw As ListView, ColIndex As Long) lvw.Sorted = False If lvw.SortKey = ColIndex - 1 Then If lvw.SortOrder = lvwAscending Then 'Swap the sort over lvw.SortOrder = lvwDescending Else lvw.SortOrder = lvwAscending End If Else lvw.SortKey = ColIndex - 1 lvw.SortOrder = lvwAscending End If zlColumnIndex = ColIndex - 1 zbSortAscending = (lvw.SortOrder = lvwAscending) SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf zCompareValues End Sub Sub LvSortCurrency(lvw As ListView, ColIndex As Long) lvw.Sorted = False If lvw.SortKey = ColIndex - 1 Then 'Swap the sort over If lvw.SortOrder = lvwAscending Then lvw.SortOrder = lvwDescending Else lvw.SortOrder = lvwAscending End If Else lvw.SortKey = ColIndex - 1 lvw.SortOrder = lvwAscending End If zlColumnIndex = ColIndex - 1 zbSortAscending = (lvw.SortOrder = lvwAscending) 'Start the sort SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf zCompareCurrency End Sub Sub LvSortPercent(lvw As ListView, ColIndex As Long) lvw.Sorted = False If lvw.SortKey = ColIndex - 1 Then 'Swap the sort over If lvw.SortOrder = lvwAscending Then lvw.SortOrder = lvwDescending Else lvw.SortOrder = lvwAscending End If Else lvw.SortKey = ColIndex - 1 lvw.SortOrder = lvwAscending End If zlColumnIndex = ColIndex - 1 zbSortAscending = (lvw.SortOrder = lvwAscending) 'Start the sort SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf zComparePercent End Sub '------------------------------------------ '------------------------------------------ 'Private supporting routines '------------------------------------------ 'zCompareDates: This is the sorting routine that gets passed to the 'ListView control to provide the comparison test for date values. 'Compare returns: ' 0 = Less Than ' 1 = Equal ' 2 = Greater Than Private Function zCompareDates(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal hWnd As Long) As Long Dim dDate1 As Date, dDate2 As Date On Error GoTo ErrFailed 'Obtain the item names and dates corresponding to the 'input parameters dDate1 = zLvItemDate(hWnd, lParam1) dDate2 = zLvItemDate(hWnd, lParam2) If zbSortAscending Then 'sort ascending If dDate1 < dDate2 Then zCompareDates = 0 ElseIf dDate1 = dDate2 Then zCompareDates = 1 Else zCompareDates = 2 End If Else 'sort descending If dDate1 > dDate2 Then zCompareDates = 0 ElseIf dDate1 = dDate2 Then zCompareDates = 1 Else zCompareDates = 2 End If End If Exit Function ErrFailed: zCompareDates = 1 End Function 'zCompareValues: This is the sorting routine that gets passed to the 'ListView control to provide the comparison test for numeric values. 'Compare returns: ' 0 = Less Than ' 1 = Equal ' 2 = Greater Than Private Function zCompareValues(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal hWnd As Long) As Long Dim lVal1 As Long, lVal2 As Long On Error GoTo ErrFailed 'Obtain the item names and values corresponding 'to the input parameters lVal1 = zLvItemStr(hWnd, lParam1) lVal2 = zLvItemStr(hWnd, lParam2) If zbSortAscending Then 'sort ascending If lVal1 < lVal2 Then zCompareValues = 0 ElseIf lVal1 = lVal2 Then zCompareValues = 1 Else zCompareValues = 2 End If Else 'sort descending If lVal1 > lVal2 Then zCompareValues = 0 ElseIf lVal1 = lVal2 Then zCompareValues = 1 Else zCompareValues = 2 End If End If Exit Function ErrFailed: zCompareValues = 1 End Function 'zCompareValues: This is the sorting routine that gets passed to the 'ListView control to provide the comparison test for numeric values. 'Compare returns: ' 0 = Less Than ' 1 = Equal ' 2 = Greater Than Private Function zCompareCurrency(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal hWnd As Long) As Long Dim cVal1 As Currency, cVal2 As Currency On Error GoTo ErrFailed 'Obtain the item names and values corresponding 'to the input parameters cVal1 = zLvItemCurrency(hWnd, lParam1) cVal2 = zLvItemCurrency(hWnd, lParam2) If zbSortAscending Then 'sort ascending If cVal1 < cVal2 Then zCompareCurrency = 0 ElseIf cVal1 = cVal2 Then zCompareCurrency = 1 Else zCompareCurrency = 2 End If Else 'sort descending If cVal1 > cVal2 Then zCompareCurrency = 0 ElseIf cVal1 = cVal2 Then zCompareCurrency = 1 Else zCompareCurrency = 2 End If End If Exit Function ErrFailed: zCompareCurrency = 1 End Function 'zCompareValues: This is the sorting routine that gets passed to the 'ListView control to provide the comparison test for numeric values. 'Compare returns: ' 0 = Less Than ' 1 = Equal ' 2 = Greater Than Private Function zComparePercent(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal hWnd As Long) As Long Dim fVal1 As Single, fVal2 As Single On Error GoTo ErrFailed 'Obtain the item names and values corresponding 'to the input parameters fVal1 = zLvItemPercent(hWnd, lParam1) fVal2 = zLvItemPercent(hWnd, lParam2) 'based on the Private variable zbSortAscending set in the 'columnheader click sub, sort the values appropriately: If zbSortAscending Then 'sort ascending If fVal1 < fVal2 Then zComparePercent = 0 ElseIf fVal1 = fVal2 Then zComparePercent = 1 Else zComparePercent = 2 End If Else 'sort descending If fVal1 > fVal2 Then zComparePercent = 0 ElseIf fVal1 = fVal2 Then zComparePercent = 1 Else zComparePercent = 2 End If End If Exit Function ErrFailed: zComparePercent = 1 End Function Private Function zLvItemDate(hWnd As Long, lParam As Long) As Date Dim lRetVal As Long, lIndex As Long 'Convert the input parameter to an index in the list view ztFind.flags = LVFI_PARAM ztFind.lParam = lParam lIndex = SendMessageAny(hWnd, LVM_FINDITEM, -1, ztFind) 'Obtain the value of the specified list view item. 'The ztItem.iSubItem member is set to the index 'of the column that is being retrieved. ztItem.mask = LVIF_TEXT ztItem.iSubItem = zlColumnIndex ztItem.pszText = Space$(32) ztItem.cchTextMax = Len(ztItem.pszText) 'get the string at subitem 1 lRetVal = SendMessageAny(hWnd, LVM_GETITEMTEXT, lIndex, ztItem) 'and convert it into a date and exit If lRetVal > 0 Then If IsDate(Left$(ztItem.pszText, lRetVal)) Then zLvItemDate = CDate(Left$(ztItem.pszText, lRetVal)) Else zLvItemDate = DateSerial(4501, 1, 1) End If End If End Function Private Function zLvItemStr(hWnd As Long, lParam As Long) As Long Dim lRetVal As Long, lIndex As Long 'Convert the input parameter to an index in the list view ztFind.flags = LVFI_PARAM ztFind.lParam = lParam lIndex = SendMessageAny(hWnd, LVM_FINDITEM, -1, ztFind) 'Obtain the value of the specified list view item. 'The ztItem.iSubItem member is set to the index 'of the column that is being retrieved. ztItem.mask = LVIF_TEXT ztItem.iSubItem = zlColumnIndex ztItem.pszText = Space$(32) ztItem.cchTextMax = Len(ztItem.pszText) 'get the string at subitem 2 lRetVal = SendMessageAny(hWnd, LVM_GETITEMTEXT, lIndex, ztItem) 'and convert it into a long If lRetVal > 0 Then zLvItemStr = CLng(Left$(ztItem.pszText, lRetVal)) End If End Function Private Function zLvItemCurrency(hWnd As Long, lParam As Long) As Long Dim lRetVal As Long, lIndex As Long 'Convert the input parameter to an index in the list view ztFind.flags = LVFI_PARAM ztFind.lParam = lParam lIndex = SendMessageAny(hWnd, LVM_FINDITEM, -1, ztFind) 'Obtain the value of the specified list view item. 'The ztItem.iSubItem member is set to the index 'of the column that is being retrieved. ztItem.mask = LVIF_TEXT ztItem.iSubItem = zlColumnIndex ztItem.pszText = Space$(32) ztItem.cchTextMax = Len(ztItem.pszText) 'get the string at subitem 2 lRetVal = SendMessageAny(hWnd, LVM_GETITEMTEXT, lIndex, ztItem) 'and convert it into a long If lRetVal > 0 Then zLvItemCurrency = CCur(Left$(ztItem.pszText, lRetVal)) End If End Function Private Function zLvItemPercent(hWnd As Long, lParam As Long) As Long Dim lRetVal As Long, lIndex As Long, sTemp As String 'Convert the input parameter to an index in the list view ztFind.flags = LVFI_PARAM ztFind.lParam = lParam lIndex = SendMessageAny(hWnd, LVM_FINDITEM, -1, ztFind) 'Obtain the value of the specified list view item. 'The ztItem.iSubItem member is set to the index 'of the column that is being retrieved. ztItem.mask = LVIF_TEXT ztItem.iSubItem = zlColumnIndex ztItem.pszText = Space$(32) ztItem.cchTextMax = Len(ztItem.pszText) 'get the string at subitem 2 lRetVal = SendMessageAny(hWnd, LVM_GETITEMTEXT, lIndex, ztItem) 'and convert it into a long If lRetVal > 0 Then sTemp = Left$(ztItem.pszText, lRetVal) If Right$(sTemp, 1) = "%" Then sTemp = Left$(sTemp, Len(sTemp) - 1) End If zLvItemPercent = CSng(sTemp) End If End Function
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
