vbAccelerator - Contents of code file: fNonMDITest.frm

VERSION 5.00
Begin VB.Form frmNonMDI 
   Caption         =   "Custom Title Bar Draw Test (A bit dodgy, I think!)"
   ClientHeight    =   4200
   ClientLeft      =   7500
   ClientTop       =   6075
   ClientWidth     =   6195
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   4200
   ScaleWidth      =   6195
   Begin VB.PictureBox picBrush 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   120
      Left            =   360
      Picture         =   "fNonMDITest.frx":0000
      ScaleHeight     =   120
      ScaleWidth      =   120
      TabIndex        =   0
      Top             =   180
      Width           =   120
   End
End
Attribute VB_Name = "frmNonMDI"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private WithEvents m_cT As cTitleBar
Attribute m_cT.VB_VarHelpID = -1

Private Type RECT
    Left As Long
    tOP As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
Private Const PS_DASH = 1                    '  -------
Private Const PS_DASHDOT = 3                 '  _._._._
Private Const PS_DASHDOTDOT = 4              '  _.._.._
Private Const PS_DOT = 2                     '  .......
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal
 crColor As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
        TranslateColor = -1 'CLR_INVALID
    End If
End Function
Private Function LightenColor(ByVal lColor As Long, ByVal fP As Double) As Long
Dim bR As Double, bG As Double, bB As Double
    bB = (lColor And &HFF0000) \ &H10000
    bG = (lColor And &HFF00&) \ &H100
    bR = lColor And &HFF
    bR = bR + ((255 - bR) / 255) * fP: bG = bG + ((255 - bG) / 255) * fP: bB =
     bB + ((255 - bB) / 255) * fP
    If (bR < 0) Then bR = 0
    If (bG < 0) Then bG = 0
    If (bB < 0) Then bB = 0
    If (bR > 255) Then bR = 255
    If (bG > 255) Then bG = 255
    If (bB > 255) Then bB = 255
    
    LightenColor = RGB(bR, bG, bB)
End Function
Private Sub Form_Load()
    Set m_cT = New cTitleBar
    m_cT.CustomDraw = True
    m_cT.Color(eActiveStartColor) =
     LightenColor(TranslateColor(vbActiveTitleBar), 120)
    m_cT.Color(eActiveText) = &HFFFFFF
    m_cT.GradientForm Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    m_cT.GradientReleaseForm
    
End Sub


Private Sub m_cT_CustomDraw(ByVal eDrawStage As
 TBarGrad.EGradTitleBarDrawStage, bDoDefault As Boolean, ByVal lhDC As Long,
 ByVal lLeft As Long, ByVal lTop As Long, ByVal lWidth As Long, ByVal lHeight
 As Long, ByVal bActive As Boolean)
    
    
    If (eDrawStage = eDrawIcon) Then
    
    Dim hBR As Long
    Dim hBrushOld As Long
    Dim rc As RECT
    Dim hPen As Long
    Dim hPenOld As Long
    Dim tOP As POINTAPI
    Dim lY As Long
    Dim lCOl As Long
    Dim lOffset As Long

    Debug.Print "Draw", lhDC, lLeft, lTop, lWidth, lHeight
    
    'hBR = CreatePatternBrush(picBrush.Picture.Handle)
    If (bActive) Then
        lCOl = TranslateColor(m_cT.Color(eActiveStartColor))
        SetBkColor lhDC, lCOl
        hBR = CreateSolidBrush(lCOl)
    Else
        lCOl = TranslateColor(vbInactiveTitleBar)
        SetBkColor lhDC, lCOl
        hBR = CreateSolidBrush(lCOl)
        lCOl = LightenColor(lCOl, 50)
    End If
    rc.Left = lLeft
    rc.tOP = lTop
    rc.Right = rc.Left + lWidth
    rc.Bottom = rc.tOP + lHeight
    'FillRect lhDC, rc, hBR
    
    hBrushOld = SelectObject(lhDC, hBR)
    hPen = CreatePen(PS_SOLID, 1, lCOl)
    hPenOld = SelectObject(lhDC, hPen)
    For lY = rc.tOP + 1 To rc.Bottom - 2 Step 4
        MoveToEx lhDC, rc.Left + lOffset, lY, tOP
        LineTo lhDC, rc.Right, lY
    Next lY
    SelectObject lhDC, hPenOld
    DeleteObject hPen
    SelectObject lhDC, hBrushOld
    DeleteObject hBR
    End If
    
End Sub