global.bas

这是一个带公历农历日历及查询、并带有自动关机

Attribute VB_Name = "Global"
Option Explicit

'Public variable
Public DomainServer As ListOfServer
Public CurrentServer As String
Public Dummy As Variant

Public Sub ExtendListView(List As ListView, Flag As Boolean)
    Dim rStyle As Long
    Dim Ret As Long
    
    'get the current ListView style
    rStyle = SendMessageLong(List.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
    If Not Flag Then            'remove the extended style bit
        rStyle = rStyle Xor LVS_EX_FULLROWSELECT
    Else                        'set the extended style bit
        rStyle = rStyle Or LVS_EX_FULLROWSELECT
    End If
    'set the new ListView style
    Ret = SendMessageLong(List.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)

End Sub

Public Sub GridListView(List As ListView, Flag As Boolean)
    Dim rStyle As Long
    Dim Ret As Long

    'get the current ListView style
    rStyle = SendMessageLong(List.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)

    If Not Flag Then            'remove the extended bit
      rStyle = rStyle Xor LVS_EX_GRIDLINES
    Else                        'set the extended bit
      rStyle = rStyle Or LVS_EX_GRIDLINES
    End If

    'set the new ListView style
    Ret = SendMessageLong(List.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)

End Sub

Public Sub ShowHeaderIcon(List As ListView, _
                          colNo As Long, _
                          imgIconNo As Long, _
                          justify As Long, _
                          showImage As Long)

    Dim r As Long
    Dim hHeader As Long
    Dim HD As HD_ITEM
    
    'get a handle to the listview header component
    hHeader = SendMessageLong(List.hWnd, LVM_GETHEADER, 0, 0)
    'set up the required structure members
    With HD
        .mask = HDI_IMAGE Or HDI_FORMAT
        .fmt = HDF_LEFT Or HDF_STRING Or justify Or showImage
        .pszText = List.ColumnHeaders(colNo + 1).Text
        If showImage Then .iImage = imgIconNo
    End With
    'modify the header
    r = SendMessageAny(hHeader, HDM_SETITEM, colNo, HD)
    
End Sub

Public Sub TrackListView(List As ListView, Flag As Boolean)
    Dim rStyle As Long
    Dim Ret As Long
    
    'get the current ListView style
    rStyle = SendMessageLong(List.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
    
    If Not Flag Then
        'remove the extended style bit
        rStyle = rStyle Xor LVS_EX_TRACKSELECT
    Else
        'set the extended style bit
        rStyle = rStyle Or LVS_EX_TRACKSELECT
    End If
    
    'set the new ListView style
    Ret = SendMessageLong(List.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
    
End Sub

Public Sub CheckListView(List As ListView, Flag As Boolean)
    Dim rStyle As Long
    Dim r As Long
    
    'get the current ListView style
    rStyle = SendMessageLong(List.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
    If Not Flag Then
        'remove the extended bit
        rStyle = rStyle Xor LVS_EX_CHECKBOXES
    Else
        'set the extended bit
        rStyle = rStyle Or LVS_EX_CHECKBOXES
    End If
    'set the new ListView style
    r = SendMessageLong(List.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
    
End Sub

Public Function CrLf(Optional Count) As String
    Dim x As Integer, Text As String
    
    If IsMissing(Count) Then Count = 1
    For x = 1 To Count
        Text = Text & Chr(13) & Chr(10)
    Next
    CrLf = Text
    
End Function

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
    Dim dDate2 As Date
    
    'Obtain the item names and dates corresponding to the  'input parameters
    dDate1 = ListView_GetItemDate(lParam1, hWnd)
    dDate2 = ListView_GetItemDate(lParam2, hWnd)
    
    '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
        
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
    Dim val2 As Long
    
    '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

End Function

Public Function ListView_GetItemDate(lParam As Long, hWnd As Long) As Date
    Dim r As Long
    Dim 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 = 1
    objItem.iSubItem = objIndex
    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
    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
    Dim r As Long
    Dim 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 = 2
    objItem.iSubItem = objIndex
    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 Sub IEToolBar(Tb As Toolbar)
    Dim style As Long
    Dim hToolbar As Long
    Dim r As Long
     
    'get the handle of the toolbar
    hToolbar = FindWindowEx(Tb.hWnd, 0&, "ToolbarWindow32", vbNullString)
     
    'retrieve the toolbar styles
    style = SendMessageLong(hToolbar, TB_GETSTYLE, 0&, 0&)
     
    'Set the new style flag
    If style And TBSTYLE_FLAT Then
        style = style Xor TBSTYLE_FLAT
    Else: style = style Or TBSTYLE_FLAT
    End If
     
    'apply the new style to the toolbar
    r = SendMessageLong(hToolbar, TB_SETSTYLE, 0, style)
    Tb.Refresh
   
End Sub