home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Proper_Lis2102272182008.psc / modLVSort.bas < prev    next >
BASIC Source File  |  2008-02-18  |  4KB  |  106 lines
  1. Attribute VB_Name = "modLVSort"
  2. Option Explicit
  3. Option Compare Text
  4. Public Enum LVSortEnum
  5.  LVNatural = 0
  6.  LVNumeric = 1
  7.  LVDate = 2
  8. End Enum
  9. Private LV As ListView
  10. Private LVSort As LVSortEnum
  11. Private Const SORT_DESCENDING = &H80000000
  12. Private Const SORT_COLUMNMASK = &HFF
  13. Private Const LVM_FIRST = &H1000
  14. Private Const LVM_SORTITEMS = (LVM_FIRST + 48)
  15. Private Const WM_DESTROY = &H2
  16. Private Const LVProc = (-4)
  17. Private Const OLDLVProc = "OldLVProc"
  18. Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
  19. Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
  20. Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
  21. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
  22. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  23. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  24. Public Sub SortListView(ByVal LView As ListView, ByVal SortType As LVSortEnum)
  25.  LVSort = SortType
  26.  Set LV = LView
  27.  With LV
  28.   .Sorted = False
  29.   Call LVSubClass(.hWnd, AddressOf ListViewProc)
  30.   .Sorted = True
  31.   Call UnLVSubClass(.hWnd)
  32.  End With
  33.  Set LV = Nothing
  34. End Sub
  35. Private Static Function LVCompare(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal lParamSort As Long) As Long
  36.  Dim LVCol As Long
  37.  Dim RetVal As Long
  38.  Dim Val1 As String
  39.  Dim Val2 As String
  40.  LVCol = lParamSort And SORT_COLUMNMASK
  41.  Select Case LVCol
  42.   Case 0
  43.    Val1 = GetLVItem(lParam1).Text
  44.    Val2 = GetLVItem(lParam2).Text
  45.   Case Else
  46.    Val1 = GetLVItem(lParam1).SubItems(LVCol)
  47.    Val2 = GetLVItem(lParam2).SubItems(LVCol)
  48.  End Select
  49.  Select Case LVSort
  50.   Case LVNatural: RetVal = StrCompFileNames(Val1, Val2)
  51.   Case LVNumeric: RetVal = CCur(Val1) - CCur(Val2)
  52.   Case LVDate:    RetVal = CDate(Val1) - CDate(Val2)
  53.  End Select
  54.  Select Case CBool(lParamSort And SORT_DESCENDING)
  55.   Case True: LVCompare = -RetVal
  56.   Case False: LVCompare = RetVal
  57.  End Select
  58. End Function
  59. Private Function GetLVItem(lParam As Long) As ListItem
  60.  Dim lpli As Long
  61.  Dim li As ListItem
  62.  If lParam Then
  63.   Call MoveMemory(lpli, ByVal lParam + 8, 4)
  64.   If lpli Then
  65.    Call MoveMemory(li, lpli, 4)
  66.    Set GetLVItem = li
  67.    Call MoveMemory(li, 0&, 4)
  68.   End If
  69.  End If
  70. End Function
  71. Private Function LVSubClass(hWnd As Long, lpfnNew As Long) As Boolean
  72.  Dim lpfnOld As Long
  73.  Dim fSuccess As Boolean
  74.  If GetProp(hWnd, OLDLVProc) Then
  75.   LVSubClass = True
  76.   Exit Function
  77.  Else
  78.   lpfnOld = SetWindowLong(hWnd, LVProc, lpfnNew)
  79.   If lpfnOld Then LVSubClass = SetProp(hWnd, OLDLVProc, lpfnOld)
  80.  End If
  81. End Function
  82. Private Function UnLVSubClass(hWnd As Long) As Boolean
  83.  Dim lpfnOld As Long
  84.  lpfnOld = GetProp(hWnd, OLDLVProc)
  85.  If lpfnOld Then
  86.   If RemoveProp(hWnd, OLDLVProc) Then
  87.    UnLVSubClass = SetWindowLong(hWnd, LVProc, lpfnOld)
  88.   End If
  89.  End If
  90. End Function
  91. Private Function ListViewProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  92.  Select Case uMsg
  93.   Case LVM_SORTITEMS
  94.    wParam = LV.SortKey Or (CBool(LV.SortOrder) And SORT_DESCENDING)
  95.    lParam = FARPROC(AddressOf LVCompare)
  96.   Case WM_DESTROY
  97.    Call CallWindowProc(GetProp(hWnd, OLDLVProc), hWnd, uMsg, wParam, lParam)
  98.    Call UnLVSubClass(hWnd)
  99.    Exit Function
  100.  End Select
  101.  ListViewProc = CallWindowProc(GetProp(hWnd, OLDLVProc), hWnd, uMsg, wParam, lParam)
  102. End Function
  103. Private Function FARPROC(pfn As Long) As Long
  104.  FARPROC = pfn
  105. End Function
  106.