vbAccelerator - Contents of code file: mDockContainer.bas

Attribute VB_Name = "mDockContainer"
Option Explicit

Public Const DOCKCONTAINERID = "vbal:DockContainer:lPtr"
Public Const DOCKCONTAINERVERTICAL = "vbal:DockContainer:Vertical"
Public Const DOCKCONTAINERBARINDEX = "vbal:DockContainer:BarIndex"
Public Const MDITOOLBARMENUID = "vbal:MDIToolbarMenu:lPtr"
Public Const DOCKCONTAINERPARENTHWND = "vbal:DockContainer:ParenthWnd"
Public Const UNDOCKEDCONTAINERID = "vbal:UndockedContainer:lPtr"

Public Const TOOLWINDOWPARENTWINDOWHWND = "vbal:ToolWindow:ParenthWnd"


Public Type POINTAPI
   x As Long
   y As Long
End Type
Public Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As
 Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd
 As Long, ByVal lpString As String) As Long

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long

Public Declare Function RedrawWindowAsNull Lib "user32" Alias "RedrawWindow"
 (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal
 fuRedraw As Long) As Long
Public Const RDW_ALLCHILDREN = &H80
Public Const RDW_ERASE = &H4
Public Const RDW_ERASENOW = &H200
Public Const RDW_FRAME = &H400
Public Const RDW_INTERNALPAINT = &H2
Public Const RDW_INVALIDATE = &H1
Public Const RDW_NOCHILDREN = &H40
Public Const RDW_NOERASE = &H20
Public Const RDW_NOFRAME = &H800
Public Const RDW_NOINTERNALPAINT = &H10
Public Const RDW_UPDATENOW = &H100
Public Const RDW_VALIDATE = &H8

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As
 Any, pSrc As Any, ByVal ByteLen As Long)

Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As
 Long, ByVal lpEnumFunc As Long, ByVal lParam 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 Const CLR_INVALID = -1

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal
 hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, lpsz2 As Any) As
 Long

Private m_hWnd() As Long
Private m_lCount As Long

Public Property Get DockTargetCount() As Long
   DockTargetCount = m_lCount
End Property
Public Property Get DockTarget(ByVal lIndex As Long) As Long
   DockTarget = m_hWnd(lIndex)
End Property

Public Property Get objectFromPtr(ByVal lPtr As Long) As Object
Dim objT As Object
   If Not (lPtr = 0) Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory objT, lPtr, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set objectFromPtr = objT
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory objT, 0&, 4
   End If
End Property

Private Function enumWindowsProc( _
        ByVal lhWnd As Long, _
        ByVal lParam As Long _
    ) As Long
Dim bStop As Boolean
   bStop = False
   If GetProp(lhWnd, DOCKCONTAINERID) <> 0 Then
      m_lCount = m_lCount + 1
      ReDim Preserve m_hWnd(1 To m_lCount) As Long
      m_hWnd(m_lCount) = lhWnd
   End If
   enumWindowsProc = 1
End Function

Public Function findDockTargets( _
      ByVal hWndParent As Long _
   ) As Boolean
   m_lCount = 0
   Erase m_hWnd
   EnumChildWindows hWndParent, AddressOf enumWindowsProc, 0
End Function

Public Function dockCheck( _
      ByVal hWndToolbarWindow As Long, _
      ByVal hWndCtl As Long, _
      ByVal bCanDockHorizontal As Boolean, _
      ByVal bCanDockVertical As Boolean, _
      ByRef hWndDockTo As Long, _
      ByRef lRowDockAt As Long, _
      ByRef lXDockAt As Long _
   ) As Boolean
Dim lhWndP As Long
Dim lhWnd As Long
Dim i As Long
Dim tP As POINTAPI
Dim tTL As POINTAPI
Dim tWR As RECT
Dim tTWR As RECT
Dim bVertical As Boolean
Dim lDiff1 As Long
Dim lDiff2 As Long
Dim bDockCheck As Boolean
Dim ctl As vbalDockContainer
Dim lPtr As Long

   ' Evaluate the owning form of these docking
   ' controls:
   lhWnd = GetParent(hWndCtl)
      
   ' Find all child windows of m_hWndCtl's parent
   ' which are dock targets:
   findDockTargets lhWnd

   ' now check if we dock onto any of them:
   'Debug.Print "DockCheck: " & m_lCount
   GetCursorPos tP
   For i = 1 To m_lCount
      GetWindowRect m_hWnd(i), tWR
      'Debug.Print i, tWR.Left, tWR.Top, tWR.Right, tWR.Bottom
      bVertical = (GetProp(m_hWnd(i), DOCKCONTAINERVERTICAL) <> 0)
      If tP.y >= tWR.Top And tP.y <= tWR.Bottom Then
         If tP.x >= tWR.Left And tP.x <= tWR.Right Then
            'Debug.Print "Dock Target:" & m_hWnd(i)
            hWndDockTo = m_hWnd(i)
            GetWindowRect hWndToolbarWindow, tTWR
            tTL.x = tTWR.Left
            tTL.y = tTWR.Top
            ScreenToClient hWndDockTo, tTL
            If bVertical Then
               If (bCanDockVertical) Then
                  bDockCheck = True
                  
                  lPtr = GetProp(m_hWnd(i), DOCKCONTAINERID)
                  If Not (lPtr = 0) Then
                     Set ctl = objectFromPtr(lPtr)
                     If (ctl.LockToolBars) Then
                        bDockCheck = False
                     End If
                  End If
                  
                  If (bDockCheck) Then
                     lDiff1 = Abs(tP.x - tWR.Left)
                     lDiff2 = Abs(tP.x - tWR.Right)
                     If lDiff1 > lDiff2 Then
                        lRowDockAt = -1
                     Else
                        lRowDockAt = 0
                     End If
                     GetCursorPos tTL
                     ScreenToClient hWndDockTo, tTL
                     lXDockAt = tTL.y
                  End If
                  
               End If
            Else
               If (bCanDockHorizontal) Then
                  bDockCheck = True
               
                  lPtr = GetProp(m_hWnd(i), DOCKCONTAINERID)
                  If Not (lPtr = 0) Then
                     Set ctl = objectFromPtr(lPtr)
                     If (ctl.LockToolBars) Then
                        bDockCheck = False
                     End If
                  End If
                  
                  If (bDockCheck) Then
                     lDiff1 = Abs(tP.y - tWR.Top)
                     lDiff2 = Abs(tP.y - tWR.Bottom)
                     If lDiff1 > lDiff2 Then
                        lRowDockAt = -1
                     Else
                        lRowDockAt = 0
                     End If
                     ' Work out where we are l-r on the window:
                     GetCursorPos tTL
                     ScreenToClient hWndDockTo, tTL
                     lXDockAt = tTL.x
                  End If
               End If
            End If
            If Not bDockCheck Then
               Screen.MousePointer = vbNoDrop
            Else
               Screen.MousePointer = vbSizeAll
            End If
            dockCheck = bDockCheck
            Exit For
         End If
      End If
   Next i
   Screen.MousePointer = vbSizeAll
   
End Function

Public Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function
Public Property Get BlendColor( _
      ByVal oColorFrom As OLE_COLOR, _
      ByVal oColorTo As OLE_COLOR, _
      Optional ByVal alpha As Long = 128 _
   ) As Long
Dim lCFrom As Long
Dim lCTo As Long
   lCFrom = TranslateColor(oColorFrom)
   lCTo = TranslateColor(oColorTo)
Dim lSrcR As Long
Dim lSrcG As Long
Dim lSrcB As Long
Dim lDstR As Long
Dim lDstG As Long
Dim lDstB As Long
   lSrcR = lCFrom And &HFF
   lSrcG = (lCFrom And &HFF00&) \ &H100&
   lSrcB = (lCFrom And &HFF0000) \ &H10000
   lDstR = lCTo And &HFF
   lDstG = (lCTo And &HFF00&) \ &H100&
   lDstB = (lCTo And &HFF0000) \ &H10000
     
   
   BlendColor = RGB( _
      ((lSrcR * alpha) / 255) + ((lDstR * (255 - alpha)) / 255), _
      ((lSrcG * alpha) / 255) + ((lDstG * (255 - alpha)) / 255), _
      ((lSrcB * alpha) / 255) + ((lDstB * (255 - alpha)) / 255) _
      )
      
End Property

Public Property Get VSNetControlColor() As Long
   VSNetControlColor = BlendColor(vbButtonFace, VSNetBackgroundColor, 195)
End Property

Public Property Get VSNetBackgroundColor() As Long
   VSNetBackgroundColor = BlendColor(vbWindowBackground, vbButtonFace, 220)
End Property
Public Property Get VSNetCheckedColor() As Long
   VSNetCheckedColor = BlendColor(vbHighlight, vbWindowBackground, 30)
End Property
Public Property Get VSNetBorderColor() As Long
   VSNetBorderColor = TranslateColor(vbHighlight)
End Property
Public Property Get VSNetSelectionColor() As Long
   VSNetSelectionColor = BlendColor(vbHighlight, vbWindowBackground, 70)
End Property
Public Property Get VSNetPressedColor() As Long
   VSNetPressedColor = BlendColor(vbHighlight, VSNetSelectionColor, 70)
End Property

Public Function mdiChildhWnd(ByVal hWndA As Long) As Long
   mdiChildhWnd = FindWindowEx(hWndA, 0, "MDIClient", ByVal 0&)
End Function