modlistitemsort.bas

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

Attribute VB_Name = "modListItemSort"
Public objFind As LV_FINDINFO
Public objItem As LV_ITEM
Public sOrder As Boolean
Public lSubItem 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
'常量
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声明
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
  '日期比较方式
  '返回:
  ' 0 = 小于
  ' 1 = 等于
  ' 2 = 大于
   Dim dDate1 As Date
   Dim dDate2 As Date
   
   dDate1 = ListView_GetItemDate(hwnd, lParam1)
   dDate2 = ListView_GetItemDate(hwnd, lParam2)
   
   Select Case sOrder
      Case True:
            '降序
            If dDate1 < dDate2 Then
                  CompareDates = 0
            ElseIf dDate1 = dDate2 Then
                  CompareDates = 1
            Else: CompareDates = 2
            End If
      Case Else:
            '升序
            If dDate1 > dDate2 Then
                  CompareDates = 0
            ElseIf dDate1 = dDate2 Then
                  CompareDates = 1
            Else: CompareDates = 2
            End If
   End Select
   
End Function
Public Function CompareValues(ByVal lParam1 As Long, _
                              ByVal lParam2 As Long, _
                              ByVal hwnd As Long) As Long
  '数值比较方式
  '返回:
  ' 0 = 小于
  ' 1 = 等于
  ' 2 = 大于
   Dim val1 As Long
   Dim val2 As Long
  
   val1 = Val(ListView_GetItemValueStr(hwnd, lParam1))
   val2 = Val(ListView_GetItemValueStr(hwnd, lParam2))
  
   Select Case sOrder
      Case True:
            '降序
            If val1 < val2 Then
                  CompareValues = 0
            ElseIf val1 = val2 Then
                  CompareValues = 1
            Else: CompareValues = 2
            End If
      Case Else:
            '升序
            If val1 > val2 Then
                  CompareValues = 0
            ElseIf val1 = val2 Then
                  CompareValues = 1
            Else: CompareValues = 2
            End If
   End Select
End Function
Public Function ListView_GetItemDate(hwnd As Long, lParam As Long) As Date
   '获取ListView的日期数据
   Dim r As Long
   Dim hIndex As Long
   'lParam转换为Listview的索引
   objFind.flags = LVFI_PARAM
   objFind.lParam = lParam
   hIndex = SendMessageAny(hwnd, LVM_FINDITEM, -1, objFind)
  
   objItem.mask = LVIF_TEXT
   objItem.iSubItem = lSubItem
   objItem.pszText = Space$(32)
   objItem.cchTextMax = Len(objItem.pszText)
   '获取ListView的内容
   r = SendMessageAny(hwnd, LVM_GETITEMTEXT, hIndex, objItem)
   '将其转化为日期
   If r > 0 Then
      ListView_GetItemDate = CDate(Left$(objItem.pszText, r))
   End If
End Function
Public Function ListView_GetItemValueStr(hwnd As Long, lParam As Long) As Long
   '获取ListView的值数据
   Dim r As Long
   Dim hIndex As Long
   'lParam转换为Listview的索引
   objFind.flags = LVFI_PARAM
   objFind.lParam = lParam
   hIndex = SendMessageAny(hwnd, LVM_FINDITEM, -1, objFind)
  
   objItem.mask = LVIF_TEXT
   objItem.iSubItem = lSubItem
   objItem.pszText = Space$(32)
   objItem.cchTextMax = Len(objItem.pszText)
   '获取ListView的内容
   r = SendMessageAny(hwnd, LVM_GETITEMTEXT, hIndex, objItem)
   '将其转化为数值
   If r > 0 Then
      ListView_GetItemValueStr = Val(Left$(objItem.pszText, r))
   End If
End Function