'Make sure the module name is
'mLVSort.  Set this in
'your properties window


Public objFind   As LV_FINDINFO
Public objItem   As LV_ITEM

'variable to hold the sort order (ascending or descending)
Public sOrder    As Boolean
'variable to hold sort column
Public sColumn   As Long

Public Type POINT
    x            As Long
    y            As Long
End Type

Public Type LV_FINDINFO
    flags        As Long
    psz          As String
    lParam       As Long
    pt           As POINT
    vkDirection  As Long
End Type

Public 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
Public Const LVFI_PARAM =  1 
Public Const LVIF_TEXT = &H1

Public Const LVM_FIRST = &H1000
Public Const LVM_FINDITEM = LVM_FIRST +  13 
Public Const LVM_GETITEMTEXT = LVM_FIRST +  45 
Public Const LVM_SORTITEMS = LVM_FIRST +  48 

'API declarations
Public 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

Public Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" ( _
                                                                          ByVal hWnd As Long, _
                                                                          ByVal wMsg As Long, _
                                                                          ByVal wParam As Long, _
                                                                          lParam As Any) As Long
Public Function CompareDates(ByVal lParam1 As Long, _
                             ByVal lParam2 As Long, _
                             ByVal hWnd As Long) As Long

'CompareDates: 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

    Dim dDate1 As Date, dDate2 As Date, dE As Boolean, d2E As Boolean
    On Error GoTo CDERR

    'Obtain the item names and dates corresponding to the
    'input parameters
    dDate1 = ListView_GetItemDate(hWnd, lParam1)
    dDate2 = ListView_GetItemDate(hWnd, lParam2)

    'based on the Public variable sOrder set in the
    'columnheader click sub, sort the dates appropriately:
    Select Case sOrder
        Case True:    'sort descending

            If dDate1 < dDate2 Then
                CompareDates =  0 
            ElseIf dDate1 = dDate2 Then
                CompareDates =  1 
            Else
                CompareDates =  2 
            End If

        Case Else:    'sort ascending

            If dDate1 > dDate2 Then
                CompareDates = 0
            ElseIf dDate1 = dDate2 Then
                CompareDates = 1
            Else
                CompareDates = 2
            End If

    End Select
    Exit Function
CDERR:
    CompareDates = 1
End Function


Public Function CompareValues(ByVal lParam1 As Long, _
                              ByVal lParam2 As Long, _
                              ByVal hWnd As Long) As Long

'CompareValues: 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

    Dim val1 As Long, val2 As Long
    On Error GoTo CDERR
    'Obtain the item names and values corresponding
    'to the input parameters
    val1 = ListView_GetItemValueStr(hWnd, lParam1)
    val2 = ListView_GetItemValueStr(hWnd, lParam2)

    'based on the Public variable sOrder set in the
    'columnheader click sub, sort the values appropriately:
    Select Case sOrder
        Case True    'sort descending

            If val1 < val2 Then
                CompareValues =  0 
            ElseIf val1 = val2 Then
                CompareValues =  1 
            Else
                CompareValues =  2 
            End If

        Case Else    'sort ascending

            If val1 > val2 Then
                CompareValues = 0
            ElseIf val1 = val2 Then
                CompareValues = 1
            Else
                CompareValues = 2
            End If

    End Select
    Exit Function
CDERR:
    CompareValues = 1
End Function

Public Function CompareCurrency(ByVal lParam1 As Long, _
                                ByVal lParam2 As Long, _
                                ByVal hWnd As Long) As Long

'CompareValues: 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

    Dim val1 As Currency, val2 As Currency
    On Error GoTo CDERR
    'Obtain the item names and values corresponding
    'to the input parameters
    val1 = ListView_GetItemCurrency(hWnd, lParam1)
    val2 = ListView_GetItemCurrency(hWnd, lParam2)

    'based on the Public variable sOrder set in the
    'columnheader click sub, sort the values appropriately:
    Select Case sOrder
        Case True:    'sort descending

            If val1 < val2 Then
                CompareCurrency =  0 
            ElseIf val1 = val2 Then
                CompareCurrency =  1 
            Else
                CompareCurrency =  2 
            End If

        Case Else:    'sort ascending

            If val1 > val2 Then
                CompareCurrency = 0
            ElseIf val1 = val2 Then
                CompareCurrency = 1
            Else
                CompareCurrency = 2
            End If

    End Select
    Exit Function
CDERR:
    CompareCurrency = 1
End Function

Public Function ComparePercent(ByVal lParam1 As Long, _
                               ByVal lParam2 As Long, _
                               ByVal hWnd As Long) As Long

'CompareValues: 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

    Dim val1 As Single, val2 As Single
    On Error GoTo CDERR
    'Obtain the item names and values corresponding
    'to the input parameters
    val1 = ListView_GetItemPercent(hWnd, lParam1)
    val2 = ListView_GetItemPercent(hWnd, lParam2)

    'based on the Public variable sOrder set in the
    'columnheader click sub, sort the values appropriately:
    Select Case sOrder
        Case True:    'sort descending

            If val1 < val2 Then
                ComparePercent =  0 
            ElseIf val1 = val2 Then
                ComparePercent =  1 
            Else
                ComparePercent =  2 
            End If

        Case Else:    'sort ascending

            If val1 > val2 Then
                ComparePercent = 0
            ElseIf val1 = val2 Then
                ComparePercent = 1
            Else
                ComparePercent = 2
            End If

    End Select
    Exit Function
CDERR:
    ComparePercent = 1
End Function

Private Function ListView_GetItemDate(hWnd As Long, lParam As Long) As Date
    Dim r As Long, hIndex As Long, tmpdate As Date
    'Convert the input parameter to an index in the list view
    objFind.flags = LVFI_PARAM
    objFind.lParam = lParam
    hIndex = SendMessageAny(hWnd, LVM_FINDITEM, - 1 , objFind)

    'Obtain the value of the specified list view item.
    'The objItem.iSubItem member is set to the index
    'of the column that is being retrieved.
    objItem.mask = LVIF_TEXT
    objItem.iSubItem = sColumn
    objItem.pszText = Space$(32)
    objItem.cchTextMax = Len(objItem.pszText)

    'get the string at subitem  1 
    r = SendMessageAny(hWnd, LVM_GETITEMTEXT, hIndex, objItem)

    'and convert it into a date and exit
    On Error Resume Next
    If r > 0 Then
        tmpdate = DateValue(objItem.pszText)
        If err.Number = 13 Or Not IsDate(tmpdate) Then
            'dateValue  237 ; 229 ;  239 ; 229 ; 240 ; 229 ; 224 ; 240 ; 232 ; 226 ; 224 ; 229 ; 242 ;  239 ; 243 ; 241 ; 242 ; 251 ; 229 ;  231 ; 237 ; 224 ; 247 ; 229 ; 237 ; 232 ; 255 ;  232 ;  237 ; 229 ;  241 ; 242 ; 224 ; 237 ; 228 ; 224 ; 240 ; 242 ; 237 ; 238 ;  238 ; 242 ; 244 ; 238 ; 240 ; 236 ; 224 ; 242 ; 232 ; 240 ; 238 ; 226 ; 224 ; 237 ; 251 ; 229 ;  231 ; 237 ; 224 ; 247 ; 229 ; 237 ; 232 ; 255 ;
            ListView_GetItemDate = DateSerial( 4501 ,  1 ,  1 )
            err.Clear
        Else
            ListView_GetItemDate = CDate(tmpdate)    'CDate(Left$(objItem.pszText, r))
        End If
    End If
End Function


Public Function ListView_GetItemValueStr(hWnd As Long, lParam As Long) As Long
    Dim r As Long, hIndex As Long
    'Convert the input parameter to an index in the list view
    objFind.flags = LVFI_PARAM
    objFind.lParam = lParam
    hIndex = SendMessageAny(hWnd, LVM_FINDITEM, - 1 , objFind)

    'Obtain the value of the specified list view item.
    'The objItem.iSubItem member is set to the index
    'of the column that is being retrieved.
    objItem.mask = LVIF_TEXT
    objItem.iSubItem = sColumn
    objItem.pszText = Space$(32)
    objItem.cchTextMax = Len(objItem.pszText)

    'get the string at subitem  2 
    r = SendMessageAny(hWnd, LVM_GETITEMTEXT, hIndex, objItem)

    'and convert it into a long
    If r > 0 Then
        ListView_GetItemValueStr = CLng(Left$(objItem.pszText, r))
    End If
End Function

Public Function ListView_GetItemCurrency(hWnd As Long, lParam As Long) As Currency
    Dim r As Long, hIndex As Long
    'Convert the input parameter to an index in the list view
    objFind.flags = LVFI_PARAM
    objFind.lParam = lParam
    hIndex = SendMessageAny(hWnd, LVM_FINDITEM, - 1 , objFind)

    'Obtain the value of the specified list view item.
    'The objItem.iSubItem member is set to the index
    'of the column that is being retrieved.
    objItem.mask = LVIF_TEXT
    objItem.iSubItem = sColumn
    objItem.pszText = Space$(32)
    objItem.cchTextMax = 32    ' Len(objItem.pszText)

    'get the string at subitem 2
    r = SendMessageAny(hWnd, LVM_GETITEMTEXT, hIndex, objItem)

    'and convert it into a long
    If r >  0  Then
        ListView_GetItemCurrency = CCur(Val(objItem.pszText))    ' êîïåéêè íå ó÷èòûâàþòñÿ!! 12,25 =12,99 !!!
    End If
End Function

Public Function ListView_GetItemPercent(hWnd As Long, lParam As Long) As Long
    Dim r As Long, hIndex As Long, temp As String
    'Convert the input parameter to an index in the list view
    objFind.flags = LVFI_PARAM
    objFind.lParam = lParam
    hIndex = SendMessageAny(hWnd, LVM_FINDITEM, - 1 , objFind)

    'Obtain the value of the specified list view item.
    'The objItem.iSubItem member is set to the index
    'of the column that is being retrieved.
    objItem.mask = LVIF_TEXT
    objItem.iSubItem = sColumn
    objItem.pszText = Space$(32)
    objItem.cchTextMax = Len(objItem.pszText)

    'get the string at subitem  2 
    r = SendMessageAny(hWnd, LVM_GETITEMTEXT, hIndex, objItem)

    'and convert it into a long
    If r >  0  Then
        temp = Left$(objItem.pszText, r)
        If Right$(temp,  1 ) =  "%"  Then
            temp = Left$(temp, Len(temp) -  1 )
        End If
        ListView_GetItemPercent = CSng(temp)
    End If
End Function

Public Sub SortLvwOnDate(lvw As MSComctlLib.ListView, ColIndex As Long)
    If lvw.Sorted = True Then lvw.Sorted = False
    If lvw.SortKey = ColIndex -  1  Then
        If lvw.SortOrder = lvwAscending Then
            lvw.SortOrder = lvwDescending
        Else
            lvw.SortOrder = lvwAscending
        End If
    Else
        lvw.SortKey = ColIndex -  1 
        lvw.SortOrder = lvwAscending
    End If
    mLVSort.sColumn = ColIndex -  1 
    mLVSort.sOrder = (lvw.SortOrder = lvwAscending)
    SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf CompareDates
End Sub

Public Sub SortLvwOnLong(lvw As ListView, ColIndex As Long)
    If lvw.Sorted = True Then lvw.Sorted = False
    If lvw.SortKey = ColIndex -  1  Then
        If lvw.SortOrder = lvwAscending Then
            lvw.SortOrder = lvwDescending
        Else
            lvw.SortOrder = lvwAscending
        End If
    Else
        lvw.SortKey = ColIndex -  1 
        lvw.SortOrder = lvwAscending
    End If
    mLVSort.sColumn = ColIndex -  1 
    mLVSort.sOrder = (lvw.SortOrder = lvwAscending)
    SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf CompareValues
End Sub

Public Sub SortLvwOnCurrency(lvw As ListView, ColIndex As Long)
    If lvw.Sorted = True Then lvw.Sorted = False
    If lvw.SortKey = ColIndex -  1  Then
        If lvw.SortOrder = lvwAscending Then
            lvw.SortOrder = lvwDescending
        Else
            lvw.SortOrder = lvwAscending
        End If
    Else
        lvw.SortKey = ColIndex -  1 
        lvw.SortOrder = lvwAscending
    End If
    mLVSort.sColumn = ColIndex -  1 
    mLVSort.sOrder = (lvw.SortOrder = lvwAscending)
    SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf CompareCurrency
End Sub

Public Sub SortLvwOnPercent(lvw As ListView, ColIndex As Long)
    If lvw.Sorted = True Then lvw.Sorted = False
    If lvw.SortKey = ColIndex -  1  Then
        If lvw.SortOrder = lvwAscending Then
            lvw.SortOrder = lvwDescending
        Else
            lvw.SortOrder = lvwAscending
        End If
    Else
        lvw.SortKey = ColIndex -  1 
        lvw.SortOrder = lvwAscending
    End If
    mLVSort.sColumn = ColIndex -  1 
    mLVSort.sOrder = (lvw.SortOrder = lvwAscending)
    SendMessageLong lvw.hWnd, LVM_SORTITEMS, lvw.hWnd, AddressOf ComparePercent
End Sub

''Structures
'
'Public Type POINT
'    x            As Long
'    y            As Long
'End Type
'
'Public Type LV_FINDINFO
'    flags        As Long
'    psz          As String
'    lParam       As Long
'    pt           As POINT
'    vkDirection  As Long
'End Type
'
'Public Type LV_ITEM
'    mask         As Long
'    iItem        As Long
'    iSubItem     As Long
'    State        As Long
'    stateMask    As Long
'    pszText      As Long
'    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
'Public Const LVM_SORTITEMS = LVM_FIRST +  48 
'
''API declarations
'
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
 '                                                                ByVal hWnd As Long, _
 '                                                                ByVal wMsg As Long, _
 '                                                                ByVal wParam As Long, _
 '                                                                ByVal lParam As Long) As Long
'
''Module Functions and Procedures
'
''CompareDates: This is the sorting routine that gets passed to the
''ListView control to provide the comparison test for date values.
'
'Public Function CompareDatesAsc(ByVal lngParam1 As Long, _
 '                                ByVal lngParam2 As Long, _
 '                                ByVal hWnd As Long) As Long
'
'    Dim strName1 As String
'    Dim strName2 As String
'    Dim dDate1   As Date
'    Dim dDate2   As Date
'
'    'Obtain the item names and dates corresponding to the
'    'input parameters
'
'    ListView_GetItemData lngParam1, hWnd, strName1, dDate1
'    ListView_GetItemData lngParam2, hWnd, strName2, dDate2
'
'    'Compare the dates
'    'Return 0 ==> Less Than
'    '       1 ==> Equal
'    '       2 ==> Greater Than
'
'    If dDate1 < dDate2 Then
'        CompareDatesAsc =  2 
'    ElseIf dDate1 = dDate2 Then
'        CompareDatesAsc =  1 
'    Else
'        CompareDatesAsc =  0 
'    End If
'
'End Function
'Public Function CompareDatesDesc(ByVal lngParam1 As Long, _
 '                                 ByVal lngParam2 As Long, _
 '                                 ByVal hWnd As Long) As Long
'
'    Dim strName1 As String
'    Dim strName2 As String
'    Dim dDate1   As Date
'    Dim dDate2   As Date
'
'    'Obtain the item names and dates corresponding to the
'    'input parameters
'
'    ListView_GetItemData lngParam1, hWnd, strName1, dDate1
'    ListView_GetItemData lngParam2, hWnd, strName2, dDate2
'
'    'Compare the dates
'    'Return  0  ==> Less Than
'    '        1  ==> Equal
'    '        2  ==> Greater Than
'
'    If dDate1 < dDate2 Then
'        CompareDatesDesc = 0
'    ElseIf dDate1 = dDate2 Then
'        CompareDatesDesc = 1
'    Else
'        CompareDatesDesc = 2
'    End If
'
'End Function            'GetItemData - Given Retrieves
'
'Public Sub ListView_GetItemData(lngParam As Long, _
 '                                hWnd As Long, _
 '                                strName As String, _
 '                                dDate As Date)
'    Dim objFind  As LV_FINDINFO
'    Dim lngIndex As Long
'    Dim objItem  As LV_ITEM
'    Dim baBuffer( 32 ) As Byte
'    Dim lngLength As Long
'
'    '
'    ' Convert the input parameter to an index in the list view
'    '
'    objFind.flags = LVFI_PARAM
'    objFind.lParam = lngParam
'    lngIndex = SendMessage(hWnd, LVM_FINDITEM, -1, VarPtr(objFind))
'
'    '
'    ' Obtain the name of the specified list view item
'    '
'    objItem.mask = LVIF_TEXT
'    objItem.iSubItem =  0 
'    objItem.pszText = VarPtr(baBuffer(0))
'    objItem.cchTextMax = UBound(baBuffer)
'    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, _
     '                            VarPtr(objItem))
'    strName = Left$(StrConv(baBuffer, vbUnicode), lngLength)
'
'    '
'    ' Obtain the modification date of the specified list view item
'    '
'    objItem.mask = LVIF_TEXT
'    objItem.iSubItem =  1 
'    objItem.pszText = VarPtr(baBuffer(0))
'    objItem.cchTextMax = UBound(baBuffer)
'    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, _
     '                            VarPtr(objItem))
'    If lngLength > 0 Then
'        dDate = CDate(Left$(StrConv(baBuffer, vbUnicode), lngLength))
'
'        dDate = (Left$(StrConv(baBuffer, vbUnicode), lngLength))
'        '          If dDate = CDate( 0 ) Then dDate =  "31 / 12 / 2100 "
'
'    End If
'
'End Sub
'
''GetListItem - This is a modified version of ListView_GetItemData
'' It takes an index into the list as a parameter and returns
'' the appropriate values in the strName and dDate parameters.
'
'Public Sub ListView_GetListItem(lngIndex As Long, _
 '                                hWnd As Long, _
 '                                strName As String, _
 '                                dDate As Date)
'    Dim objItem  As LV_ITEM
'    Dim baBuffer( 32 ) As Byte
'    Dim lngLength As Long
'
'    '
'    ' Obtain the name of the specified list view item
'    '
'    objItem.mask = LVIF_TEXT
'    objItem.iSubItem =  0 
'    objItem.pszText = VarPtr(baBuffer(0))
'    objItem.cchTextMax = UBound(baBuffer)
'    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, _
     '                            VarPtr(objItem))
'    strName = Left$(StrConv(baBuffer, vbUnicode), lngLength)
'
'    '
'    ' Obtain the modification date of the specified list view item
'    '
'    objItem.mask = LVIF_TEXT
'    objItem.iSubItem =  1 
'    objItem.pszText = VarPtr(baBuffer(0))
'    objItem.cchTextMax = UBound(baBuffer)
'    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, _
     '                            VarPtr(objItem))
'    If lngLength > 0 Then
'        dDate = CDate(Left$(StrConv(baBuffer, vbUnicode), lngLength))
'    End If
'
'End Sub
'

Call SortLvwOnDate(LisctView1, ColumnHeader.Index) - для сортировки дат