VB6中ListBox、ListView数值排序问题
━━━━━━━━━━━━━━━━━━━━━━━━━

不知道各位有沒有發現，ListBox 及 ComboBox 的 Sorted 屬性在遇到數字後有點怪怪的，是有排序沒錯，但是它似乎將數字當作文字排序了！所以排出來的效果和我們真正想要的並不完全相同。其實這情形不只發生在 ListBox 及 ComboBox 而已，檔案總管的檔案排也有同樣的情形，讓我們來看看：

ListBox 及 ComboBox 的 Sorted 屬性設為 True        
  1 12 2  
我們真正想要的結果
1 2 12

'以下這個模組就是用來排序數字用的，得到的結果，就如同上方右邊的結果！

Sub ReSort(L As Control)
    Dim P%, PP%, C%, Pre$, S$, V & , NewPos%, CheckIt%
    Dim TempL$, TempItemData & , S1$
    For P = 0 To L.ListCount - 1
      S = L.List(P)
      For C = 1 To Len(S)
        V = Val(Mid$(S, C))
        If V > 0 Then Exit For
      Next
      If V > 0 Then
        If C > 1 Then Pre = Left$(S, C - 1)
        NewPos = - 1
        For PP = P + 1 To L.ListCount - 1
            CheckIt = False
            S1 = L.List(PP)
            If Pre <> " " Then
              If InStr(S1, Pre) = 1 Then CheckIt = True
            Else
              If Val(S1) > 0 Then CheckIt = True
            End If
            If CheckIt Then
              If Val(Mid$(S1, C)) < V Then NewPos = PP
            Else
              Exit For
            End If
        Next
        If NewPos > - 1 Then
            TempL = L.List(P)
            TempItemData = L.ItemData(P)
            L.RemoveItem (P)
            L.AddItem TempL, NewPos
            L.ItemData(L.NewIndex) = TempItemData
            P = P - 1
        End If
      End If
    Next
End Sub
'實際使用時，需傳入控制項的名稱，例如：

Private Sub Command1_Click()
    Call ReSort(List1)
End Sub

━━━━━━━━━━━━━━━━━━━━━━━━━
找到一段api搞定的,有些聲明是多余的,自己整理吧..
三種排序方法已經封裝成函數
━━━━━━━━━━━━━━━━━━━━━━━━━

Public Enum LVStylesEx
  CheckBoxes = LVS_EX_CHECKBOXES
  FullRowSelect = LVS_EX_FULLROWSELECT
  GridLines = LVS_EX_GRIDLINES
  HeaderDragDrop = LVS_EX_HEADERDRAGDROP
  SubItemImages = LVS_EX_SUBITEMIMAGES
  TrackSelect = LVS_EX_TRACKSELECT
End Enum

'--- Sorting Variables --- '
Public Enum LVItemTypes
  lvDate = 0
  lvNumber = 1
  lvBinary = 2
  lvAlphabetic = 3
End Enum

Public Enum LVSortTypes
  lvAscending = 0
  lvDescending = 1
End Enum

Public BuildLookup As Long
Public PerformSort As Long

'方法一：

' *********************************************************
'   Knowledge Base-based Sorting Routines
' *********************************************************
Public Function LVSortK(lv As ListView, ByVal Index As Long, ByVal ItemType As LVItemTypes, ByVal SortOrder As LVSortTypes) As Boolean
  Dim tmr As New CStopWatch
   
  ' turn off the default sorting of the control
  With lv
    .Sorted = False
    .SortKey = Index
    .SortOrder = SortOrder
  End With

  ' store some values used during the sort
  m_lvSortColumn = Index
  m_lvSortType = ItemType
  m_lvHWnd = lv.hWnd
  BuildLookup = 0
   
  ' start sorting to type-specific callback routines
  tmr.Reset
  Select Case ItemType
    Case lvDate
      Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompareDates)
    Case lvNumber
      Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompareNumbers)
  End Select
  PerformSort = tmr.Elapsed
End Function

Private Function LVCompareDates(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  Static dat1 As Date
  Static dat2 As Date
   
  ' lookup text in listview based on index, and convert to date
  on Error Resume Next
  dat1 = CDate(LVGetItemText(lParam1, m_lvHWnd))
  dat2 = CDate(LVGetItemText(lParam2, m_lvHWnd))
  on Error GoTo 0

  '--- this sorts ascending
  LVCompareDates = Sgn(dat1 - dat2)
   
  '--- this sorts descending
  If SortOrder = lvDescending Then
    LVCompareDates = - LVCompareDates
  End If
End Function

Private Function LVCompareNumbers(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  Static dat1 As Double
  Static dat2 As Double
   
  ' lookup text in listview based on index, and convert to double
  on Error Resume Next
  dat1 = CDbl(LVGetItemText(lParam1, m_lvHWnd))
  dat2 = CDbl(LVGetItemText(lParam2, m_lvHWnd))
  on Error GoTo 0
   
  '--- this sorts ascending
  LVCompareNumbers = Sgn(dat1 - dat2)
   
  '--- this sorts descending
  If SortOrder = lvDescending Then
    LVCompareNumbers = - LVCompareNumbers
  End If
End Function

Public Function LVGetItemText(lParam As Long, hWnd As Long) As String
  Dim objFind As LV_FINDINFO
  Dim Index As Long
  Dim objItem As LV_ITEM
  Dim nRet As Long
   
  ' Convert the input parameter to an index in the list view
  With objFind
    .Flags = LVFI_PARAM
    .lParam = lParam
  End With
  Index = SendMessage(hWnd, LVM_FINDITEM, - 1, objFind)
   
  ' Obtain the name of the specified list view item
  With objItem
    .Mask = LVIF_TEXT
    .SubItem = m_lvSortColumn
    .Text = Space(32)
    .TextMax = Len(.Text)
  End With
   
  ' Grab the text
  nRet = SendMessage(hWnd, LVM_GETITEMTEXT, Index, objItem)
  If nRet Then
    LVGetItemText = Left$(objItem.Text, nRet)
  End If
End Function
━━━━━━━━━━━━━━━━━━━━━━━━━

'方法二：

' *********************************************************
'   Collection-based Sorting Routines
' *********************************************************
Public Function LVSortC(lv As ListView, ByVal Index As Long, ByVal ItemType As LVItemTypes, ByVal SortOrder As LVSortTypes) As Boolean
  Dim tmr As New CStopWatch
   
  ' turn off the default sorting of the control
  With lv
    .Sorted = False
    .SortKey = Index
    .SortOrder = SortOrder
  End With

  ' prepare collection of data for quicker lookups during callbacks
  tmr.Reset
  Call LVPrepareSortCollection(lv, Index, ItemType)
  BuildLookup = tmr.Elapsed
   
  ' initiate sort then delete collection
  tmr.Reset
  Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompare)
  PerformSort = tmr.Elapsed
   
  ' delete collection of sort data
  Set m_lvSortColl = Nothing
End Function

Private Function LVCompare(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  '--- this sorts ascending
  With m_lvSortColl
    LVCompare = Sgn(.Item( "k " & lParam1) - .Item( "k " & lParam2))
  End With
     
  '--- this sorts descending
  If SortOrder = lvDescending Then
    LVCompare = - LVCompare
  End If
End Function

Private Function LVPrepareSortCollection(lv As ListView, ByVal SubItemIndex As Long, ByVal ItemType As LVItemTypes) As Boolean
  Dim i As Long, n As Long
  Dim lvi As LV_ITEM
  Dim dat As Date
   
  ' initialize collection
  Set m_lvSortColl = New Collection
   
  ' obtain the ItemData value and string for each item in the list
  With lvi
    .Mask = LVIF_TEXT or LVIF_PARAM
    .SubItem = SubItemIndex
    .TextMax = 256
    .Text = Space(256)
    If ItemType = lvDate Then
      For i = 1 To lv.ListItems.Count
        .Index = i - 1
        Call SendMessage(lv.hWnd, LVM_GETITEM, 0 & , lvi)
        n = InStr(.Text, vbNullChar)
        If n > 1 Then
          on Error Resume Next
            dat = CDate(Left$(.Text, n - 1))
          on Error GoTo 0
          m_lvSortColl.Add dat, "k " & .Param
        Else
          m_lvSortColl.Add 0, "k " & .Param
        End If
      Next i
    ElseIf ItemType = lvNumber Then
      For i = 1 To lv.ListItems.Count
        .Index = i - 1
        Call SendMessage(lv.hWnd, LVM_GETITEM, 0 & , lvi)
        n = InStr(.Text, vbNullChar)
        If n > 1 Then
          m_lvSortColl.Add CDbl(Left$(.Text, n - 1)), "k " & .Param
        Else
          m_lvSortColl.Add 0, "k " & .Param
        End If
      Next i
    End If
  End With
End Function
━━━━━━━━━━━━━━━━━━━━━━━━━

'方法三：

' *********************************************************
'   IListItem-based Sorting Routines
' *********************************************************
Public Function LVSortI(lv As ListView, ByVal Index As Long, ByVal ItemType As LVItemTypes, ByVal SortOrder As LVSortTypes) As Boolean
  Dim tmr As New CStopWatch
   
  ' turn off the default sorting of the control
  With lv
    .Sorted = False
    .SortKey = Index
    .SortOrder = SortOrder
  End With

  ' no lookups used by this method
  BuildLookup = 0
   
  ' need to use module variables to let compare routine know
  ' which column and method to use
  m_lvSortColumn = Index
  m_lvSortType = ItemType
   
  ' fire off sorting
  tmr.Reset
  Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompareI)
  PerformSort = tmr.Elapsed
   
  ' delete collection of sort data
  Set m_lvSortColl = Nothing
End Function

Private Function LVCompareI(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  Static ListItem1 As ListItem
  Static ListItem2 As ListItem
  Static sItem1 As String
  Static sItem2 As String
   
  ' WARNING: This method *will* likely break in the future!
  ' Glom references to internal ListItem class using magic number
  CopyMem ListItem1, lParam1 + 84, 4
  CopyMem ListItem2, lParam2 + 84, 4
   
  ' Grab text items of interest
  If m_lvSortColumn = 0 Then
    sItem1 = ListItem1.Text
    sItem2 = ListItem2.Text
  Else
    sItem1 = ListItem1.SubItems(m_lvSortColumn)
    sItem2 = ListItem2.SubItems(m_lvSortColumn)
  End If
   
  ' Clean up hacked reference
  CopyMem ListItem1, Nothing, 4
  CopyMem ListItem2, Nothing, 4
   
  ' Perform ascending comparison
  on Error GoTo Failure
    Select Case m_lvSortType
      Case lvDate
        LVCompareI = Sgn(CDate(sItem1) - CDate(sItem2))
      Case lvNumber
        LVCompareI = Sgn(CDbl(sItem1) - CDbl(sItem2))
      Case lvBinary
        LVCompareI = StrComp(sItem1, sItem2, vbBinaryCompare)
      Case lvAlphabetic
        LVCompareI = StrComp(sItem1, sItem2, vbTextCompare)
      Case Else ' default ascending text
        LVCompareI = StrComp(sItem1, sItem2, vbTextCompare)
    End Select
  on Error GoTo 0
   
  ' Negate if descending
  If SortOrder = lvDescending Then
    LVCompareI = - LVCompareI
  End If
  Exit Function
   
Failure:
  ' Bail with 0 for failed comparison, because it 's  "just a visual sort  " 
  ' Might want to return failure code in real app by setting flag here.
  Exit Function
End Function



━━━━━━━━━━━━━━━━━━━━━━━━━
現將LISTVIEW的排序方法整理出來共大家參考
━━━━━━━━━━━━━━━━━━━━━━━━━

　　排序控制加在ListView1_ColumnClick事件中,可以有3種排序方法,支持lvDate,lvNumber,lvBinary ,lvAlphabetic 四種類型
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
  With ListView1
    .SortKey = ColumnHeader.Index - 1
    .SortOrder = Abs(Not .SortOrder = 1)
    '**********//KB method********
        LVSortK ListView1, .SortKey, lvDate, .SortOrder
    '**********// 'collection method*************
        LVSortC ListView1, .SortKey, lvDate, .SortOrder
    '**************//IListView hack method*********************
        LVSortI ListView1, .SortKey, lvDate, .SortOrder
    End If
  End With
End Sub


━━━━━━━━━━━━━━━━━━━━━━━━━
調整列寬.. 
━━━━━━━━━━━━━━━━━━━━━━━━━
  
Call LVSetAllColWidths(ListView1, LVSCW_AUTOSIZE_USEHEADER) '可在模塊中修改參數

'LISTVIEWK控制模塊,放在標准模塊中

Option Explicit

Private Declare Function GetClientRect Lib "user32 " (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32 " (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32 " (ByVal hWnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function SendMessage Lib "user32 " Alias "SendMessageA " (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
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 Sub CopyMem Lib "kernel32 " Alias "RtlMoveMemory " (Destination As Any, Source As Any, ByVal Length As Long)

Private Type POINT
  X As Long
  Y As Long
End Type

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Const LVM_FIRST As Long = &H1000
Private Const LVM_GETITEM As Long = LVM_FIRST + 5
Private Const LVM_FINDITEM As Long = LVM_FIRST + 13
Private Const LVM_ENSUREVISIBLE = LVM_FIRST + 19
Private Const LVM_SETCOLUMNWIDTH As Long = LVM_FIRST + 30
Private Const LVM_GETTOPINDEX = LVM_FIRST + 39
Private Const LVM_SETITEMSTATE As Long = LVM_FIRST + 43
Private Const LVM_GETITEMSTATE As Long = LVM_FIRST + 44
Private Const LVM_GETITEMTEXT As Long = LVM_FIRST + 45
Private Const LVM_SORTITEMS As Long = LVM_FIRST + 48
Private Const LVM_SETEXTENDEDLISTVIEWSTYLE As Long = LVM_FIRST + 54
Private Const LVM_GETEXTENDEDLISTVIEWSTYLE As Long = LVM_FIRST + 55
Private Const LVM_SETCOLUMNORDERARRAY = LVM_FIRST + 58
Private Const LVM_GETCOLUMNORDERARRAY = LVM_FIRST + 59

Private Const LVS_EX_GRIDLINES As Long = &H1
Private Const LVS_EX_SUBITEMIMAGES As Long = &H2
Private Const LVS_EX_CHECKBOXES As Long = &H4
Private Const LVS_EX_TRACKSELECT As Long = &H8
Private Const LVS_EX_HEADERDRAGDROP As Long = &H10
Private Const LVS_EX_FULLROWSELECT As Long = &H20

Private Const LVFI_PARAM As Long = 1

Private Const LVIF_TEXT As Long = 1
Private Const LVIF_IMAGE As Long = 2
Private Const LVIF_PARAM As Long = 4
Private Const LVIF_STATE As Long = 8
Private Const LVIF_INDENT As Long = &H10
Private Const LVIF_NORECOMPUTE As Long = &H800
Private Const LVIS_STATEIMAGEMASK As Long = &HF000 &

Private Type LV_ITEM
  Mask As Long
  Index As Long
  SubItem As Long
  State As Long
  StateMask As Long
  Text As String
  TextMax As Long
  Icon As Long
  Param As Long
  Indent 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


'--- Array used to speed custom sorts --- '
Private m_lvSortData() As LV_ITEM
Private m_lvSortColl As Collection
Private m_lvSortColumn As Long
Private m_lvHWnd As Long
Private m_lvSortType As LVItemTypes

Public Enum LVSCW_Styles
  LVSCW_AUTOSIZE = - 1
  LVSCW_AUTOSIZE_USEHEADER = - 2
End Enum

Public Enum LVStylesEx
  CheckBoxes = LVS_EX_CHECKBOXES
  FullRowSelect = LVS_EX_FULLROWSELECT
  GridLines = LVS_EX_GRIDLINES
  HeaderDragDrop = LVS_EX_HEADERDRAGDROP
  SubItemImages = LVS_EX_SUBITEMIMAGES
  TrackSelect = LVS_EX_TRACKSELECT
End Enum

Public Enum LVItemTypes
  lvDate = 0
  lvNumber = 1
  lvBinary = 2
  lvAlphabetic = 3
End Enum
Public Enum LVSortTypes
  lvAscending = 0
  lvDescending = 1
End Enum

Public BuildLookup As Long
Public PerformSort As Long

Public Function LVSetStyleEx(lv As ListView, ByVal NewStyle As LVStylesEx, ByVal NewVal As Boolean) As Boolean
  Dim nStyle As Long
   
  nStyle = SendMessage(lv.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0 & , ByVal 0 & )
   
  If NewVal Then
    nStyle = nStyle or NewStyle
  Else
    nStyle = nStyle Xor NewStyle
  End If

  LVSetStyleEx = CBool(SendMessage(lv.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0 & , ByVal nStyle))
End Function

Public Function LVGetColOrder(lv As ListView) As Variant
  Dim cols() As Long
  Dim nRet As Long
  With lv
    ReDim cols(0 To .ColumnHeaders.Count - 1) As Long
    nRet = SendMessage(.hWnd, LVM_GETCOLUMNORDERARRAY, .ColumnHeaders.Count, cols(0))
    If nRet Then
      LVGetColOrder = cols
    End If
  End With
End Function

Public Function LVSetColOrder(lv As ListView, cols() As Long) As Boolean
  Dim nRet As Long
  Dim rClient As RECT
  With lv
    If (UBound(cols) + 1) = .ColumnHeaders.Count Then
      nRet = SendMessage(.hWnd, LVM_SETCOLUMNORDERARRAY, .ColumnHeaders.Count, cols(0))
      LVSetColOrder = CBool(nRet)
      Call GetClientRect(.hWnd, rClient)
      Call InvalidateRect(.hWnd, rClient, True)
    End If
  End With
End Function

Public Sub LVSetColWidth(lv As ListView, ByVal ColumnIndex As Long, ByVal Style As LVSCW_Styles)
  With lv
    If .View = lvwReport Then
      If ColumnIndex > = 1 And ColumnIndex <= .ColumnHeaders.Count Then
        Call SendMessage(.hWnd, LVM_SETCOLUMNWIDTH, ColumnIndex - 1, ByVal Style)
      End If
    End If
  End With
End Sub

Public Sub LVSetAllColWidths(lv As ListView, ByVal Style As LVSCW_Styles)
  Dim ColumnIndex As Long
  With lv
    For ColumnIndex = 1 To .ColumnHeaders.Count
      LVSetColWidth lv, ColumnIndex, Style
    Next ColumnIndex
  End With
End Sub

Public Function LVItemChecked(lv As ListView, ByVal Index As Long) As Boolean
  Dim nRet As Long
  Const MaskBit As Long = &H1000   '(2 ^ 12)
  nRet = SendMessage(lv.hWnd, LVM_GETITEMSTATE, Index - 1, ByVal LVIS_STATEIMAGEMASK)
  LVItemChecked = (((nRet \ MaskBit) - 1) <> 0)
End Function

Public Function LVSetItemCheck(lv As ListView, ByVal Index As Long, ByVal Value As Boolean) As Boolean
  Dim lvi As LV_ITEM
  Index = Index - 1
  lvi.Index = Index
  lvi.Mask = LVIF_STATE
  lvi.StateMask = LVIS_STATEIMAGEMASK
  Call SendMessage(lv.hWnd, LVM_GETITEM, 0 & , lvi)
  If Value Then
    lvi.State = (lvi.State And (Not LVIS_STATEIMAGEMASK)) or &H2000
  Else
    lvi.State = (lvi.State And (Not LVIS_STATEIMAGEMASK)) or &H1000
  End If
  LVSetItemCheck = SendMessage(lv.hWnd, LVM_SETITEMSTATE, Index, lvi)
End Function

Public Function LVGetFirstVisible(lv As ListView) As Long
  LVGetFirstVisible = SendMessage(lv.hWnd, LVM_GETTOPINDEX, 0 & , ByVal 0 & )
End Function

Public Function LVEnsureVisible(lv As ListView, ByVal Index As Long) As Boolean
  LVEnsureVisible = SendMessage(lv.hWnd, LVM_ENSUREVISIBLE, Index, ByVal 0 & )
End Function
Public Function LVSortK(lv As ListView, ByVal Index As Long, ByVal ItemType As LVItemTypes, ByVal SortOrder As LVSortTypes) As Boolean
  Dim tmr As New CStopWatch
  With lv
    .Sorted = False
    .SortKey = Index
    .SortOrder = SortOrder
  End With
  m_lvSortColumn = Index
  m_lvSortType = ItemType
  m_lvHWnd = lv.hWnd
  BuildLookup = 0
  tmr.Reset
  Select Case ItemType
    Case lvDate
      Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompareDates)
    Case lvNumber
      Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompareNumbers)
  End Select
  PerformSort = tmr.Elapsed
End Function

Private Function LVCompareDates(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  Static dat1 As Date
  Static dat2 As Date
  on Error Resume Next
  dat1 = CDate(LVGetItemText(lParam1, m_lvHWnd))
  dat2 = CDate(LVGetItemText(lParam2, m_lvHWnd))
  on Error GoTo 0
  LVCompareDates = Sgn(dat1 - dat2)
  If SortOrder = lvDescending Then
    LVCompareDates = - LVCompareDates
  End If
End Function

Private Function LVCompareNumbers(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  Static dat1 As Double
  Static dat2 As Double
  on Error Resume Next
  dat1 = CDbl(LVGetItemText(lParam1, m_lvHWnd))
  dat2 = CDbl(LVGetItemText(lParam2, m_lvHWnd))
  on Error GoTo 0
  LVCompareNumbers = Sgn(dat1 - dat2)
  If SortOrder = lvDescending Then
    LVCompareNumbers = - LVCompareNumbers
  End If
End Function

Public Function LVGetItemText(lParam As Long, hWnd As Long) As String
  Dim objFind As LV_FINDINFO
  Dim Index As Long
  Dim objItem As LV_ITEM
  Dim nRet As Long
  With objFind
    .Flags = LVFI_PARAM
    .lParam = lParam
  End With
  Index = SendMessage(hWnd, LVM_FINDITEM, - 1, objFind)
  With objItem
    .Mask = LVIF_TEXT
    .SubItem = m_lvSortColumn
    .Text = Space(32)
    .TextMax = Len(.Text)
  End With
  nRet = SendMessage(hWnd, LVM_GETITEMTEXT, Index, objItem)
  If nRet Then
    LVGetItemText = Left$(objItem.Text, nRet)
  End If
End Function
Public Function LVSortC(lv As ListView, ByVal Index As Long, ByVal ItemType As LVItemTypes, ByVal SortOrder As LVSortTypes) As Boolean
  Dim tmr As New CStopWatch
  With lv
    .Sorted = False
    .SortKey = Index
    .SortOrder = SortOrder
  End With
  tmr.Reset
  Call LVPrepareSortCollection(lv, Index, ItemType)
  BuildLookup = tmr.Elapsed
  tmr.Reset
  Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompare)
  PerformSort = tmr.Elapsed
  Set m_lvSortColl = Nothing
End Function

Private Function LVCompare(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  With m_lvSortColl
    LVCompare = Sgn(.Item( "k " & lParam1) - .Item( "k " & lParam2))
  End With
  If SortOrder = lvDescending Then
    LVCompare = - LVCompare
  End If
End Function

Private Function LVPrepareSortCollection(lv As ListView, ByVal SubItemIndex As Long, ByVal ItemType As LVItemTypes) As Boolean
  Dim i As Long, n As Long
  Dim lvi As LV_ITEM
  Dim dat As Date
  Set m_lvSortColl = New Collection
  With lvi
    .Mask = LVIF_TEXT or LVIF_PARAM
    .SubItem = SubItemIndex
    .TextMax = 256
    .Text = Space(256)
    If ItemType = lvDate Then
      For i = 1 To lv.ListItems.Count
        .Index = i - 1
        Call SendMessage(lv.hWnd, LVM_GETITEM, 0 & , lvi)
        n = InStr(.Text, vbNullChar)
        If n > 1 Then
          on Error Resume Next
            dat = CDate(Left$(.Text, n - 1))
          on Error GoTo 0
          m_lvSortColl.Add dat, "k " & .Param
        Else
          m_lvSortColl.Add 0, "k " & .Param
        End If
      Next i
    ElseIf ItemType = lvNumber Then
      For i = 1 To lv.ListItems.Count
        .Index = i - 1
        Call SendMessage(lv.hWnd, LVM_GETITEM, 0 & , lvi)
        n = InStr(.Text, vbNullChar)
        If n > 1 Then
          m_lvSortColl.Add CDbl(Left$(.Text, n - 1)), "k " & .Param
        Else
          m_lvSortColl.Add 0, "k " & .Param
        End If
      Next i
    End If
  End With
End Function
Public Function LVSortI(lv As ListView, ByVal Index As Long, ByVal ItemType As LVItemTypes, ByVal SortOrder As LVSortTypes) As Boolean
  Dim tmr As New CStopWatch
  With lv
    .Sorted = False
    .SortKey = Index
    .SortOrder = SortOrder
  End With
  BuildLookup = 0
  m_lvSortColumn = Index
  m_lvSortType = ItemType
  tmr.Reset
  Call SendMessageLong(lv.hWnd, LVM_SORTITEMS, SortOrder, AddressOf LVCompareI)
  PerformSort = tmr.Elapsed
  Set m_lvSortColl = Nothing
End Function

Private Function LVCompareI(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal SortOrder As Long) As Long
  Static ListItem1 As ListItem
  Static ListItem2 As ListItem
  Static sItem1 As String
  Static sItem2 As String
  CopyMem ListItem1, lParam1 + 84, 4
  CopyMem ListItem2, lParam2 + 84, 4
  If m_lvSortColumn = 0 Then
    sItem1 = ListItem1.Text
    sItem2 = ListItem2.Text
  Else
    sItem1 = ListItem1.SubItems(m_lvSortColumn)
    sItem2 = ListItem2.SubItems(m_lvSortColumn)
  End If
  CopyMem ListItem1, Nothing, 4
  CopyMem ListItem2, Nothing, 4
  on Error GoTo Failure
    Select Case m_lvSortType
      Case lvDate
        LVCompareI = Sgn(CDate(sItem1) - CDate(sItem2))
      Case lvNumber
        LVCompareI = Sgn(CDbl(sItem1) - CDbl(sItem2))
      Case lvBinary
        LVCompareI = StrComp(sItem1, sItem2, vbBinaryCompare)
      Case lvAlphabetic
        LVCompareI = StrComp(sItem1, sItem2, vbTextCompare)
      Case Else
        LVCompareI = StrComp(sItem1, sItem2, vbTextCompare)
    End Select
  on Error GoTo 0
  If SortOrder = lvDescending Then
    LVCompareI = - LVCompareI
  End If
  Exit Function
Failure:
  Exit Function
End Function

 
>>>>>>>>>>>>>>>>>