vbAccelerator - Contents of code file: vbInfoBar.ctl

VERSION 5.00
Begin VB.UserControl vbInfoBar 
   Alignable       =   -1  'True
   Appearance      =   0  'Flat
   BackColor       =   &H80000010&
   ClientHeight    =   660
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   660
   ScaleWidth      =   4800
   Begin VB.PictureBox picImage 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   255
      Left            =   1740
      ScaleHeight     =   255
      ScaleWidth      =   315
      TabIndex        =   0
      Top             =   240
      Visible         =   0   'False
      Width           =   315
   End
End
Attribute VB_Name = "vbInfoBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'-- Default Property Values:
Const m_def_Caption = "Information Bar"
Const m_def_IconCaption = ""
Const m_def_ButtonEnabled = True
Const m_def_lIconIndex = 0
Const m_def_bGradient = False

'-- Property Variables:
Private m_Caption       As String
Private m_IconCaption   As String
Private m_ButtonEnabled As Boolean
Private m_bGradient     As Boolean
Private m_bVertGradient As Boolean
Private m_BackColor2    As Long
Private m_bThinButtonEdge As Boolean

'-- Internal Variables
Private Enum epButtonState
    epbsNone = 0
    epbsRaised = 1
    epbsSunken = 2
End Enum

Public Enum eButtonState
    ebsNormal = 0
    ebsStayDown = 1
End Enum

Private m_bBitmap    As Boolean
Private m_hDCSrc     As Long
Private m_lBitmapW   As Long
Private m_lBitmapH   As Long
Private m_bDirty     As Boolean
Private m_hIml       As Long
Private m_lIconSizeX As Long
Private m_lIconSizeY As Long
Private m_lIconIndex As Long
Private m_ButRect    As RECT
Private m_bPressed   As Boolean
Private m_InFocus    As Boolean
Private m_Sticky     As eButtonState
Private m_State      As epButtonState
Private m_cMemDC     As cMemDC
Private m_Font       As IFont
Private m_oBackColor As OLE_COLOR
Private m_oForeColor As OLE_COLOR

Private WithEvents m_cTPM As cMouseTrack
Attribute m_cTPM.VB_VarHelpID = -1

'-- Event Declarations:
Public Event Click()
Public Event Paint()
Public Event ButtonDown(ButtonState As eButtonState)

Public Property Get BackColor() As OLE_COLOR
    BackColor = m_oBackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    m_oBackColor = New_BackColor
    PropertyChanged "BackColor"
    Refresh
End Property

Public Property Get BackColor2() As OLE_COLOR
    BackColor2 = m_BackColor2
End Property

Public Property Let BackColor2(ByVal New_BackColor2 As OLE_COLOR)
    m_BackColor2 = New_BackColor2
    PropertyChanged "BackColor2"
    Refresh
End Property

Public Property Get BackgroundPicture() As StdPicture
    Set BackgroundPicture = picImage.Picture
End Property

Public Property Set BackgroundPicture(sPic As StdPicture)

    On Error Resume Next

    Set picImage.Picture = sPic
    picImage.Refresh
    If (Err.Number <> 0) Or (picImage.ScaleWidth = 0) Or (sPic Is Nothing) Then
        m_hDCSrc = 0
        m_bBitmap = False
    Else
        m_bBitmap = True
        m_hDCSrc = picImage.hdc
        m_lBitmapW = picImage.ScaleWidth \ Screen.TwipsPerPixelX
        m_lBitmapH = picImage.ScaleHeight \ Screen.TwipsPerPixelY
    End If
    m_bDirty = True
    Refresh
    PropertyChanged "BackgroundPicture"

End Property

Public Property Get Caption() As String
    Caption = m_Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
   m_Caption = New_Caption
   PropertyChanged "Caption"
   Refresh
End Property

Public Property Get ButtonEnabled() As Boolean
    ButtonEnabled = m_ButtonEnabled
End Property

Public Property Let ButtonEnabled(ByVal New_ButtonEnabled As Boolean)
    m_ButtonEnabled = New_ButtonEnabled
    PropertyChanged "ButtonEnabled"
End Property

Public Property Get ForeColor() As OLE_COLOR
    ForeColor = m_oForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    m_oForeColor = New_ForeColor
    PropertyChanged "ForeColor"
    pDraw
End Property

Public Property Get Font() As IFont
   Set Font = UserControl.Font
End Property

Public Property Let Font(fnt As IFont)
   pSetFont fnt
   PropertyChanged "Font"
   Refresh
End Property

Public Property Set Font(fnt As IFont)
   pSetFont fnt
   PropertyChanged "Font"
   Refresh
End Property

Public Property Let ImageList(vThis As Variant)

    Dim hIml As Long

    If VarType(vThis) = vbObject Then
        On Error Resume Next
        vThis.ListImages(1).Draw 0, 0, 0, 1
        hIml = vThis.hImageList
        If (Err.Number <> 0) Then
            hIml = 0
        End If
        On Error GoTo 0
    ElseIf VarType(vThis) = vbLong Then
        hIml = vThis
    Else
        Err.Raise vbObjectError + 1049, "vbInfoBar." & App.EXEName, "ImageList
         property expects ImageList object or long hImageList handle."
    End If
    If (hIml <> 0) Then
        m_hIml = hIml
        ImageList_GetIconSize m_hIml, m_lIconSizeX, m_lIconSizeY
        pSetHeight
    End If

End Property

Public Sub GetDropDownPosition(Id As Long, X As Long, Y As Long)
    With UserControl.Extender
        X = .Left
        Y = .Top + .Height
    End With
End Sub

Public Property Get Gradient() As Boolean
    Gradient = m_bGradient
End Property

Public Property Let Gradient(ByVal New_Gradient As Boolean)
    m_bGradient = New_Gradient
    PropertyChanged "Gradient"
    m_bDirty = True
    Refresh
End Property

Public Property Get hwnd() As Long
   hwnd = UserControl.hwnd
End Property

Public Property Get IconCaption() As String
    IconCaption = m_IconCaption
End Property

Public Property Let IconCaption(ByVal New_IconCaption As String)
    m_IconCaption = New_IconCaption
    PropertyChanged "IconCaption"
    Refresh
End Property

Public Property Get IconIndex() As Long
   IconIndex = m_lIconIndex
End Property

Public Property Let IconIndex(ByVal lIconIndex As Long)
   m_lIconIndex = lIconIndex
    PropertyChanged "IconIndex"
End Property

Public Sub Refresh()
   pDraw
End Sub

Public Sub ReleaseButton()
    m_bPressed = False
    m_InFocus = False
    m_Sticky = ebsNormal
    m_State = epbsNone
    pDraw
End Sub

Public Property Get VerticalGradient() As Boolean
    VerticalGradient = m_bVertGradient
End Property

Public Property Let VerticalGradient(ByVal New_VertGradient As Boolean)
    m_bVertGradient = New_VertGradient
    PropertyChanged "VerticalGradient"
    m_bDirty = True
    pDraw
End Property

Private Sub m_cTPM_MouseHover(Button As MouseButtonConstants, Shift As
 ShiftConstants, X As Single, Y As Single)
'    Debug.Print "m_cTPM_MouseHover"
   m_cTPM.StartMouseTracking
End Sub

Private Sub m_cTPM_MouseLeave()
    If m_Sticky = ebsNormal And m_bPressed = False Then
        'Debug.Print "vbInfoBar->m_cTPM::MouseLeave"
        If m_InFocus = True Then
            m_InFocus = False
            m_State = epbsNone
            pDraw
        End If
    End If
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
    pMouseDown Button, Shift, X \ Screen.TwipsPerPixelX, Y \
     Screen.TwipsPerPixelY
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
    If Not m_cTPM.Tracking Then
      If X > 0 And Y > 0 Then
         m_cTPM.StartMouseTracking
      End If
    End If
    pMouseMove Button, Shift, X \ Screen.TwipsPerPixelX, Y \
     Screen.TwipsPerPixelY
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
    pMouseUp Button, Shift, X \ Screen.TwipsPerPixelX, Y \ Screen.TwipsPerPixelY
End Sub

Private Sub UserControl_Paint()
   pDraw
End Sub

Private Sub UserControl_Resize()
   pDraw
End Sub

Private Sub UserControl_AmbientChanged(PropertyName As String)
'    Debug.Print "UserControl_AmbientChanged: "; PropertyName
End Sub

Private Sub UserControl_Initialize()
'    Debug.Print "UserControl_Initialize"
End Sub

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_ButtonEnabled = m_def_ButtonEnabled
    Set UserControl.Font = Ambient.Font
    m_Caption = m_def_Caption
    m_IconCaption = m_def_IconCaption
    pInitialise
End Sub


'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    pInitialise

    Dim sFnt As New StdFont
    sFnt.Name = "MS Sans Serif"
    sFnt.Size = 8
    Set Font = PropBag.ReadProperty("Font", sFnt)

    m_ButtonEnabled = PropBag.ReadProperty("ButtonEnabled", m_def_ButtonEnabled)
    BackColor = PropBag.ReadProperty("BackColor", &H80000010)
    m_BackColor2 = PropBag.ReadProperty("BackColor2", &H80000010)
    m_oForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    Set BackgroundPicture = PropBag.ReadProperty("BackgroundPicture", Nothing)
    m_Caption = PropBag.ReadProperty("Caption", m_def_Caption)
    m_IconCaption = PropBag.ReadProperty("IconCaption", m_def_IconCaption)
    m_lIconIndex = PropBag.ReadProperty("IconIndex", m_def_lIconIndex)
    m_bGradient = PropBag.ReadProperty("Gradient", m_def_bGradient)
    m_bVertGradient = PropBag.ReadProperty("VerticalGradient", m_def_bGradient)

End Sub

Private Sub UserControl_Terminate()
    Set m_cMemDC = Nothing
    Set m_cTPM = Nothing
'    Debug.Print "UserControl_Terminate"
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Dim sFnt As New StdFont
    sFnt.Name = "MS Sans Serif"
    sFnt.Size = 8
    PropBag.WriteProperty "Font", Font, sFnt

    PropBag.WriteProperty "ButtonEnabled", m_ButtonEnabled, m_def_ButtonEnabled
    PropBag.WriteProperty "BackColor", m_oBackColor, &H80000010
    PropBag.WriteProperty "BackColor2", m_BackColor2, &H80000010
    PropBag.WriteProperty "ForeColor", m_oForeColor, &H80000012
    PropBag.WriteProperty "BackgroundPicture", BackgroundPicture, Nothing
    PropBag.WriteProperty "Caption", m_Caption, m_def_Caption
    PropBag.WriteProperty "IconCaption", m_IconCaption, m_def_IconCaption
    PropBag.WriteProperty "IconIndex", m_lIconIndex, m_def_lIconIndex
    PropBag.WriteProperty "Gradient", m_bGradient, m_def_bGradient
    PropBag.WriteProperty "VerticalGradient", m_bVertGradient, m_def_bGradient

End Sub

Private Sub pDraw()

    Dim sText     As String
    Dim eFlags    As ECGTextAlignFlags
    Dim PicRect  As RECT
    Dim CaptRect  As RECT
    Dim SubRect   As RECT
    Dim lWidth    As Long
    Dim lIconLeft As Long
    Dim lHDC      As Long
    Dim lhDCU     As Long
    Dim hFontOld  As Long
    Dim bMemDC    As Boolean

    pPrepareMemDC lHDC, lhDCU, bMemDC
    GetClientRect UserControl.hwnd, PicRect
    
    '-- Box text
    CaptRect = PicRect
    CaptRect.Left = CaptRect.Left + 2
    CaptRect.Right = CaptRect.Right - m_lIconSizeX - 5
    pFillBackground lHDC, PicRect, 0, 0
    DrawImage m_hIml, _
              m_lIconIndex, _
              lHDC, _
              CaptRect.Right + 5, _
              PicRect.Top + (PicRect.Bottom - m_lIconSizeY) \ 2, _
              m_lIconSizeX, _
              m_lIconSizeY
    lWidth = UserControl.TextWidth(m_Caption) \ Screen.TwipsPerPixelX + 4
    sText = m_Caption & vbNullChar
    eFlags = DT_WORD_ELLIPSIS Or _
             DT_PATH_ELLIPSIS Or _
             DT_MODIFYSTRING Or _
             DT_END_ELLIPSIS Or _
             DT_VCENTER Or DT_SINGLELINE 'vcenter won't work if multi-line.
    If CaptRect.Right - CaptRect.Left > lWidth Then
        CaptRect.Right = CaptRect.Left + lWidth
    End If
    hFontOld = SelectObject(lHDC, Font.hFont)
    If m_State = epbsSunken Then
      OffsetRect CaptRect, 1, 1
    End If
    DrawText lHDC, sText, -1, CaptRect, eFlags
    If m_State = epbsSunken Then
      OffsetRect CaptRect, 0, 0
    End If
    m_ButRect = CaptRect
    m_ButRect.Left = UserControl.ScaleLeft
    If m_State = epbsRaised Then
      If m_bThinButtonEdge Then
         DrawEdge lHDC, m_ButRect, BDR_RAISEDINNER, BF_RECT
      Else
         DrawEdge lHDC, m_ButRect, EDGE_RAISED, BF_RECT
      End If
    ElseIf m_State = epbsSunken Then
      If m_bThinButtonEdge Then
         m_ButRect.Bottom = m_ButRect.Bottom - 1
         DrawEdge lHDC, m_ButRect, BDR_SUNKENOUTER, BF_RECT
      Else
         DrawEdge lHDC, m_ButRect, EDGE_SUNKEN, BF_RECT
      End If
    End If
    pMemDCToDC lhDCU, lHDC, bMemDC, PicRect

End Sub

Private Sub pFillBackground(ByVal lHDC As Long, _
                            ByRef tR As RECT, _
                            ByVal lOffsetX As Long, _
                            ByVal lOffsetY As Long)

    Dim hBr As Long

    If (m_bBitmap) Then
        TileArea lHDC, _
                 tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, _
                 m_hDCSrc, _
                 m_lBitmapW, m_lBitmapH, _
                 lOffsetX, lOffsetY
    ElseIf (m_bGradient) Then
        DrawGraduatedBackdrop lHDC, _
                              tR.Left, tR.Top, tR.Right, tR.Bottom, _
                              TranslateColor(m_oBackColor),
                               TranslateColor(m_BackColor2), _
                              m_bVertGradient
    Else
        hBr = CreateSolidBrush(TranslateColor(m_oBackColor))
        FillRect lHDC, tR, hBr
        DeleteObject hBr
    End If

End Sub

Private Sub pInitialise()
    Set m_cMemDC = New cMemDC
    'Set m_cMemDC2 = New cMemDC
    Set m_cTPM = New cMouseTrack
    m_cTPM.AttachMouseTracking Me
    m_Sticky = ebsNormal
End Sub

Private Sub pMouseDown(ByVal Button As MouseButtonConstants, ByVal Shift As
 ShiftConstants, ByVal X As Long, ByVal Y As Long)
    If m_ButtonEnabled Then
        If PtInRect(m_ButRect, X, Y) Then
            If m_Sticky = ebsNormal Then
                RaiseEvent ButtonDown(m_Sticky)
                pMouseMove Button, Shift, X, Y
                'Debug.Print "vbInfoBar->pMouseDown"
            End If
        End If
    End If
End Sub

Private Sub pMouseMove(ByVal Button As MouseButtonConstants, ByVal Shift As
 ShiftConstants, ByVal X As Long, ByVal Y As Long)

    Dim lHDC As Long

    If (m_Sticky And m_bPressed) Then Exit Sub
    If m_ButtonEnabled Then
        lHDC = UserControl.hdc
        If PtInRect(m_ButRect, X, Y) Then
            m_InFocus = True
            If Button Then
                m_bPressed = True
            Else
                m_bPressed = False
            End If
            If Not m_bPressed Then
                m_State = epbsRaised
                pDraw
            Else
                m_State = epbsSunken
                pDraw
           End If
        Else
            If m_InFocus Then
                m_State = epbsNone
                pDraw
                m_InFocus = False
            End If
        End If
    End If

End Sub

Private Sub pMouseUp(ByVal Button As MouseButtonConstants, ByVal Shift As
 ShiftConstants, ByVal X As Long, ByVal Y As Long)
    'Debug.Print "Raise Item Click Event!"
    If m_ButtonEnabled Then
        If PtInRect(m_ButRect, X, Y) Then
            RaiseEvent Click
        End If
    End If
End Sub

Private Sub pMemDCToDC(ByVal lhDCU As Long, ByVal lHDC As Long, ByVal bMemDC As
 Boolean, ByRef tR As RECT)
   If bMemDC Then
      With tR
          BitBlt lhDCU, .Left, .Top, .Right - .Left, .Bottom - .Top, lHDC, 0,
           0, vbSrcCopy
      End With
   End If
End Sub

Private Sub pPrepareMemDC(ByRef lHDC As Long, ByRef lhDCU As Long, ByRef bMemDC
 As Boolean)
   
   lhDCU = UserControl.hdc
   If Not m_cMemDC Is Nothing Then
      m_cMemDC.Width = UserControl.ScaleWidth \ Screen.TwipsPerPixelY
      m_cMemDC.Height = UserControl.ScaleHeight \ Screen.TwipsPerPixelX
      lHDC = m_cMemDC.hdc
   End If
   If lHDC = 0 Then
      lHDC = lhDCU
   Else
      bMemDC = True
   End If
   SetBkColor lHDC, TranslateColor(m_oBackColor)
   SetBkMode lHDC, TRANSPARENT
   SetTextColor lHDC, TranslateColor(m_oForeColor)

End Sub

Private Sub pSetFont(fnt As IFont)
   If Not fnt Is Nothing Then
      Set UserControl.Font = fnt
      Set m_Font = fnt
      pSetHeight
      pDraw
   End If
End Sub

Private Sub pSetHeight()

   Dim lHeight As Long

   lHeight = UserControl.TextHeight("Gg") + 4 * Screen.TwipsPerPixelY
   If m_lIconSizeY * Screen.TwipsPerPixelY > lHeight Then
      lHeight = m_lIconSizeY * Screen.TwipsPerPixelY
   End If
   If UserControl.Height <> lHeight Then
      UserControl.Height = lHeight
      m_cMemDC.Height = lHeight \ Screen.TwipsPerPixelY
   End If

End Sub