September 30, 2014
Hot Topics:
RSS RSS feed Download our iPhone app

Creating a Gradulated Title Bar

  • November 19, 2002
  • By Sam Huggill
  • Send Email »
  • More Articles »

When I discovered the cTitleBar class on the vbAccelerator web site, I knew I had to share it with you.

The class module allows you to paint gradients across your title bar without losing any of the features (caption, icon and buttons)

Make sure that you have Steve McMahon's SSubTmr subclassing component installed and registered on your machine before you try this project. Check vbaccelerator.com for this component.

Add a class module (cTitleBar) and copy the following code into it:

Option Explicit
' ====================================================
' Filename: cTitlebar.cls
' Author: Steve McMahon
' Date: 25 November 1998
'
' Mostly based on Ben Baird's code, see below.
' Changes:
' -Change Subclass method to SSUBTMR
' -Added WM_STYLECHANGED and WM_SETTEXT to allow
' titlebar to be
' repainted when caption changes.
' -Icon is now drawn transparent rather than 
' with black background
' -Added facility to change start/end and text
' colours (although if
' the end colour isn't the title bar colour, 
' it doesn't really work)
' -Removed WM_SIZE subclass this prevented
' the form from being resized and/or 
' lost the Form_Resize message
' and was also unnecessary
' -Now determines what buttons are present 
' when drawing gradient -Check for tool window 
' and appropriately smaller Tbar
' -Added owner draw background support
'
'
' ====================================================

'//================================================
'+ Gradient titlebar example, version 1.1
'+ Author: Ben Baird
'+ Comments: Uploaded to Visual Basic Thunder
' with Excalibur CodeLib on Monday,
' September 1, 1997.
' Thanks goes to Eric Dimayuga for
' letting me bounce some ideas off
' him. He also assisted me with the
' theory of the code.
'
'+ If you release this code or any 
' modified version of it to the private, 
' I would appreciate some
' credit for the original code.
'+ FIXED IN THIS VERSION:
' - Some trouble with the 
' GradientGetCapsFont routine,
' mainly a problem with the LOGFONT declaration.
' - Added some more cleanup code.
'//================================================

Dim GradhWnd As Long, GradIcon As Long
Dim DrawDC As Long, tmpDC As Long
Dim hRgn As Long
Dim tmpGradFont As Long
Private m_bInSubClass As Boolean
Private m_bMDI As Boolean
Private m_pic As StdPicture
Private m_lHdc As Long
Private m_lHBmpOld As Long
Private m_lhPalOld As Long
Private m_lBitmapW As Long
Private m_lBitmapH As Long
Private m_sFileName As String
Private m_bCustomDraw As Boolean
Private m_bTextTransparent As Boolean
Implements ISubclass
Private m_emr As EMsgResponse
Private m_oColor(1 To 6) As OLE_COLOR
Public Enum EGradTitleBarColors
  eActiveStartColor = 1
  eActiveEndColor = 2
  eActiveText = 3
  einActivestartcolor = 4
  eInactiveEndColor = 5
  eInActiveText = 6
End Enum
Public Enum EGradTitleBarDrawStage
  eDrawBackground
  eDrawIcon
  eDrawText
End Enum

Public Event CustomDraw(ByVal eDrawStage _
  As EGradTitleBarDrawStage, _
  ByRef 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)

Private Type DRAWTEXTPARAMS
  cbSize As Long
  iTabLength As Long
  iLeftMargin As Long
  iRightMargin As Long
  uiLengthDrawn As Long
End Type
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName As String * 32
End Type

Private Declare Function SystemParametersInfo _
  Lib "user32" Alias _
  "SystemParametersInfoA" _
  (ByVal uAction As Long, ByVal uParam As Long, _
  lpvParam As Any, _
  ByVal fuWinIni As Long) As Long

Private Const SPI_GETNONCLIENTMETRICS = 41

Private Type NONCLIENTMETRICS
 cbSize As Long
  iBorderWidth As Long
  iScrollWidth As Long
  iScrollHeight As Long
  iCaptionWidth As Long
  iCaptionHeight As Long
  lfCaptionFont As LOGFONT
  iSMCaptionWidth As Long
  iSMCaptionHeight As Long
  lfSMCaptionFont As LOGFONT
  iMenuWidth As Long
  iMenuHeight As Long
  lfMenuFont As LOGFONT
  lfStatusFont As LOGFONT
  lfMessageFont As LOGFONT
End Type

Dim CaptionFont As LOGFONT
Private Declare Function CreateFontIndirect _
  Lib "gdi32" Alias _
  "CreateFontIndirectA" _
  (lpLogFont As LOGFONT) As Long

Private Declare Function CallWindowProc Lib _
  "user32" Alias _
  "CallWindowProcA" _
  (ByVal lpPrevWndFunc As Long, ByVal hwnd 
  As Long, ByVal Msg As Long, ByVal _
  wParam As Long, _
  ByVal lParam As Long) As Long

Private Declare Function GetWindow Lib _
  "user32" (ByVal hwnd As Long, _
  ByVal wCmd As Long) As Long

Private Declare Function GetWindowText _
  Lib "user32" _
  Alias "GetWindowTextA" _
  (ByVal hwnd As Long, _
  ByVal lpString As String, _
  ByVal cch As Long) As Long

Private Declare Function GetDC Lib _
  "user32" _
  (ByVal hwnd As Long) As Long

Private Declare Function GetWindowDC _
  Lib "user32" _
  (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRgn _
  Lib "user32" _
  (ByVal hwnd As Long, ByVal hRgn _
  As Long) As Long
Private Declare Function GetWindowRect _
  Lib "user32" _
  (ByVal hwnd As Long, lpRect As RECT) _
  As Long
Private Declare Function GetActiveWindow _
  Lib "user32" () As Long
Private Declare Function GetClassLong _
  Lib "user32" _
  Alias "GetClassLongA" _
  (ByVal hwnd As Long, ByVal nIndex _
  As Long) As Long
Private Declare Function GetWindowLong _
  Lib "user32" _
  Alias "GetWindowLongA" _
  (ByVal hwnd As Long, _
  ByVal nIndex As Long) As Long
Private Declare Function SetClassLong _
  Lib "user32" _
  Alias "SetClassLongA" _
  (ByVal hwnd As Long, _
  ByVal nIndex As Long, ByVal _
  dwNewLong As Long) As Long
Private Declare Function SetWindowLong _
  Lib "user32" _
  Alias "SetWindowLongA" _
  (ByVal hwnd As Long, _
  ByVal nIndex As Long, ByVal _
  dwNewLong As Long) As Long

Private Const GWL_WNDPROC = (-4)
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const GCL_WNDPROC = (-24)
Private Const GCL_HICON = (-14)
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000 _
'WS_BORDER Or WS_DLGFRAME
Private Const WS_CHILD = &H40000000
Private Const WS_CHILDWINDOW = (WS_CHILD)
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or _
  WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or _
  WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_POPUP = &H80000000
Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER _
  Or WS_SYSMENU)
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
Private Const WS_EX_TOOLWINDOW = &H80&

Private Declare Function GetParent Lib _
  "user32" _
  (ByVal hwnd As Long) As Long

Private Declare Function DeleteDC Lib _
  "gdi32" _
  (ByVal hDC As Long) As Long
Private Declare Function DeleteObject _
  Lib "gdi32" _
  (ByVal hObject As Long) As Long
Private Declare Function OffsetClipRgn _
  Lib "gdi32" _ 
  (ByVal hDC As Long, ByVal X As Long, _
  ByVal Y As Long) As Long
Private Declare Function DestroyIcon Lib _
  "user32" _
  (ByVal hIcon As Long) As Long
Private Declare Function OffsetRect _
  Lib "user32" _
  (lpRect As RECT, ByVal X As Long, _
  ByVal Y As Long) As Long
Private Declare Function DrawIcon _
  Lib "user32" _
  (ByVal hDC As Long, ByVal X _
  As Long, ByVal Y As Long, _
  ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx _
  Lib "user32" _
  (ByVal hDC As Long, ByVal xLeft As Long, _
  ByVal yTop As Long, _
  ByVal hIcon As Long, ByVal cxWidth _
  As Long, ByVal cyWidth As
Long, ByVal istepIfAniCur As Long, _
  hbrFlickerFreeDraw As Long, _
  ByVal diFlags As Long) As Long
Private Const DI_MASK = &H1
Private Const DI_IMAGE = &H2
Private Const DI_NORMAL = &H3
Private Const DI_COMPAT = &H4
Private Const DI_DEFAULTSIZE = &H8

Private Declare Function RectInRegion _
  Lib "gdi32" _
  (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function DrawText _
  Lib "user32" Alias _
  "DrawTextA" (ByVal hDC As Long, _
  ByVal lpStr As String, _
  ByVal nCount As Long, lpRect As RECT, ByVal _
  wFormat As Long) As Long
Private Declare Function DrawTextEx Lib _
  "user32" Alias _
  "DrawTextExA" (ByVal hDC As Long, _
  ByVal lpsz As String, _
  ByVal n As Long, lpRect As RECT, _
  ByVal un As Long, _
  lpDrawTextParams As DRAWTEXTPARAMS) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_VCENTER = &H4
Private Const DT_END_ELLIPSIS = &H8000&
Private Declare Function ReleaseDC _
  Lib "user32" _
  (ByVal hwnd As Long, ByVal hDC As Long) _
  As Long
Private Declare Function SelectClipRgn _
  Lib "gdi32" _
  (ByVal hDC As Long, ByVal hRgn As Long) _
  As Long
Private Declare Function GetClipRgn Lib _
  "gdi32" _
  (ByVal hDC As Long, ByVal hRgn As Long) _
  As Long
Private Declare Function SendMessage _
  Lib "user32" _
  Alias "SendMessageA" _
  (ByVal hwnd As Long, _
  ByVal wMsg As Long, ByVal wParam As Long, _
  lParam As Any) As Long
Private Declare Function DrawCaption Lib _
  "user32" _
  (ByVal hwnd As Long, ByVal hDC As Long, _
  pcRect As RECT, _
  ByVal un As Long) As Long
Private Declare Function ReleaseCapture _
  Lib "user32" () As Long
Private Declare Function SelectObject _
  Lib "gdi32" _
  (ByVal hDC As Long, ByVal hObject As Long) _
  As Long
Private Declare Function BitBlt Lib _
  "gdi32" (ByVal hDestDC As Long, _
  ByVal X As Long, ByVal Y As Long, _
  ByVal nWidth As Long, _
  ByVal nHeight As Long, ByVal hSrcDC As Long, _
  ByVal xSrc As Long, _
  ByVal ySrc As Long, ByVal _
  dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020
Private Declare Function GetStockObject _
  Lib "gdi32" _
  (ByVal nIndex As Long) As Long
Private Declare Function SetBkMode _
  Lib "gdi32" _
  (ByVal hDC As Long, ByVal nBkMode As Long) _
  As Long
Private Const TRANSPARENT = 1
Private Const OPAQUE = 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 Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type
Private Declare Function GetDesktopWindow _
  Lib "user32" () As Long
Private Declare Function GetObjectAPI Lib _
  "gdi32" Alias _
  "GetObjectA" (ByVal hObject As Long, _
  ByVal nCount As Long, _
  lpObject As Any) As Long

Private Declare Function CopyImage Lib _
  "user32" (ByVal handle As Long, _
  ByVal un1 As Long, ByVal n1 As Long, _
  ByVal n2 As Long, ByVal un2 As Long) _
  As Long
Private Declare Function SetTextColor _
  Lib "gdi32" _
  (ByVal hDC As Long, ByVal crColor As Long) _
  As Long

Private Declare Function GetSystemMetrics _
  Lib "user32" _
  (ByVal nIndex As Long) As Long
Private Const SM_CMETRICS = 44
Private Const SM_CMOUSEBUTTONS = 43
Private Const SM_CXBORDER = 5
Private Const SM_CXCURSOR = 13
Private Const SM_CXDLGFRAME = 7
Private Const SM_CXDOUBLECLK = 36
Private Const SM_CXFIXEDFRAME = SM_CXDLGFRAME
Private Const SM_CXFRAME = 32
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CXHSCROLL = 21
Private Const SM_CXHTHUMB = 10
Private Const SM_CXICON = 11
Private Const SM_CXICONSPACING = 38
Private Const SM_CXMIN = 28
Private Const SM_CXMINTRACK = 34
Private Const SM_CXSCREEN = 0
Private Const SM_CXSMSIZE = 30
Private Const SM_CXSIZEFRAME = SM_CXFRAME
Private Const SM_CXVSCROLL = 2
Private Const SM_CYBORDER = 6
Private Const SM_CYCAPTION = 4
Private Const SM_CYCURSOR = 14
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYDOUBLECLK = 37
Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME
Private Const SM_CYFRAME = 33
Private Const SM_CYFULLSCREEN = 17
Private Const SM_CYHSCROLL = 3
Private Const SM_CYICON = 12
Private Const SM_CYICONSPACING = 39
Private Const SM_CYKANJIWINDOW = 18
Private Const SM_CYMENU = 15
Private Const SM_CYMIN = 29
Private Const SM_CYMINTRACK = 35
Private Const SM_CYSCREEN = 1
Private Const SM_CYSMSIZE = 31
Private Const SM_CYSIZEFRAME = SM_CYFRAME
Private Const SM_CYVSCROLL = 20
Private Const SM_CYVTHUMB = 9
Private Const SM_DBCSENABLED = 42
Private Const SM_DEBUG = 22
Private Const SM_MENUDROPALIGNMENT = 40
Private Const SM_MOUSEPRESENT = 19
Private Const SM_PENWINDOWS = 41
Private Const SM_RESERVED1 = 24
Private Const SM_RESERVED2 = 25
Private Const SM_RESERVED3 = 26
Private Const SM_RESERVED4 = 27
Private Const SM_SWAPBUTTON = 23
Private Const SM_CYSMCAPTION = 51


Private Declare Function FillRect _
  Lib "user32" _
  (ByVal hDC As Long, lpRect As RECT, _
  ByVal hBrush As Long) As Long
Private Declare Function CreateCompatibleBitmap _
  Lib "gdi32" _
  (ByVal hDC As Long, ByVal nWidth As Long, _
  ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC _
  Lib "gdi32" 
  (ByVal hDC As Long) As Long
Private Declare Function CreateRectRgnIndirect _
  Lib "gdi32" _
  (lpRect As RECT) As Long
Private Declare Function CreateRectRgn _
  Lib "gdi32" (ByVal X1 As Long, _
  ByVal Y1 As Long, ByVal X2 As Long, _
  ByVal Y2 As Long) As Long
Private Declare Function ExcludeClipRect _
  Lib "gdi32" (ByVal hDC As Long, _
  ByVal X1 As Long, ByVal Y1 As Long, _
  ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush _
  Lib "gdi32" _
  (ByVal crColor As Long) As Long

Private Declare Function DrawFrameControl _
  Lib "user32" (ByVal hDC As Long, _
  lpRect As RECT, ByVal un1 As Long, _
  ByVal un2 As Long) As Long

Private Const DFC_CAPTION = 1
Private Const DFCS_CAPTIONRESTORE = &H3
Private Const DFCS_CAPTIONMIN = &H1
Private Const DFCS_CAPTIONMAX = &H2
Private Const DFCS_CAPTIONHELP = &H4
Private Const DFCS_CAPTIONCLOSE = &H0
Private Const DFCS_INACTIVE = &H100

Private Const WM_ACTIVATE = &H6
Private Const WM_SIZE = &H5
Private Const WM_GETFONT = &H31
Private Const WM_STYLECHANGED = &H7D
Private Const WM_GETTEXT = &HD
Private Const WM_SETTEXT = &HC

' WM_ACTIVATE state values
Private Const WA_INACTIVE = 0
Private Const WA_ACTIVE = 1
Private Const WA_CLICKACTIVE = 2

Private Const WM_NCHITTEST = &H84
Private Const WM_NCPAINT = &H85
Private Const WM_NCACTIVATE = &H86

Private Const WM_MDIACTIVATE = &H222
Private Const WM_MDIGETACTIVE = &H229
Public Property Let TextTransparent_
 (ByVal bState As Boolean)
  m_bTextTransparent = bState
End Property
Public Property Get TextTransparent() _
  As Boolean
  TextTransparent = m_bTextTransparent
End Property
Public Property Let CustomDraw _
 (ByVal bState As Boolean)
  m_bCustomDraw = bState
End Property
Public Property Get CustomDraw() _
  As Boolean
  CustomDraw = m_bCustomDraw
End Property

Public Property Get Color _ 
(ByVal eType As EGradTitleBarColors) _
  As OLE_COLOR
  Color = m_oColor(eType)
End Property
Public Property Let Color _
 (ByVal eType As EGradTitleBarColors, _
  oColor As OLE_COLOR)
  If (m_oColor(eType) <> _
  oColor) Then
    m_oColor(eType) = oColor
    If (GradhWnd <> 0) Then
      SendMessage GradhWnd, _
  WM_NCPAINT, 0, 0
    End If
  End If
End Property

Public Property Get Picture() As StdPicture
  Set Picture = m_pic
End Property
Public Property Let Picture(oPic As StdPicture)
  ' Load a picture from a StdPicture object:
  pClearUp
  If (pbEnsurePicture()) Then
    Set m_pic = oPic
    If (Err.Number = 0) Then
      pbGetBitmapIntoDC
    End If
  End If
End Property
Private Function pbEnsurePicture() As Boolean
  On Error Resume Next
  pbEnsurePicture = True
  If (m_pic Is Nothing) Then
    Set m_pic = New StdPicture
    If (Err.Number <> 0) Then
      pErr 3, "Unable to allocate _
      memory for picture object."
      pbEnsurePicture = False
    End If
  End If
  On Error GoTo 0
  Exit Function
End Function
Private Function pbGetBitmapIntoDC() As Boolean
  Dim tB As BITMAP
  Dim lhDC As Long, lHwnd As Long

  ' Make a DC to hold the picture bitmap 
  ' which we can blt from:
  lHwnd = GetDesktopWindow()
  lhDC = GetDC(lHwnd)
  m_lHdc = CreateCompatibleDC(lhDC)
  ReleaseDC lHwnd, lhDC
  If (m_lHdc <> 0) Then
    ' Get size of bitmap:
    GetObjectAPI m_pic.handle, LenB(tB), tB
    m_lBitmapW = tB.bmWidth
    m_lBitmapH = tB.bmHeight

    ' Select bitmap into DC:
    m_lHBmpOld = SelectObject(m_lHdc, m_pic.handle)
    If (m_lHBmpOld <> 0) Then
      ' Select the palette
      into the DC:
      m_lhPalOld =
      SelectObject(m_lHdc, m_pic.hPal)
      pbGetBitmapIntoDC =
      True
    Else
      pClearUp
      pErr 2, "Unable to
      select bitmap into DC"
    End If
  Else
    pErr 1, "Unable to create compatible
    DC"
  End If
End Function

Private Sub pClearUp()
  ' Clear reference to the filename:
  m_sFileName = ""
  ' If we have a DC, then clear up:
  If (m_lHdc <> 0) Then
    ' Select the bitmap out of DC:
    If (m_lHBmpOld <> 0) Then
      SelectObject m_lHdc, m_lHBmpOld
      ' The original bitmap does not have to 
      ' deleted because it is owned by m_pic
    End If
    ' Select the palette out of the DC:
    If (m_lhPalOld <> 0) Then
      SelectObject m_lHdc, m_lhPalOld
      ' The original palette does not have _
      ' to deleted because it is owned by m_pic
    End If
    ' Remove the DC:
    DeleteObject m_lHdc
  End If
End Sub

Private Sub pErr(lNumber As Long, sMsg As String)

  Err.Raise vbObjectError + 1048 + lNumber, _
    App.EXEName & _
    ".cTitleBar", sMsg & ", _
    [" & lNumber & _
    "]"
End Sub

Private Function GradientCallback _
  (ByVal hwnd As Long, _
  ByVal wMsg As Long, ByVal wParam _
  As Long, ByVal lParam _
  As Long) As Long

  Dim OldBMP As Long, NewBMP As Long
  Dim rcWnd As RECT

  Select Case wMsg
    Case WM_NCACTIVATE, WM_MDIACTIVATE

      'Debug.Print "ACTIVATE"

      GetWindowRect GradhWnd, rcWnd

      'Create memory DC to draw the titlebar in.
      tmpDC = GetWindowDC(GradhWnd)
      DrawDC = CreateCompatibleDC(tmpDC)
      NewBMP = CreateCompatibleBitmap _
       (tmpDC, rcWnd.Right - rcWnd.Left, 50)
      OldBMP = SelectObject(DrawDC, NewBMP)
      With rcWnd
        hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        SelectClipRgn tmpDC, hRgn
        OffsetClipRgn tmpDC, -.Left, -.Top
      End With
      'Find out what color the titlebar needs
      'to be...
      If wParam And GetParent(GradhWnd) = 0 Then

        DrawGradient TranslateColor _
            (Color(eActiveStartColor)), _
            TranslateColor(Color(eActiveEndColor)), True

      ElseIf wParam = GradhWnd And GetParent _
            (GradhWnd) <> 0 Then

        DrawGradient TranslateColor _
          (Color(einActivestartcolor)),_
          TranslateColor(Color(eInactiveEndColor)), _
          False

      ElseIf SendMessage(GetParent(GradhWnd), _
          WM_MDIGETACTIVE, 0, 0) = GradhWnd Then

        DrawGradient TranslateColor(Color(eActiveStartColor)), _
           TranslateColor(Color(eActiveEndColor)), True

      Else

        DrawGradient TranslateColor(Color(einActivestartcolor)), _
            TranslateColor(Color(eInactiveEndColor)), False

      End If

      'Cleanup
      SelectObject DrawDC, OldBMP
      DeleteObject NewBMP
      DeleteDC DrawDC
      OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
      GetClipRgn tmpDC, hRgn
      ReleaseDC GradhWnd, tmpDC
      DeleteObject hRgn
      tmpDC = 0
      GradientCallback = 1
      Exit Function

    Case WM_NCPAINT

      'Debug.Print "NCPAINT"

      'Basically same as above.
      GetWindowRect GradhWnd, rcWnd
      tmpDC = GetWindowDC(GradhWnd)
      DrawDC = CreateCompatibleDC(tmpDC)
      NewBMP = CreateCompatibleBitmap _
        (tmpDC, rcWnd.Right - rcWnd.Left, 50)
      OldBMP = SelectObject(DrawDC, NewBMP)
      With rcWnd
        hRgn = CreateRectRgn _
          (.Left, .Top, .Right, .Bottom)
        SelectClipRgn tmpDC, hRgn
        OffsetClipRgn tmpDC, -.Left, -.Top
      End With
      'Get the color to paint the caption with.
      If GetActiveWindow() = GradhWnd Then
        DrawGradient TranslateColor _
          (Color(eActiveStartColor)), _
          TranslateColor(Color(eActiveEndColor)), True
      ElseIf SendMessage(GetParent(GradhWnd), _
        WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
        DrawGradient TranslateColor(Color(eActiveStartColor)), _
          TranslateColor(Color(eActiveEndColor)), True
      Else
        DrawGradient TranslateColor _
          (Color(einActivestartcolor)), _
          TranslateColor(Color(eInactiveEndColor)), False
      End If

      'Cleanup
      SelectObject DrawDC, OldBMP
      DeleteObject NewBMP
      DeleteDC DrawDC
      OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
      GetClipRgn tmpDC, hRgn

      'Call the old proc. This will only
      'draw the titlebar's min/max/close buttons
      'because we told it not to do the rest (this
      'eliminates flicker.)
      GradientCallback = CallOldWindowProc(hwnd, _
        WM_NCPAINT, hRgn, lParam)
      ReleaseDC GradhWnd, tmpDC
      DeleteObject hRgn
      tmpDC = 0
      Exit Function

    Case WM_SIZE, WM_STYLECHANGED, WM_SETTEXT
      'Whoa, we need to paint the caption.
      If hwnd = GradhWnd Then SendMessage GradhWnd, _
        WM_NCPAINT, 0, 0
  End Select

End Function

Public Sub RefreshTitleBar()
  If GradhWnd <> 0 Then SendMessage GradhWnd, _
  WM_NCPAINT, 0, 0
End Sub

Public Sub GradientForm(frm As Object)

  If (m_bInSubClass) Then
    GradientReleaseForm
  End If

  GradhWnd = frm.hwnd
  GradIcon = frm.Icon

  If (TypeOf frm Is MDIForm) Then
    m_bMDI = True
  End If

  AttachMessage Me, GradhWnd, WM_NCPAINT
  AttachMessage Me, GradhWnd, WM_NCACTIVATE
  AttachMessage Me, GradhWnd, WM_MDIACTIVATE
  ' Check for change in form caption:
  AttachMessage Me, GradhWnd, WM_STYLECHANGED
  AttachMessage Me, GradhWnd, WM_SETTEXT

  m_bInSubClass = True

  GradientGetCapsFont

End Sub

Public Sub GradientReleaseForm()

 If (m_bInSubClass) Then
   DetachMessage Me, GradhWnd, WM_NCPAINT
   DetachMessage Me, GradhWnd, WM_NCACTIVATE
   DetachMessage Me, GradhWnd, WM_MDIACTIVATE
   DetachMessage Me, GradhWnd, WM_STYLECHANGED
   DetachMessage Me, GradhWnd, WM_SETTEXT
   GradhWnd = 0
 End If

End Sub

Private Function DrawGradient( _
  ByVal Color1 As Long, _
  ByVal Color2 As Long, _
  ByVal bActive As Boolean _
  ) As Long

  Dim i As Integer
  Dim DestWidth As Long, DestHeight As Long
  Dim StartPnt As Integer, EndPnt As Integer
  Dim PixelStep As Long, XBorder As Long
  Dim WndRect As RECT
  Dim OldFont As Long
  Dim fText As String
  Dim iBmTop As Long
  Dim lS As Long
  Dim lBtnWidth As Long
  Dim bDoDefault As Boolean
  Dim bShowBitmap As Boolean

  On Error Resume Next

  GetWindowRect GradhWnd, WndRect
  With WndRect
  DestWidth = .Right - .Left
  End With

  bShowBitmap = ((m_lHdc <> 0) And _
   (DestWidth > (m_lBitmapW * 4)))

  'Get height of caption bar
  lS = GetWindowLong(GradhWnd, GWL_EXSTYLE)_
  If ((lS And WS_EX_TOOLWINDOW) = 
   WS_EX_TOOLWINDOW) Then
    DestHeight = GetSystemMetrics(SM_CYSMCAPTION)
  Else
    DestHeight = GetSystemMetrics(SM_CYCAPTION)
  End If

  'Get the text of the form's caption
  fText = Space$(255)
  GetWindowText GradhWnd, fText, 255
  fText = Trim$(fText)

  'Get the width of the border
  XBorder = GetSystemMetrics(SM_CXFRAME)

  'The width of the area we need to paint:
  DestWidth = DestWidth - (XBorder * 2) + 6
  lS = GetWindowLong(GradhWnd, GWL_STYLE)
  If ((lS And WS_MINIMIZEBOX) = WS_MINIMIZEBOX) _
    Or ((lS And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX) Then
    lBtnWidth = lBtnWidth + (GetSystemMetrics _
    (SM_CXSMSIZE)) * 2
  End If
  If ((lS And WS_SYSMENU) = WS_SYSMENU) Then
    lBtnWidth = lBtnWidth + (GetSystemMetrics(SM_CXSMSIZE))
  End If
  If (lBtnWidth <> 0) Then lBtnWidth = lBtnWidth + 1
  DestWidth = DestWidth - lBtnWidth

  'Where the painting begins:
  StartPnt = XBorder
  'Where the painting ends:
  EndPnt = XBorder + DestWidth - 4

  'How many steps do we need to
  'paint the titlebar?
  If (bShowBitmap) Then
    PixelStep = DestWidth - 16 - m_lBitmapW
  Else
    PixelStep = DestWidth \ 8
  End If

  ReDim Colors(PixelStep) As Long
  'Create gradient colors in the array
  GradateColors Colors(), Color1, Color2

  Dim rct As RECT
  Dim hBr As Long

  With rct
    .Top = XBorder
    .Left = XBorder
    .Right = XBorder + (DestWidth \ PixelStep)
    .Bottom = XBorder + DestHeight - 1
    bDoDefault = True
    If (m_bCustomDraw) Then
      RaiseEvent CustomDraw(eDrawBackground, _
            bDoDefault, DrawDC, _
            XBorder, XBorder, EndPnt - XBorder, _
            DestHeight - 1, bActive)
    End If

    If (bDoDefault) Then

      If (bShowBitmap) Then
        ' the first box is going to extend 
        ' all the way from
        ' the icon to the end of the bitmap, 
        ' and the gradient
        ' is only doing to start afterwards:
        rct.Right = rct.Left + 16 + m_lBitmapW
      End If
      hBr = CreateSolidBrush(Colors(0))
      FillRect DrawDC, rct, hBr
      DeleteObject hBr
      If (bShowBitmap) Then
        rct.Left = rct.Right
        rct.Right = rct.Left + (DestWidth \ PixelStep)
      End If
      For i = 1 To PixelStep - 1
        'Paint the titlebar in increments, increasing
        'the color index with each iteration.
        hBr = CreateSolidBrush(Colors(i))
        FillRect DrawDC, rct, hBr
        'Cleanup
        DeleteObject hBr
        'Prepare for the next iteration
        OffsetRect rct, (DestWidth \ PixelStep), 0
        If i = PixelStep - 2 Then .Right = EndPnt
      Next

    End If

    bDoDefault = True
    If (m_bCustomDraw) Then
      RaiseEvent CustomDraw(eDrawIcon, bDoDefault, DrawDC, _
        XBorder, XBorder, EndPnt - XBorder, DestHeight - 1, _
        bActive)
    End If
    If (bDoDefault) Then
      If GradIcon <> 0 Then 'Paint the icon

        'Move the caption text's start point over

        'to make room for the icon

        .Left = XBorder + GetSystemMetrics(SM_CXSMSIZE) + 2

        DrawIconEx DrawDC, XBorder + 1, XBorder + 1, GradIcon, _
          GetSystemMetrics(SM_CXSMSIZE) - 2, _
          GetSystemMetrics(SM_CYSMSIZE) _
          - 2, ByVal 0&, ByVal 0&, DI_NORMAL

      Else

        'No icon

        .Left = XBorder

      End If
    End If

    'If we have a picture:
    If (bShowBitmap) Then
      ' Draw it and shift left & right
      iBmTop = 2 + .Top + ((.Bottom - .Top - m_lBitmapH) \ 2)
      BitBlt DrawDC, .Left, iBmTop, m_lBitmapW, m_lBitmapH, _
        m_lHdc, 0, 0, SRCCOPY
      .Left = .Left + m_lBitmapW + 2
    Else
      .Left = .Left + 2
    End If

    bDoDefault = True
    If (m_bCustomDraw) Then
      RaiseEvent CustomDraw(eDrawText, bDoDefault, DrawDC, XBorder, _
        XBorder, EndPnt - XBorder - 10, DestHeight - 1, bActive)
    End If
    If (bDoDefault) Then

      'If getting the caption font failed, use the font
      'from the gradient caption form.
      If CaptionFont.lfHeight = 0 And tmpGradFont = 0 Then
        tmpGradFont = SendMessage(GradhWnd, WM_GETFONT, 0, 0)
      ElseIf tmpGradFont = 0 Then
        tmpGradFont = CreateFontIndirect(CaptionFont)
      End If
      OldFont = SelectObject(DrawDC, tmpGradFont)
      'This is like setting FontTransparent on a Form to True:
      SetBkMode DrawDC, 1
      'Use a white caption, since the background is black
      'on the left side
      If (bActive) Then

        SetTextColor DrawDC, TranslateColor(m_oColor(eActiveText))
        '&HFFFFFF
        'RGB(255, 255, 255)
      Else

        SetTextColor DrawDC, TranslateColor(m_oColor(eInActiveText)) 
        '&HC0C0C0
        'RGB(128, 128, 128)
      End If
      .Right = .Right - 10
      'Draw the caption text
      If (m_bTextTransparent) Then
        SetBkMode DrawDC, TRANSPARENT
      Else
        SetBkMode DrawDC, OPAQUE
        If (bActive) Then
          SetBkColor DrawDC, TranslateColor _
          (m_oColor(eActiveStartColor))
        Else
          SetBkColor DrawDC, TranslateColor _
          (m_oColor(einActivestartcolor))
        End If
      End If
      DrawText DrawDC, fText, Len(fText) - 1, _
          rct, DT_SINGLELINE Or _ DT_END_ELLIPSIS _
          Or DT_VCENTER
      'Cleanup
      SelectObject DrawDC, OldFont
      DeleteObject tmpGradFont
      tmpGradFont = 0
    End If

    .Left = XBorder
    .Right = .Right + 12
    If tmpDC <> 0 Then
      'Blit our work from the memory DC to the form's
      'window DC to finish the job.
      BitBlt tmpDC, .Left, .Top, .Right - .Left - 10, _
        .Bottom - .Top, _ DrawDC, .Left, .Top, vbSrcCopy
      'Tell windows that we already painted most of
      'the titlebar.
      ExcludeClipRect tmpDC, XBorder, XBorder, .Right - _
        .Left - 7, .Bottom - .Top + 4

    End If

  End With

End Function

Private Sub GradateColors(Colors() As Long, _
  ByVal Color1 As Long, ByVal Color2 As Long)

  'Alright, I admit -- this routine was
  'taken from a VBPJ issue a few months back.

  Dim i As Integer
  Dim dblR As Double, dblG As Double, dblB As Double
  Dim addR As Double, addG As Double, addB As Double
  Dim bckR As Double, bckG As Double, bckB As Double

  dblR = CDbl(Color1 And &HFF)
  dblG = CDbl(Color1 And &HFF00&) / 255
  dblB = CDbl(Color1 And &HFF0000) / &HFF00&
  bckR = CDbl(Color2 And &HFF&)
  bckG = CDbl(Color2 And &HFF00&) / 255
  bckB = CDbl(Color2 And &HFF0000) / &HFF00&

  addR = (bckR - dblR) / UBound(Colors)
  addG = (bckG - dblG) / UBound(Colors)
  addB = (bckB - dblB) / UBound(Colors)

  For i = 0 To UBound(Colors)
  dblR = dblR + addR
  dblG = dblG + addG
  dblB = dblB + addB
  If dblR > 255 Then dblR = 255
  If dblG > 255 Then dblG = 255
  If dblB > 255 Then dblB = 255
  If dblR < 0 Then dblR = 0
  If dblG < 0 Then dblG = 0
  If dblG < 0 Then dblB = 0
  Colors(i) = RGB(dblR, dblG, dblB)
  Next

End Sub

Private Sub GradientGetCapsFont()

  'Tries to retrieve the Windows caption font
  'in the current Appearance scheme. Doesn't
  'seem to work all the time, so if anyone knows
  'why I'd appreciate being told.

  Dim NCM As NONCLIENTMETRICS
  Dim lfNew As LOGFONT

  NCM.cbSize = Len(NCM)
  Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, _
    0, NCM, 0)

  If NCM.iCaptionHeight = 0 Then
    CaptionFont.lfHeight = 0
  Else
    CaptionFont = NCM.lfCaptionFont
  End If

End Sub
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 Sub Class_Initialize()
  m_bCustomDraw = True
  m_bTextTransparent = True
  m_oColor(eActiveStartColor) = 0
  m_oColor(einActivestartcolor) = 0
  m_oColor(eActiveEndColor) = vbActiveTitleBar
  m_oColor(eInactiveEndColor) = vbInactiveTitleBar
  m_oColor(eActiveText) = &HFFFFFF
  m_oColor(eInActiveText) = &HC0C0C0
End Sub

Private Sub Class_Terminate()
  GradientReleaseForm
End Sub

Private Property Let ISubclass_MsgResponse _
 (ByVal RHS As SSubTimer.EMsgResponse)
  m_emr = RHS
End Property

Private Property Get ISubclass_MsgResponse() _
  As SSubTimer.EMsgResponse
  'Debug.Print "Get MsgResponse", _
   CurrentMessage
  Select Case CurrentMessage
    Case WM_NCACTIVATE, WM_MDIACTIVATE
      'This will cause a slight flicker because we
      'let Windows paint the caption before we do.
      'We don't let this happen in the WM_NCPAINT message,
      'which is called more often than NCACTIVATE.
      m_emr = emrPreprocess

    Case WM_NCPAINT
      'Call the old proc. This will only
      'draw the titlebar's min/max/close buttons
      'because we told it not to do the rest (this
      'eliminates flicker.
      m_emr = emrConsume

    Case Else
      m_emr = emrPostProcess
  End Select

  ISubclass_MsgResponse = m_emr
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, _
  ByVal iMsg As Long, ByVal wParam As Long, _
  ByVal lParam As Long) As Long
 
  'Debug.Print "Get Msg" & vbCrLf
  ISubclass_WindowProc = GradientCallback _
  (hwnd, iMsg, wParam, lParam)
End Function

Add a new form (frmTest) and copy this code into the General Declarations procedure:

'This project was provided by VB Square in the form
'of a How-To on the web site.
'Please recognise the author's in the Class module
'For more, detailed How-To's, code and other VB stuff
'visit VB Square - www.programmerz.com/vb/
Private m_ct As New cTitleBar

Private Sub Form_Load()
  m_ct.GradientForm (Me)
End Sub





Comment and Contribute

 


(Maximum characters: 1200). You have characters left.

 

 


Sitemap | Contact Us

Rocket Fuel