ucverywellsstatusbarxp.ctl

显示XP效果的状态栏程序.希望能和大家一起学习

Public Sub ClearPanel(lPanelIndex As Long)
    ' Removes the text from a panel without a complete redraw of the control (speed! ...)
    ' This is done by copying the pixel colume left to the text to the whole area using
    ' the StretchBlt() API function

    Dim lSrcX   As Long
    Dim lWidth  As Long
    Dim lHeight As Long

    If lPanelIndex < 1 Or lPanelIndex > m_PanelCount Then
        
        Exit Sub
    End If
    
    With m_Panels(lPanelIndex)
        lSrcX = .ContentsLeft
        lWidth = .ContentsRight - lSrcX
        lHeight = .ClientHeight
    End With
    
    StretchBlt UserControl.hDC, lSrcX + 1, 0, lWidth, lHeight, UserControl.hDC, lSrcX, 0, 1, lHeight, ScrCopy
    UserControl.Refresh
    
End Sub


' *************************************
' *         FRIEND FUNCTIONS          *
' *************************************

Friend Sub TimerUpdate()

    Dim i   As Long
    Dim rc  As RECT
    
    RaiseEvent TimerBeforeRedraw
    
    For i = 1 To m_PanelCount
        With m_Panels(i)
            Select Case .PanelType
            
            Case [PT Date]
                    PanelCaption(i) = Format(Date, "d.m.yyyy")
                                            
            Case [PT Time]
                    PanelCaption(i) = Format(Time, "hh:nn:ss")
            
            Case [PT CapsLock]
                    GetKeyboardState kbArray
                    .pEnabled = IIf(kbArray.kbByte(VK_CAPITAL) = 1, True, False)
                    PanelCaption(i) = "CAPS"
            
            Case [PT NumLock]
                    GetKeyboardState kbArray
                    .pEnabled = IIf(kbArray.kbByte(VK_NUMLOCK) = 1, True, False)
                    PanelCaption(i) = "NUM"
            
            Case [PT Scroll]
                    GetKeyboardState kbArray
                    .pEnabled = IIf(kbArray.kbByte(VK_SCROLL) = 1, True, False)
                    PanelCaption(i) = "SCROLL"
            
            End Select
            
        End With
    Next i
    
    RaiseEvent TimerAfterRedraw
    
End Sub



' *************************************
' *         PRIVATE FUNCTIONS         *
' *************************************

Private Sub UserControl_InitProperties()
            
    flgRedrawEnabled = False
    Set UserControl.Font = UserControl.Parent.Font
    oBackColor = vbButtonFace
    oForeColor = vbButtonText
    oDissColor = vbGrayText
    oMaskColor = RGB(255, 0, 255)
    bDrawGripper = True
    flgTimerEnabled = False
    m_Apperance = m_def_Apperance
    m_UseWindowsColors = m_def_UseWindowsColors
    flgRedrawEnabled = True
    DrawStatusBar True
     
End Sub


Private Sub UserControl_Show()

    ' Ensure "special background handling"
    Select Case m_Apperance

    Case [XP Diagonal Left], [XP Diagonal Right]
        BackColor = oBackColor = UserControl.Parent.BackColor

    End Select

    If Ambient.UserMode = True Then
        If flgTimerEnabled = False Then
            ' Start timer
            SetProp UserControl.hwnd, "sbXP_ClassID", ObjPtr(Me)
            SetTimer UserControl.hwnd, 2201, 200, AddressOf API_Timer_Callback
            flgTimerEnabled = True
        End If
    Else
        ' Stop timer
        KillTimer UserControl.hwnd, 2201
        flgTimerEnabled = False
    End If
    
End Sub


Private Sub UserControl_Click()
    
    If PanelNum < 1 Then
         
         Exit Sub
    End If
    If m_Panels(PanelNum).pEnabled = True Then
        RaiseEvent Click(PanelNum)
    End If
    
End Sub

Private Sub UserControl_DblClick()
    
    If PanelNum < 1 Then
         
         Exit Sub
    End If
    If m_Panels(PanelNum).pEnabled = True Then
        RaiseEvent DblClick(PanelNum)
    End If
    
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    Dim pt      As POINTAPI
    Dim hRgn    As Long
    Dim i       As Long
    
    PanelNum = 0
    If ShowGripper = True Then
        hRgn = CreateRectRgnIndirect(rcGripper)
        If PtInRegion(hRgn, CLng(X), CLng(Y)) Then
            If Button = vbLeftButton Then
                SizeByGripper frm.hwnd
                DeleteObject hRgn
                
                Exit Sub
            End If
        End If
        
    End If
    
    For i = 1 To m_PanelCount
        hRgn = CreateRectRgnIndirect(rcPanel(i))
        If PtInRegion(hRgn, CLng(X), CLng(Y)) Then
            If Button = vbLeftButton Then
                If m_Panels(i).pEnabled = True Then
                    PanelNum = i
                    RaiseEvent MouseDownInPanel(i)
                End If
                DeleteObject hRgn
            End If
        End If
    Next i
    
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Dim hRgn    As Long
    Dim i       As Long
    
    On Error GoTo error_handler

    If ShowGripper = True Then
        hRgn = CreateRectRgnIndirect(rcGripper)
        If PtInRegion(hRgn, CLng(X), CLng(Y)) Then
            UserControl.MousePointer = vbSizeNWSE
            DeleteObject hRgn
            
            Exit Sub
        Else
            UserControl.MousePointer = vbArrow
            DeleteObject hRgn
        End If
    Else
        UserControl.MousePointer = vbArrow
    End If
    
    If m_PanelCount < 1 Then        ' Jut for sure ...
    
        Exit Sub
    End If
    For i = 1 To m_PanelCount
        hRgn = CreateRectRgnIndirect(rcPanel(i))
        If PtInRegion(hRgn, CLng(X), CLng(Y)) Then
            Extender.ToolTipText = m_Panels(i).ToolTipTxt
        End If
        DeleteObject hRgn
    Next i

    On Error GoTo 0

    Exit Sub


error_handler:
    
    ' User 'Dream' from PSC noticed an error in this sub, but I didn't get one using my VB5
    ' so to have a fast solution, I inserted this error handler. Thx for any hints!
    
    ' MsgBox "Error [" + Err.Description + "] in procedure 'UserControl_MouseMove()' at Benutzersteuerelement ucVeryWellsStatusBarXP"
    
    If hRgn Then
        DeleteObject hRgn
    End If
    
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    ReleaseCapture
    
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    
    Dim i As Long

    On Error GoTo error_handler
    
    flgRedrawEnabled = False
    With PropBag
        BackColor = .ReadProperty("BackColor", vbButtonFace)
        ForeColor = .ReadProperty("ForeColor", vbButtonText)
        ForeColorDisabled = .ReadProperty("ForeColorDissabled", vbGrayText)
        MaskColor = .ReadProperty("MaskColor", RGB(255, 0, 255))
        
        Set UserControl.Font = .ReadProperty("Font", UserControl.Parent.Font)
        ShowGripper = .ReadProperty("ShowGripper", True)
        ShowSeperators = .ReadProperty("ShowSeperators", True)
        m_Apperance = .ReadProperty("Apperance", m_def_Apperance)
        m_UseWindowsColors = .ReadProperty("UseWindowsColors", m_def_UseWindowsColors)
        m_TopLine = .ReadProperty("TopLine", True)
        
        m_PanelCount = .ReadProperty("NumberOfPanels", 0)
    End With
    
    If m_PanelCount > 0 Then
        ReDim m_Panels(1 To m_PanelCount) As New clsPanels
    End If
    For i = 1 To m_PanelCount
        With m_Panels(i)
            .pEnabled = PropBag.ReadProperty("pEnabled" & i)
            .ClientWidth = PropBag.ReadProperty("PWidth" & i)
            .ToolTipTxt = PropBag.ReadProperty("pTTText" & i)
            
            .PanelType = PropBag.ReadProperty("pType" & i, [PT Text spring size])
            .PanelText = PropBag.ReadProperty("pText" & i)
            .TextAlignment = PropBag.ReadProperty("pTextAlignment" & i, [TA Left])
            
            Set .PanelPicture = PropBag.ReadProperty("PanelPicture" & i, Nothing)
            .PanelPicAlignment = PropBag.ReadProperty("PanelPicAlignment" & i)
            
            .PanelBckgColor = PropBag.ReadProperty("pBckgColor" & i)
            .PanelGradient = PropBag.ReadProperty("pGradient" & i)
            .PanelEdgeSpacing = PropBag.ReadProperty("pEdgeSpacing" & i)
            .PanelEdgeInner = PropBag.ReadProperty("pEdgeInner" & i)
            .PanelEdgeOuter = PropBag.ReadProperty("pEdgeOuter" & i)
            
            .Tag = PropBag.ReadProperty("pTag" & i, vbNullString)
            
        End With
    Next i
    
    flgRedrawEnabled = True
    DrawStatusBar True
    
    Exit Sub
    
    
error_handler:

    If Err.Number = 327 Then        ' In Immediate Window:  err.raise 327  , then <Help> to get infos
        Err.Clear
    Else
        MsgBox "Error [" + Err.Description + "] in 'UserControl_ReadProperties()', Modul 'ucVeryWellsStatusBarXP'", _
                vbExclamation, " Fehler "
    End If
    
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    
    Dim i As Long
    
    On Error GoTo error_handler
    
    flgRedrawEnabled = False
    With PropBag
        .WriteProperty "BackColor", oBackColor
        .WriteProperty "ForeColor", oForeColor
        .WriteProperty "ForeColorDissabled", oDissColor
        .WriteProperty "MaskColor", oMaskColor
        
        .WriteProperty "Font", UserControl.Font
        .WriteProperty "ShowGripper", bDrawGripper
        .WriteProperty "ShowSeperators", bDrawSeperators
        .WriteProperty "Apperance", m_Apperance, m_def_Apperance
        .WriteProperty "UseWindowsColors", m_UseWindowsColors, m_def_UseWindowsColors
        .WriteProperty "TopLine", m_TopLine, True
        
        .WriteProperty "NumberOfPanels", m_PanelCount
    End With

    For i = 1 To m_PanelCount
        With m_Panels(i)
            
            PropBag.WriteProperty "pEnabled" & i, .pEnabled
            PropBag.WriteProperty "PWidth" & i, .ClientWidth
            PropBag.WriteProperty "pTTText" & i, .ToolTipTxt
            
            PropBag.WriteProperty "pType" & i, .PanelType
            PropBag.WriteProperty "pText" & i, .PanelText
            PropBag.WriteProperty "pTextAlignment" & i, .TextAlignment
            
            PropBag.WriteProperty "PanelPicture" & i, .PanelPicture
            PropBag.WriteProperty "PanelPicAlignment" & i, .PanelPicAlignment
            
            PropBag.WriteProperty "pBckgColor" & i, .PanelBckgColor
            PropBag.WriteProperty "pGradient" & i, .PanelGradient
            PropBag.WriteProperty "pEdgeSpacing" & i, .PanelEdgeSpacing
            PropBag.WriteProperty "pEdgeInner" & i, .PanelEdgeInner
            PropBag.WriteProperty "pEdgeOuter" & i, .PanelEdgeOuter
            
            PropBag.WriteProperty "pTag" & i, .Tag, vbNullString
                        
        End With