CFLATHEADER.CLS

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cFlatHeader"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' ====================================================================================
' File:     cFlatHeader.cls
' Author:   SP McMahon
' Date:     15 August 1999
'
' Attach to the parent of any control containing a COMCTL32.DLL header
' control, and this routine will ensure the header paints in a flat style,
' like the header in DevStudio 6.
'
' Requires: SSUBTMR.DLL
'
' Date      Who
' 15/09/99  SPM
' First release.
'
' ------------------------------------------------------------------------------------
' vbAccelerator
' >> Advanced, free VB Source Code.
'
' http://vbaccelerator.com/
' mailto:steve@vbaccelerator.com
' ====================================================================================

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Type HD_ITEM
    mask As Long
    cxy As Long
    pszText As String
    hbm As Long
    cchTextMax As Long
    fmt As Long
    lParam As Long
    ' 4.70:
    iImage As Long
    iOrder As Long
End Type

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessageByLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc 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 GetPixel 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 Declare Function Rectangle 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 SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
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 OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ShowScrollBar Lib "user32" (ByVal hwnd As Long, ByVal wBar As Long, ByVal bShow 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 Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Const WS_EX_WINDOWEDGE = &H100
Private Const WS_EX_CLIENTEDGE = &H200
Private Const WS_EX_STATICEDGE = &H20000
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOZORDER = &H4
Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send WM_NCCALCSIZE
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const LVS_EX_FLATSB = &H100
Private Const LVM_FIRST = &H1000                   '// ListView messages
Private Const LVM_GETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 55)
Private Const LVM_SETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 54) '// optional wParam == mask
Private Const SB_BOTH = 3

Private Const WC_HEADERA = "SysHeader32"
Private Const WC_HEADER = WC_HEADERA
Private Const HDM_FIRST = &H1200                    '// Header messages
Private Const HDM_GETITEMCOUNT = (HDM_FIRST + 0)
Private Const HDM_ORDERTOINDEX = (HDM_FIRST + 15)
Private Const HDM_GETITEMA = (HDM_FIRST + 3)
Private Const HDM_GETITEM = HDM_GETITEMA

Private Const HDI_WIDTH = &H1
Private Const HDI_HEIGHT = HDI_WIDTH
Private Const HDI_TEXT = &H2
Private Const HDI_FORMAT = &H4
Private Const HDI_LPARAM = &H8
Private Const HDI_BITMAP = &H10

Private Const WM_PAINT = &HF
Private Const PS_SOLID = 0

' VB6 header in ListView is a new class:
Private Const WC_HEADER_VB6 = "msvb_lib_header"

Implements ISubclass

Private m_hWnd As Long

Public Property Get GridhWnd(ByVal hWndContainer As Long)
Dim lhWnd As Long
   lhWnd = FindWindowEx(hWndContainer, 0, "ThunderRT5UserControl", "")
   If Not lhWnd = 0 Then
      ' A little fix :)
      ShowScrollBar lhWnd, SB_BOTH, 0
      GridhWnd = lhWnd
   End If
End Property

Public Sub Attach(ByVal hWndA As Long)
Dim sClassName As String
Dim iPos As Long
Dim hWndP As Long

   Detach
   
   sClassName = String$(256, 0)
   GetClassName hWndA, sClassName, 255
   iPos = InStr(sClassName, Chr$(0))
   If Not iPos = 0 Then
      sClassName = Left$(sClassName, iPos - 1)
   End If
   If (Not sClassName = WC_HEADER) And (Not sClassName = WC_HEADER_VB6) Then
      hWndP = hWndA
      hWndA = FindWindowEx(hWndP, 0, WC_HEADER, "")
      If hWndA = 0 Then
         hWndA = FindWindowEx(hWndP, 0, WC_HEADER_VB6, "")
      End If
   End If
   If IsWindow(hWndA) Then
      m_hWnd = hWndA
      AttachMessage Me, m_hWnd, WM_PAINT
   Else
      Err.Raise 26020, App.EXEName & ".cFlatHeader", "Invalid Window Passed to cFlatHeader - no header control detected."
   End If
   
End Sub
Public Sub Detach()
   If Not m_hWnd = 0 Then
      DetachMessage Me, m_hWnd, WM_PAINT
      m_hWnd = 0
   End If
End Sub

Private Sub Class_Terminate()
   Detach
End Sub

Private Property Let ISubClass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
   '
End Property

Private Property Get ISubClass_MsgResponse() As SSubTimer.EMsgResponse
   ISubClass_MsgResponse = emrPreprocess
End Property

Private Function ISubClass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   If iMsg = WM_PAINT Then
            
      Dim tR As RECT
      Dim lC As Long
      Dim lColIndex As Long
      Dim i As Long
      Dim tHI As HD_ITEM
      Dim hdc As Long
      Dim tJunk As POINTAPI
      Dim lColor As Long
      Dim hPen As Long, hPenOld As Long
      Dim hPenFace As Long, hPenShadow As Long, hPenHighlight As Long
      Dim lX As Long, lXStart As Long
      
      GetWindowRect m_hWnd, tR
      OffsetRect tR, -tR.Left, -tR.Top
      
      hdc = GetDC(m_hWnd)
            
      lColor = GetSysColor(vb3DHighlight And &H1F&)
      hPenHighlight = CreatePen(PS_SOLID, 1, lColor)
      lColor = GetSysColor(vbButtonFace And &H1F&)
      hPenFace = CreatePen(PS_SOLID, 1, lColor)
      lColor = GetSysColor(vbButtonShadow And &H1F&)
      hPenShadow = CreatePen(PS_SOLID, 1, lColor)
            
      lC = SendMessageByLong(m_hWnd, HDM_GETITEMCOUNT, 0, 0)
      For i = 0 To lC - 1
         tHI.mask = HDI_WIDTH
         lColIndex = SendMessageByLong(m_hWnd, HDM_ORDERTOINDEX, i, 0)
         If SendMessage(m_hWnd, HDM_GETITEM, lColIndex, tHI) <> 0 Then
            lXStart = lX + 1
            lX = lX + tHI.cxy
            
            ' Draw over existing shadow with btn face:
            hPenOld = SelectObject(hdc, hPenFace)
            MoveToEx hdc, lXStart, tR.Bottom - 2, tJunk
            LineTo hdc, lX - 2, tR.Bottom - 2
            LineTo hdc, lX - 2, tR.Top
            SelectObject hdc, hPenOld
            
            ' Draw over existing black with shadow:
            If GetPixel(hdc, lXStart, tR.Top) = lColor Then
               ' Item is depressed!
               hPenOld = SelectObject(hdc, hPenHighlight)
            Else
               hPenOld = SelectObject(hdc, hPenShadow)
            End If
            MoveToEx hdc, lXStart - 1, tR.Bottom - 1, tJunk
            LineTo hdc, lX - 1, tR.Bottom - 1
            LineTo hdc, lX - 1, tR.Top - 1
            SelectObject hdc, hPenOld
            
         End If
      Next i
      
      If lX < tR.Right Then
         ' Draw over existing shadow with btn face:
         hPenOld = SelectObject(hdc, hPenFace)
         MoveToEx hdc, lX + 1, tR.Bottom - 2, tJunk
         LineTo hdc, tR.Right, tR.Bottom - 2
         SelectObject hdc, hPenOld
      End If
      
      ' Clear up objects:
      DeleteObject hPenFace
      DeleteObject hPenShadow
      DeleteObject hPenHighlight
      
      ReleaseDC m_hWnd, hdc
      
   End If

End Function

' Helper function for Control border
Public Property Let ThinBorder(ByVal hWndA As Long, ByVal bState As Boolean)
Dim lStyle As Long
   ' ListView should have Appearance set to flat and Border set to none for this to work:
   lStyle = GetWindowLong(hWndA, GWL_EXSTYLE)
   If bState Then
      lStyle = lStyle And Not WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE
   Else
      lStyle = lStyle Or WS_EX_CLIENTEDGE And Not WS_EX_STATICEDGE
   End If
   SetWindowLong hWndA, GWL_EXSTYLE, lStyle
   SetWindowPos hWndA, 0, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOZORDER Or SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE
End Property

' Helper function for VB5 ListView = flat scroll bars:
Public Property Let LVFlatScrollBars(ByVal hWndA As Long, ByVal bValue As Boolean)
Dim lStyle As Long
   lStyle = SendMessageByLong(hWndA, LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0)
   If bValue Then
      lStyle = lStyle Or LVS_EX_FLATSB
   Else
      lStyle = lStyle And Not LVS_EX_FLATSB
   End If
   SendMessageByLong hWndA, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, lStyle

End Property