vbAccelerator - Contents of code file: frmToolbar.frm

VERSION 5.00
Begin VB.Form frmToolbar 
   BorderStyle     =   0  'None
   ClientHeight    =   855
   ClientLeft      =   5655
   ClientTop       =   2850
   ClientWidth     =   3210
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   855
   ScaleWidth      =   3210
   ShowInTaskbar   =   0   'False
End
Attribute VB_Name = "frmToolbar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Implements ISubclass

Private Const WM_ERASEBKGND = &H14
Private Const WM_DESTROY = &H2
Private Const WM_ACTIVATE = &H6

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x
 As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 bRepaint As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
 nCmdShow As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_NORMAL = 1
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd
 As Long) As Long
Private Const GW_OWNER = 4
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long,
 ByVal hWndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal
 hWndNewParent 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 Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y 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 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 GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
 As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y 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 UnionRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect
 As RECT, lpSrc2Rect As RECT) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT,
 ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Const BDR_RAISED = &H5
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = 2
Private Const BDR_SUNKENINNER = 8
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_SOFT = &H1000     ' Use for softer buttons.
Private Const BF_FLAT = &H4000          '/* For flat rather than 3D borders */
Private Const BF_MONO = &H8000&          '/* For monochrome borders */
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function RedrawWindowAsNull Lib "user32" Alias "RedrawWindow"
 (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal
 fuRedraw As Long) As Long
Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4
Private Const RDW_ERASENOW = &H200
Private Const RDW_FRAME = &H400
Private Const RDW_INTERNALPAINT = &H2
Private Const RDW_INVALIDATE = &H1
Private Const RDW_NOCHILDREN = &H40
Private Const RDW_NOERASE = &H20
Private Const RDW_NOFRAME = &H800
Private Const RDW_NOINTERNALPAINT = &H10
Private Const RDW_UPDATENOW = &H100
Private Const RDW_VALIDATE = &H8
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_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOREDRAW = &H8
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send
 WM_NCCALCSIZE
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const SWP_NOZORDER = &H4
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 Const DT_BOTTOM = &H8
    Private Const DT_CENTER = &H1
    Private Const DT_LEFT = &H0
    Private Const DT_CALCRECT = &H400
    Private Const DT_WORDBREAK = &H10
    Private Const DT_VCENTER = &H4
    Private Const DT_TOP = &H0
    Private Const DT_TABSTOP = &H80
    Private Const DT_SINGLELINE = &H20
    Private Const DT_RIGHT = &H2
    Private Const DT_NOCLIP = &H100
    Private Const DT_INTERNAL = &H1000
    Private Const DT_EXTERNALLEADING = &H200
    Private Const DT_EXPANDTABS = &H40
    Private Const DT_CHARSTREAM = 4
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
 nBkMode As Long) As Long
    Private Const OPAQUE = 2
    Private Const TRANSPARENT = 1
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long)
 As Long
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33
Private Const SM_CYBORDER = 6
Private Const SM_CXBORDER = 5
Private Const SM_CYCAPTION = 4
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 SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Const WM_USER = &H400
Private Const TB_BUTTONCOUNT = (WM_USER + 24)
Private Const TB_GETBUTTON = (WM_USER + 23)
Private Const TB_GETRECT = (WM_USER + 51)             '// wParam is the Cmd
 instead of index
Private Type TBBUTTON
   iBitmap As Long
   idCommand As Long
   fsState As Byte
   fsStyle As Byte
   bReserved1 As Byte
   bReserved2 As Byte
   dwData As Long
   iString As Long
End Type

Private m_hWnd As Long

Private m_bInDrag As Boolean
Private m_xOffset As Long
Private m_yOffset As Long

Private m_hWndCtl As Long
Private m_hWndMDI As Long
Private m_sKey As String
Private m_cXAHorz As Long
Private m_cYAHorz As Long
Private m_cXAVert As Long
Private m_cYAVert As Long
Private m_bFillRow As Boolean
Private m_sTitle As String
Private m_bCanDockHorizontal As Boolean
Private m_bCanDockVertical As Boolean
Private m_bCanClose As Boolean
Private m_bOfficeXpStyle As Boolean
Private m_lXpBorderWidth As Long

Private m_tTitleR As RECT
Private m_tCloseR As RECT
Private m_bCloseOver As Boolean
Private m_bCloseDown As Boolean
Private m_tChevronR As RECT
Private m_bChevronOver As Boolean
Private m_bChevronDown As Boolean

Private m_tDockInitMousePos As POINTAPI

Private WithEvents m_tmr As CTimer
Attribute m_tmr.VB_VarHelpID = -1

Private m_cNCM As pcNonClientMetrics

Friend Sub BandSizeChange( _
      ByVal cXAHorz As Long, _
      ByVal cYAHorz As Long, _
      ByVal cXAVert As Long, _
      ByVal cYAVert As Long _
   )
Dim hWndA As Long
Dim tR As RECT
   
   m_cXAHorz = cXAHorz
   m_cYAHorz = cYAHorz
   m_cXAVert = cXAVert
   m_cYAVert = cYAVert
   
   If IsNumeric(Me.Tag) Then
      hWndA = CLng(Me.Tag)
      If (m_bOfficeXpStyle) Then
         tR.Left = m_lXpBorderWidth
         tR.Top = m_lXpBorderWidth + m_cNCM.SMCaptionHeight + 1
      Else
         tR.Left = GetSystemMetrics(SM_CXFRAME) + GetSystemMetrics(SM_CXBORDER)
         tR.Top = GetSystemMetrics(SM_CYFRAME) + GetSystemMetrics(SM_CYBORDER)
          + m_cNCM.SMCaptionHeight
      End If
      SetWindowPos hWndA, 0, _
         tR.Left, _
         tR.Top, _
         m_cXAHorz, m_cYAHorz, _
         SWP_FRAMECHANGED Or SWP_NOACTIVATE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
   End If
   
   If (m_bOfficeXpStyle) Then
      Me.Move Me.Left, Me.Top, _
         (m_cXAHorz + m_lXpBorderWidth * 2) * Screen.TwipsPerPixelX, _
         (m_cYAHorz + m_lXpBorderWidth * 2 + m_cNCM.SMCaptionHeight + 1) *
          Screen.TwipsPerPixelY
   Else
      Me.Move Me.Left, Me.Top, _
         (m_cXAHorz + (GetSystemMetrics(SM_CXBORDER) +
          GetSystemMetrics(SM_CXFRAME)) * 2) * Screen.TwipsPerPixelX, _
         (m_cYAHorz + (GetSystemMetrics(SM_CYBORDER) +
          GetSystemMetrics(SM_CYFRAME)) * 2 + m_cNCM.SMCaptionHeight) *
          Screen.TwipsPerPixelY
   End If
      
      
End Sub

Friend Property Get DockedhWnd() As Long
   If IsNumeric(Me.Tag) Then
      DockedhWnd = CLng(Me.Tag)
   End If
End Property

Private Sub OnChevronPress()
Dim lPtr As Long
Dim ctl As vbalDockContainer
Dim tP As POINTAPI
Dim hBr As Long
   
   lPtr = GetProp(m_hWndCtl, DOCKCONTAINERID)
   If Not lPtr = 0 Then
      '
      Set ctl = objectFromPtr(lPtr)
      tP.x = m_tChevronR.Left
      tP.y = m_tChevronR.Bottom
      MapWindowPoints Me.hwnd, 0, tP, 1
      
      ctl.OnChevronPress m_sKey, tP.x, tP.y
      
      m_bChevronDown = False
      m_bChevronOver = False
      If (m_bOfficeXpStyle) Then
         hBr = GetSysColorBrush(vb3DShadow And &H1F&)
      Else
         hBr = GetSysColorBrush(vbActiveTitleBar And &H1F&)
      End If
      drawChevronButton Me.hdc, hBr
      DeleteObject hBr
      
   End If
End Sub

Private Sub OnCloseClick()
Dim lPtr As Long
Dim ctl As vbalDockContainer
Dim hWndA As Long
   
   lPtr = GetProp(m_hWndCtl, DOCKCONTAINERID)
   If Not lPtr = 0 Then
      Set ctl = objectFromPtr(lPtr)
      If (ctl.OnCloseClick(m_sKey)) Then
         If IsNumeric(Me.Tag) Then
            hWndA = CLng(Me.Tag)
            ShowWindow hWndA, SW_HIDE
            SetParent hWndA, m_hWndMDI
         End If
         Unload Me
      End If
   End If
End Sub
Friend Sub getDetails( _
      ByRef sKey As String, _
      ByRef cXAHorz As Long, _
      ByRef cYAHorz As Long, _
      ByRef cXAVert As Long, _
      ByRef cYAVert As Long, _
      ByRef bFillRow As Boolean, _
      ByRef sTitle As String, _
      ByRef bCanDockHorizontal As Boolean, _
      ByRef bCanDockVertical As Boolean, _
      ByRef bCanClose As Boolean, _
      ByRef x As Long, _
      ByRef y As Long, _
      ByRef width As Long, _
      ByRef height As Long _
   )
   sKey = m_sKey
   cXAHorz = m_cXAHorz
   cYAHorz = m_cYAHorz
   cXAVert = m_cXAVert
   cYAVert = m_cYAVert
   bFillRow = m_bFillRow
   sTitle = m_sTitle
   bCanDockHorizontal = m_bCanDockHorizontal
   bCanDockVertical = m_bCanDockVertical
   bCanClose = m_bCanClose
   x = Me.Left \ Screen.TwipsPerPixelX
   y = Me.Top \ Screen.TwipsPerPixelY
   width = Me.width \ Screen.TwipsPerPixelX
   height = Me.height \ Screen.TwipsPerPixelY
End Sub

Friend Function init( _
      ByVal sKey As String, _
      ByVal hwnd As Long, _
      ByVal hWndMDI As Long, _
      ByVal cXAHorz As Long, _
      ByVal cYAHorz As Long, _
      ByVal cXAVert As Long, _
      ByVal cYAVert As Long, _
      ByVal bFillRow As Boolean, _
      ByVal sTitle As String, _
      ByVal bCanDockHorizontal As Boolean, _
      ByVal bCanDockVertical As Boolean, _
      ByVal bCanClose As Boolean, _
      ByVal bOfficeXpStyle As Boolean, _
      Optional ByVal bRestoringLayout = False _
   )
   m_bOfficeXpStyle = bOfficeXpStyle
   m_sKey = sKey
   m_hWndCtl = hwnd
   m_hWndMDI = hWndMDI
   m_cXAHorz = cXAHorz - 22
   m_cYAHorz = cYAHorz - 2
   m_cXAVert = cXAVert - 22
   m_cYAVert = cYAVert - 2
   m_bFillRow = bFillRow
   m_sTitle = sTitle
   m_bCanDockHorizontal = bCanDockHorizontal
   m_bCanDockVertical = bCanDockVertical
   m_bCanClose = bCanClose
   
   If Not (bRestoringLayout) Then
      mouseDown vbLeftButton, 0, 1, 1
      GetCursorPos m_tDockInitMousePos
      Me.MousePointer = vbSizeAll
   End If
   
End Function
Private Sub toolbarResize(ByVal hWndA As Long)
Dim lPtr As Long
   lPtr = GetProp(hWndA, "vbalTbar:ControlPtr")
   If Not (lPtr = 0) Then
      Dim ctl As Object
      Set ctl = objectFromPtr(lPtr)
      ctl.ResizeToolbar
   End If
End Sub

Friend Sub Capture( _
      ByVal hWndA As Long _
   )
Dim tR As RECT
   Debug.Print "Capture", hWndA
   If hWndA <> 0 Then
      AttachMessage Me, m_hWnd, WM_ERASEBKGND
      AttachMessage Me, m_hWnd, WM_DESTROY
      toolbarResize hWndA
      SetParent hWndA, Me.hwnd
      ShowWindow hWndA, SW_NORMAL
      If (m_bOfficeXpStyle) Then
         tR.Left = m_lXpBorderWidth
         tR.Top = m_lXpBorderWidth + m_cNCM.SMCaptionHeight + 1
      Else
         tR.Left = GetSystemMetrics(SM_CXFRAME) + GetSystemMetrics(SM_CXBORDER)
         tR.Top = GetSystemMetrics(SM_CYFRAME) + GetSystemMetrics(SM_CYBORDER)
          + m_cNCM.SMCaptionHeight
      End If
      SetWindowPos hWndA, 0, _
         tR.Left, _
         tR.Top, _
         m_cXAHorz, m_cYAHorz, _
         SWP_FRAMECHANGED Or SWP_NOACTIVATE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
   End If
   Me.Tag = hWndA
   If (m_bOfficeXpStyle) Then
      Me.Move Me.Left, Me.Top, _
         (m_cXAHorz + m_lXpBorderWidth * 2) * Screen.TwipsPerPixelX, _
         (m_cYAHorz + m_lXpBorderWidth * 2 + m_cNCM.SMCaptionHeight + 1) *
          Screen.TwipsPerPixelY
   Else
      Me.Move Me.Left, Me.Top, _
         (m_cXAHorz + (GetSystemMetrics(SM_CXBORDER) +
          GetSystemMetrics(SM_CXFRAME)) * 2) * Screen.TwipsPerPixelX, _
         (m_cYAHorz + (GetSystemMetrics(SM_CYBORDER) +
          GetSystemMetrics(SM_CYFRAME)) * 2 + m_cNCM.SMCaptionHeight) *
          Screen.TwipsPerPixelY
   End If
   Me.MousePointer = vbSizeAll
   
End Sub
Private Sub dblClick()
Dim tP As POINTAPI
   GetCursorPos tP
   ScreenToClient Me.hwnd, tP
   If PtInRect(m_tTitleR, tP.x, tP.y) Then
      performDock m_hWndCtl, -1, 0, False
   End If
End Sub
Friend Sub performDock( _
      ByVal hWndTo As Long, _
      ByVal lRowDockAt As Long, _
      ByVal lXDockAt As Long, _
      ByVal bContinueMouseCapture As Boolean _
   )
Dim lPtr As Long
Dim lPtrWasDockedTo As Long
Dim ctl As vbalDockContainer
Dim ctlWasDocked As vbalDockContainer
Dim hWndA As Long
Dim hWndParent As Long
   
   lPtr = GetProp(hWndTo, DOCKCONTAINERID)
   If Not lPtr = 0 Then
      '
      
      m_bInDrag = False
      
      If Not (m_hWndCtl = 0) Then
         If Not (IsWindow(m_hWndCtl) = 0) Then
            lPtrWasDockedTo = GetProp(m_hWndCtl, DOCKCONTAINERID)
            If Not (lPtrWasDockedTo = 0) Then
               Set ctlWasDocked = objectFromPtr(lPtrWasDockedTo)
               ctlWasDocked.RemoveUndocked m_sKey
            End If
         End If
      End If
      
      Set ctl = objectFromPtr(lPtr)
      Debug.Print "lXDockAt=", lXDockAt
      ctl.Add _
         m_sKey, _
         m_cXAHorz, m_cYAHorz, m_cXAVert, m_cYAVert, _
         m_sTitle, _
         lRowDockAt, lXDockAt, , m_bFillRow, _
         m_bCanDockHorizontal, m_bCanDockVertical, _
         m_bCanClose
      If bContinueMouseCapture Then
         ctl.fJustDocked m_sKey
      End If
      If IsNumeric(Me.Tag) Then
         hWndA = Me.Tag
         Debug.Print m_sKey, hWndA
         ctl.Capture m_sKey, hWndA
      End If
      If Not (m_hWnd = 0) Then
         DetachMessage Me, m_hWnd, WM_ERASEBKGND
         DetachMessage Me, m_hWnd, WM_DESTROY
         m_hWnd = 0
      End If
      
      Screen.MousePointer = vbDefault
      Unload Me
   Else
      Debug.Assert "Can't find container" = ""
   End If

End Sub

Private Function mouseDown( _
      ByVal Button As Integer, _
      ByVal Shift As Integer, _
      ByVal x As Single, _
      ByVal y As Single _
   ) As Boolean
Dim tP As POINTAPI
Dim xB As Long
Dim yB As Long
Dim hBr As Long
   If (Button = vbLeftButton) Then
      If (m_bOfficeXpStyle) Then
         hBr = GetSysColorBrush(vb3DShadow And &H1F&)
      Else
         hBr = GetSysColorBrush(vbActiveTitleBar And &H1F&)
      End If
      xB = x \ Screen.TwipsPerPixelX
      yB = y \ Screen.TwipsPerPixelY
      If Not (PtInRect(m_tCloseR, xB, yB) = 0) Then
         m_bCloseOver = True
         m_bCloseDown = True
         drawCloseButton Me.hdc, hBr
         If (m_bChevronOver) Then
            drawChevronButton Me.hdc, hBr
            m_bChevronOver = False
            m_bChevronDown = False
         End If
      ElseIf Not (PtInRect(m_tChevronR, xB, yB) = 0) Then
         m_bChevronOver = True
         m_bChevronDown = True
         drawChevronButton Me.hdc, hBr
         If (m_bCloseOver) Then
            drawCloseButton Me.hdc, hBr
            m_bCloseOver = False
            m_bCloseDown = False
         End If
         OnChevronPress
      Else
         GetCursorPos tP
         tP.x = tP.x * Screen.TwipsPerPixelX
         tP.y = tP.y * Screen.TwipsPerPixelY
         m_xOffset = Me.Left - tP.x
         m_yOffset = Me.Top - tP.y
         m_bInDrag = True
         mouseDown = True
         Me.MousePointer = vbSizeAll
      End If
      DeleteObject hBr
   Else
   End If
End Function

Private Sub mouseMove( _
      ByVal Button As Integer, _
      ByVal Shift As Integer, _
      ByVal x As Single, _
      ByVal y As Single _
   )
Dim tP As POINTAPI
Dim tPC As POINTAPI
Dim hWndDockTo As Long
Dim lRowDockAt As Long
Dim lXDockAt As Long
Dim hBrTitle As Long

   If m_bInDrag Then
      
      ' Move to position:
      GetCursorPos tP
      tP.x = tP.x * Screen.TwipsPerPixelX
      tP.y = tP.y * Screen.TwipsPerPixelY
      Me.Move tP.x + m_xOffset, tP.y + m_yOffset
      
      ' Check for docking:
      GetCursorPos tPC
      If Abs(tPC.x - m_tDockInitMousePos.x) > 8 Or Abs(tPC.y -
       m_tDockInitMousePos.y) > 8 Then
         m_tDockInitMousePos.x = -20000
         m_tDockInitMousePos.y = -20000
         If dockCheck(Me.hwnd, m_hWndCtl, m_bCanDockHorizontal,
          m_bCanDockVertical, hWndDockTo, lRowDockAt, lXDockAt) Then
            performDock hWndDockTo, lRowDockAt, lXDockAt, True
         End If
      End If
   
      If (Button = 0) Then
         m_bInDrag = False
      End If
   
   Else
      If (Button = 0) Then
         If (m_bOfficeXpStyle) Then
            hBrTitle = GetSysColorBrush(vb3DShadow And &H1F&)
         Else
            hBrTitle = GetSysColorBrush(vbActiveTitleBar And &H1F&)
         End If
         x = x \ Screen.TwipsPerPixelX
         y = y \ Screen.TwipsPerPixelY
         If Not (PtInRect(m_tCloseR, x, y) = 0) Then
            If Not m_bCloseOver Then
               m_bCloseOver = True
               drawCloseButton Me.hdc, hBrTitle
            End If
            If m_bChevronOver Then
               m_bChevronOver = False
               drawChevronButton Me.hdc, hBrTitle
            End If
         ElseIf Not (PtInRect(m_tChevronR, x, y) = 0) Then
            If Not m_bChevronOver Then
               m_bChevronOver = True
               drawChevronButton Me.hdc, hBrTitle
            End If
            If m_bCloseOver Then
               m_bCloseOver = False
               drawCloseButton Me.hdc, hBrTitle
            End If
         Else
            If m_bCloseOver Then
               m_bCloseOver = False
               drawCloseButton Me.hdc, hBrTitle
            End If
            If m_bChevronOver Then
               m_bChevronOver = False
               drawChevronButton Me.hdc, hBrTitle
            End If
         End If
         DeleteObject hBrTitle
      End If
   End If
   
End Sub

Private Sub Form_DblClick()
   dblClick
End Sub

Private Sub Form_Initialize()
   m_lXpBorderWidth = 3
   Set m_cNCM = New pcNonClientMetrics
   m_cNCM.GetMetrics
End Sub

Private Sub Form_Load()
   m_hWnd = Me.hwnd
   SetProp m_hWnd, UNDOCKEDCONTAINERID, ObjPtr(Me)
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   '
   If mouseDown(Button, Shift, x, y) Then
      mouseMove Button, Shift, x, y
   End If
   '
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   '
   mouseMove Button, Shift, x, y
   '
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As
 Single)
   '
   If (Button = vbLeftButton) Then
      Dim xB As Long
      Dim yB As Long
      Dim hBrTitle As Long
      xB = x \ Screen.TwipsPerPixelX
      yB = y \ Screen.TwipsPerPixelY
      If (m_bOfficeXpStyle) Then
         hBrTitle = GetSysColorBrush(vb3DShadow And &H1F&)
      Else
         hBrTitle = GetSysColorBrush(vbActiveTitleBar And &H1F&)
      End If
      If (m_bChevronDown) Then
         ' nothing to do
      ElseIf (m_bCloseDown) Then
         If Not (PtInRect(m_tCloseR, xB, yB) = 0) Then
            ' Close clicked:
            OnCloseClick
         End If
      Else
         mouseMove Button, Shift, x, y
      End If
      Me.MousePointer = vbDefault
      Screen.MousePointer = vbDefault
      m_bInDrag = False
      DeleteObject hBrTitle
   Else
   End If
   '
End Sub

Private Sub Form_Paint()
Dim tR As RECT
Dim tTR As RECT
Dim hPen As Long
Dim hPenOld As Long
Dim lHDC As Long
Dim hBr As Long
Dim hBrTitle As Long
Dim hFontOld As Long
Dim tJunk As POINTAPI
   '
   GetClientRect Me.hwnd, tR
   lHDC = Me.hdc
   
   hBr = GetSysColorBrush(vbButtonFace And &H1F&)
   FillRect lHDC, tR, hBr
   DeleteObject hBr
   
   ' Draw the title:
   LSet tTR = tR
   If (m_bOfficeXpStyle) Then
      tTR.Left = tTR.Left + m_lXpBorderWidth
      tTR.Right = tTR.Right - m_lXpBorderWidth
      tTR.Top = tTR.Top + m_lXpBorderWidth
   Else
      tTR.Left = tTR.Left + GetSystemMetrics(SM_CXBORDER) +
       GetSystemMetrics(SM_CXFRAME)
      tTR.Right = tTR.Right - (GetSystemMetrics(SM_CXBORDER) +
       GetSystemMetrics(SM_CXFRAME))
      tTR.Top = tTR.Top + GetSystemMetrics(SM_CYBORDER) +
       GetSystemMetrics(SM_CYFRAME)
   End If
   tTR.Bottom = tTR.Top + m_cNCM.SMCaptionHeight
   
   LSet m_tTitleR = tTR
   If (m_bOfficeXpStyle) Then
      hBrTitle = GetSysColorBrush(vb3DShadow And &H1F&)
   Else
      hBrTitle = GetSysColorBrush(vbActiveTitleBar And &H1F&)
   End If
   FillRect lHDC, tTR, hBrTitle
   DeleteObject hBr
   
   If Len(m_sTitle) > 0 Then
      LSet tTR = m_tTitleR
      InflateRect tTR, -1, -1
      SetBkMode lHDC, TRANSPARENT
      If active() Then
         SetTextColor lHDC, TranslateColor(vbWindowText)
      Else
         SetTextColor lHDC, TranslateColor(vbWindowText)
      End If
      hFontOld = SelectObject(lHDC, m_cNCM.FontHandle(SMCaptionFont))
      DrawText lHDC, m_sTitle, -1, tTR, DT_LEFT Or DT_SINGLELINE
      SelectObject lHDC, hFontOld
   End If
   
   LSet m_tChevronR = tTR
   m_tChevronR.Right = m_tChevronR.Right - 1
   m_tChevronR.Left = m_tChevronR.Right - (m_tChevronR.Bottom - m_tChevronR.Top)
   
   ' Close button:
   If (m_bCanClose) Then
      LSet m_tCloseR = m_tChevronR
      OffsetRect m_tChevronR, -(m_tChevronR.Bottom - m_tChevronR.Top + 1), 0
      drawCloseButton lHDC, hBrTitle
   End If
   
   ' Chevron button:
   drawChevronButton lHDC, hBrTitle
   DeleteObject hBrTitle
   
   ' Draw the border:
   If (m_bOfficeXpStyle) Then
      hPen = CreatePen(PS_SOLID, 1, GetSysColor(vb3DShadow And &H1F&))
      hPenOld = SelectObject(lHDC, hPen)
      MoveToEx lHDC, tR.Left, tR.Bottom - 1, tJunk
      LineTo lHDC, tR.Left, tR.Top
      LineTo lHDC, tR.Right - 1, tR.Top
      LineTo lHDC, tR.Right - 1, tR.Bottom - 1
      LineTo lHDC, tR.Left, tR.Bottom - 1
      SelectObject lHDC, hPenOld
      DeleteObject hPen
   Else
      DrawEdge lHDC, tR, EDGE_RAISED, BF_RECT Or BF_SOFT
   End If
   
   '
End Sub

Private Sub drawCloseButton(ByVal lHDC As Long, ByVal hBrTitle As Long)
Dim lX As Long
Dim lY As Long
Dim hBr As Long
Dim hPen As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI

   If (m_bOfficeXpStyle) Then
      If (m_bCloseOver) Then
         If (m_bCloseDown) Then
            hBr = CreateSolidBrush(VSNetPressedColor)
         Else
            hBr = CreateSolidBrush(VSNetSelectionColor)
         End If
         FillRect lHDC, m_tCloseR, hBr
         DeleteObject hBr
         
         hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbHighlight And &H1F&))
         hPenOld = SelectObject(lHDC, hPen)
         MoveToEx lHDC, m_tCloseR.Left, m_tCloseR.Bottom - 1, tJunk
         LineTo lHDC, m_tCloseR.Left, m_tCloseR.Top
         LineTo lHDC, m_tCloseR.Right - 1, m_tCloseR.Top
         LineTo lHDC, m_tCloseR.Right - 1, m_tCloseR.Bottom - 1
         LineTo lHDC, m_tCloseR.Left, m_tCloseR.Bottom - 1
         SelectObject lHDC, hPenOld
         DeleteObject hPen
         
      Else
         FillRect lHDC, m_tCloseR, hBrTitle
      End If
   Else
      FillRect lHDC, m_tCloseR, hBrTitle
      If (m_bCloseOver) Then
         If (m_bCloseDown) Then
            DrawEdge lHDC, m_tCloseR, BDR_SUNKENOUTER, BF_RECT
         Else
            DrawEdge lHDC, m_tCloseR, BDR_RAISEDINNER, BF_RECT
         End If
      End If
   End If
   
   ' Draw Close glyph:
   hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbMenuText And &H1F&))
   hPenOld = SelectObject(lHDC, hPen)
   lX = m_tCloseR.Left + (m_tCloseR.Right - m_tCloseR.Left - 8) / 2
   lY = m_tCloseR.Top + (m_tCloseR.Bottom - m_tCloseR.Top - 7) / 2
   MoveToEx lHDC, lX, lY, tJunk
   LineTo lHDC, lX + 6, lY + 6
   MoveToEx lHDC, lX + 1, lY, tJunk
   LineTo lHDC, lX + 7, lY + 6
   
   MoveToEx lHDC, lX + 5, lY, tJunk
   LineTo lHDC, lX - 1, lY + 6
   MoveToEx lHDC, lX + 6, lY, tJunk
   LineTo lHDC, lX, lY + 6
   
   SelectObject lHDC, hPenOld
   DeleteObject hPen

End Sub

Private Sub drawChevronButton(ByVal lHDC As Long, ByVal hBrTitle As Long)
Dim lX As Long
Dim lY As Long
Dim hBr As Long
Dim hPen As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI

   If (m_bOfficeXpStyle) Then
      If (m_bChevronOver) Then
         If (m_bChevronDown) Then
            hBr = CreateSolidBrush(VSNetControlColor)
         Else
            hBr = CreateSolidBrush(VSNetSelectionColor)
         End If
         FillRect lHDC, m_tChevronR, hBr
         DeleteObject hBr
         If (m_bChevronDown) Then
            hPen = CreatePen(PS_SOLID, 1, GetSysColor(vb3DDKShadow And &H1F&))
            hPenOld = SelectObject(lHDC, hPen)
            MoveToEx lHDC, m_tChevronR.Left, m_tChevronR.Bottom - 1, tJunk
            LineTo lHDC, m_tChevronR.Left, m_tChevronR.Top
            LineTo lHDC, m_tChevronR.Right - 1, m_tChevronR.Top
            LineTo lHDC, m_tChevronR.Right - 1, m_tChevronR.Bottom
            SelectObject lHDC, hPenOld
            DeleteObject hPen
         Else
            hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbHighlight And &H1F&))
            hPenOld = SelectObject(lHDC, hPen)
            MoveToEx lHDC, m_tChevronR.Left, m_tChevronR.Bottom - 1, tJunk
            LineTo lHDC, m_tChevronR.Left, m_tChevronR.Top
            LineTo lHDC, m_tChevronR.Right - 1, m_tChevronR.Top
            LineTo lHDC, m_tChevronR.Right - 1, m_tChevronR.Bottom - 1
            LineTo lHDC, m_tChevronR.Left, m_tChevronR.Bottom - 1
            SelectObject lHDC, hPenOld
            DeleteObject hPen
         End If
      Else
         FillRect lHDC, m_tChevronR, hBrTitle
      End If
   Else
      FillRect lHDC, m_tChevronR, hBrTitle
      If (m_bChevronOver) Then
         If (m_bChevronDown) Then
            DrawEdge lHDC, m_tChevronR, BDR_SUNKENOUTER, BF_RECT
         Else
            DrawEdge lHDC, m_tChevronR, BDR_RAISEDINNER, BF_RECT
         End If
      End If
   End If
   
   ' Draw chevron glyph:
   hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbMenuText And &H1F&))
   hPenOld = SelectObject(lHDC, hPen)
   lX = m_tChevronR.Left + (m_tChevronR.Right - m_tChevronR.Left - 5) / 2
   lY = m_tChevronR.Top + (m_tChevronR.Bottom - m_tChevronR.Top - 3) / 2
   MoveToEx lHDC, lX, lY, tJunk
   LineTo lHDC, lX + 5, lY
   MoveToEx lHDC, lX + 1, lY + 1, tJunk
   LineTo lHDC, lX + 4, lY + 1
   MoveToEx lHDC, lX + 2, lY, tJunk
   LineTo lHDC, lX + 2, lY + 3
   SelectObject lHDC, hPenOld
   DeleteObject hPen

End Sub

Private Function active() As Boolean
   active = True
End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   RemoveProp m_hWnd, UNDOCKEDCONTAINERID
   If Not (m_hWnd = 0) Then
      DetachMessage Me, m_hWnd, WM_ERASEBKGND
      DetachMessage Me, m_hWnd, WM_DESTROY
      m_hWnd = 0
   End If
   Set m_cNCM = Nothing
      
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   '
   Select Case CurrentMessage
   Case WM_ERASEBKGND
      ISubclass_MsgResponse = emrConsume
   Case WM_DESTROY
      ISubclass_MsgResponse = emrPreprocess
   End Select
   '
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
   '
Dim hBr As Long
Dim lhWnd As Long
Dim lBtns As Long
Dim iBtn As Long
Dim tB As TBBUTTON
Dim tR As RECT
Dim tP As POINTAPI
Dim lIndex As Long

   Select Case iMsg
   Case WM_ERASEBKGND
      lhWnd = GetWindow(hwnd, GW_CHILD)
      If lhWnd <> 0 Then
         hBr = CreateSolidBrush(TranslateColor(Me.BackColor))
         GetClientRect lhWnd, tR
         MapWindowPoints lhWnd, hwnd, tR, 2
         FillRect wParam, tR, hBr
         DeleteObject hBr
      End If
      ISubclass_WindowProc = 1
      
   Case WM_DESTROY
      If m_hWnd <> 0 Then
         DetachMessage Me, m_hWnd, WM_ERASEBKGND
         DetachMessage Me, m_hWnd, WM_DESTROY
         m_hWnd = 0
      End If
   End Select
   '
End Function