by Waty Thierry (60 Submissions)
Category: Custom Controls/Forms/Menus
Compatability: Visual Basic 4.0 (32-bit)
Difficulty: Unknown Difficulty
Originally Published: Tue 30th March 1999
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Add splitter bar to your forms
VBcoders
' * Programmer Name : SP McMahon
' * Web Site : http://www.dogma.demon.co.uk/codelib/gfx/splitter.htm
' * E-Mail : [email protected]
' * Date : 07 July 1998
' * Time : 14:30
' * Module Name : class_Splitter
' * Module Filename : Splitter.cls
' **********************************************************************
' * Comments :
' * A splitter class using the Desktop window to draw a
' * splitter bar, therefore allowing splitting of MDI forms
' * as well as standard forms.
' *
' *
' **********************************************************************
Option Explicit
' *** some global declarations
Private bDraw As Boolean
Private rcCurrent As RECT
Private rcNew As RECT
Private rcWindow As RECT
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 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 SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Const R2_BLACK = 1 ' 0
Private Const R2_COPYPEN = 13 ' P
Private Const R2_LAST = 16
Private Const R2_MASKNOTPEN = 3 ' DPna
Private Const R2_MASKPEN = 9 ' DPa
Private Const R2_MASKPENNOT = 5 ' PDna
Private Const R2_MERGENOTPEN = 12 ' DPno
Private Const R2_MERGEPEN = 15 ' DPo
Private Const R2_MERGEPENNOT = 14 ' PDno
Private Const R2_NOP = 11 ' D
Private Const R2_NOT = 6 ' Dn
Private Const R2_NOTCOPYPEN = 4 ' PN
Private Const R2_NOTMASKPEN = 8 ' DPan
Private Const R2_NOTMERGEPEN = 2 ' DPon
Private Const R2_NOTXORPEN = 10 ' DPxn
Private Const R2_WHITE = 16 ' 1
Private Const R2_XORPEN = 7 ' DPx
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Sub ClipCursorRect Lib "user32" Alias "ClipCursor" (lpRect As RECT)
Private Declare Sub ClipCursorClear Lib "user32" Alias "ClipCursor" (ByVal lpRect As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
Private Const SM_CYCAPTION = 4
Private Const SM_CYMENU = 15
Public Enum eOrientationConstants
espVertical = 1
espHorizontal = 2
End Enum
Private m_hWnd As Long
Private m_eOrientation As eOrientationConstants
Private m_lBorder(1 To 4) As Long
Private m_oSplit As Object
Public Enum ESplitBorderTypes
espbLeft = 1
espbTop = 2
espbRight = 3
espbBottom = 4
End Enum
Private m_bIsMDI As Boolean
Private m_bSplitting As Boolean
Public Property Get SplitObject() As Object
Set SplitObject = m_oSplit
End Property
Public Property Let SplitObject(ByRef oThis As Object)
Set m_oSplit = oThis
On Error Resume Next
oThis.BorderStyle = 0
If (m_eOrientation = espHorizontal) Then
oThis.MousePointer = vbSizeNS
Else
oThis.MousePointer = vbSizeWE
End If
End Property
Public Property Let Border(ByVal eBorderType As ESplitBorderTypes, ByVal lSize As Long)
m_lBorder(eBorderType) = lSize
End Property
Public Property Get Border(ByVal eBorderType As ESplitBorderTypes) As Long
Border = m_lBorder(eBorderType)
End Property
Public Property Get Orientation() As eOrientationConstants
Orientation = m_eOrientation
End Property
Public Property Let Orientation(ByVal eOrientation As eOrientationConstants)
m_eOrientation = eOrientation
If Not (m_oSplit Is Nothing) Then
If (m_eOrientation = espHorizontal) Then
m_oSplit.MousePointer = vbSizeNS
m_lBorder(espbTop) = 64
m_lBorder(espbBottom) = 64
m_lBorder(espbLeft) = 0
m_lBorder(espbRight) = 0
Else
m_oSplit.MousePointer = vbSizeWE
m_lBorder(espbTop) = 0
m_lBorder(espbBottom) = 0
m_lBorder(espbLeft) = 64
m_lBorder(espbRight) = 64
End If
End If
End Property
Public Sub SplitterMouseDown(ByVal hWnd As Long, ByVal x As Long, ByVal y As Long)
Dim tP As POINTAPI
m_hWnd = hWnd
' Send subsequent mouse messages to the owner window
SetCapture m_hWnd
' Get the window rectangle on the desktop of the owner window:
GetWindowRect m_hWnd, rcWindow
' Clip the cursor so it can't move outside the window:
ClipCursorRect rcWindow
' Check if this is an MDI form:
If (ClassName(m_hWnd) = "ThunderMDIForm") Then
' Get the inside portion of the MDI form:
' I'm assuming you have a caption,menu and border in your MDI here
rcWindow.Left = rcWindow.Left + GetSystemMetrics(SM_CXBORDER)
rcWindow.Right = rcWindow.Right - GetSystemMetrics(SM_CXBORDER)
rcWindow.Bottom = rcWindow.Bottom - GetSystemMetrics(SM_CYBORDER)
rcWindow.Top = rcWindow.Top + GetSystemMetrics(SM_CYBORDER) * 3 + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYMENU)
m_bIsMDI = True
Else
' Get the client rectangle of the window in screen coordinates:
GetClientRect m_hWnd, rcWindow
tP.x = rcWindow.Left
tP.y = rcWindow.Top
ClientToScreen m_hWnd, tP
rcWindow.Left = tP.x
rcWindow.Top = tP.y
tP.x = rcWindow.Right
tP.y = rcWindow.Bottom
ClientToScreen m_hWnd, tP
rcWindow.Right = tP.x
rcWindow.Bottom = tP.y
m_bIsMDI = False
End If
bDraw = True ' *** start actual drawing from next move message
rcCurrent.Left = 0: rcCurrent.Top = 0: rcCurrent.Right = 0: rcCurrent.Bottom = 0
x = (m_oSplit.Left + x) \ Screen.TwipsPerPixelX
y = (m_oSplit.Top + y) \ Screen.TwipsPerPixelY
SplitterFormMouseMove x, y
End Sub
Public Sub SplitterFormMouseMove(ByVal x As Long, ByVal y As Long)
Dim hdc As Long
Dim tP As POINTAPI
Dim hWndClient As Long
If (bDraw) Then
' *** Draw two rectangles in the screen DC to cause splitting:
' First get the Desktop DC:
hdc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
' Set the draw mode to XOR:
SetROP2 hdc, R2_NOTXORPEN
' *** Draw over and erase the old rectangle
' (if this is the first time, all the coords will be 0 and nothing will get drawn):
Rectangle hdc, rcCurrent.Left, rcCurrent.Top, rcCurrent.Right, rcCurrent.Bottom
' It is simpler to use the mouse cursor position than try to translate
' X,Y to screen coordinates!
GetCursorPos tP
' Determine where to draw the splitter:
If (m_eOrientation = espHorizontal) Then
rcNew.Left = rcWindow.Left + m_lBorder(espbLeft)
rcNew.Right = rcWindow.Right - m_lBorder(espbRight)
If (tP.y >= rcWindow.Top + m_lBorder(espbTop)) And (tP.y < rcWindow.Bottom - m_lBorder(espbBottom)) Then
rcNew.Top = tP.y - 2
rcNew.Bottom = tP.y + 2
Else
If (tP.y < rcWindow.Top + m_lBorder(espbTop)) Then
rcNew.Top = rcWindow.Top + m_lBorder(espbTop) - 2
rcNew.Bottom = rcNew.Top + 5
Else
rcNew.Top = rcWindow.Bottom - m_lBorder(espbBottom) - 2
rcNew.Bottom = rcNew.Top + 5
End If
End If
Else
rcNew.Top = rcWindow.Top + m_lBorder(espbTop)
rcNew.Bottom = rcWindow.Bottom - m_lBorder(espbBottom)
If (tP.x >= rcWindow.Left + m_lBorder(espbLeft)) And (tP.x <= rcWindow.Right - m_lBorder(espbRight)) Then
rcNew.Left = tP.x - 2
rcNew.Right = tP.x + 2
Else
If (tP.x < rcWindow.Left + m_lBorder(espbLeft)) Then
rcNew.Left = rcWindow.Left + m_lBorder(espbLeft) - 2
rcNew.Right = rcNew.Left + 5
Else
rcNew.Left = rcWindow.Right - m_lBorder(espbRight) - 2
rcNew.Right = rcNew.Left + 5
End If
End If
End If
' *** Draw the new rectangle
Rectangle hdc, rcNew.Left, rcNew.Top, rcNew.Right, rcNew.Bottom
' Store this position so we can erase it next time:
LSet rcCurrent = rcNew
' Free the reference to the Desktop DC we got (make sure you do this!)
DeleteDC hdc
End If
End Sub
Public Function SplitterFormMouseUp(ByVal x As Long, ByVal y As Long) As Boolean
Dim hdc As Long
Dim tP As POINTAPI
Dim hWndClient As Long
' *** Don't leave orphaned rectangle on desktop; erase last rectangle.
If (bDraw) Then
bDraw = False
' Release mouse capture:
ReleaseCapture
' Release the cursor clipping region (must do this!):
ClipCursorClear 0&
' Get the Desktop DC:
hdc = CreateDCAsNull("DISPLAY", 0, 0, 0)
' Set to XOR drawing mode:
SetROP2 hdc, R2_NOTXORPEN
' Erase the last rectangle:
Rectangle hdc, rcCurrent.Left, rcCurrent.Top, rcCurrent.Right, rcCurrent.Bottom
' Clear up the desktop DC:
DeleteDC hdc
' Here we ensure the splitter is within bounds before releasing:
GetCursorPos tP
If (tP.x < rcWindow.Left + m_lBorder(espbLeft)) Then
tP.x = rcWindow.Left + m_lBorder(espbLeft)
End If
If (tP.x > rcWindow.Right - m_lBorder(espbRight)) Then
tP.x = rcWindow.Right - m_lBorder(espbRight)
End If
If (tP.y < rcWindow.Top + m_lBorder(espbTop)) Then
tP.y = rcWindow.Top + m_lBorder(espbTop)
End If
If (tP.y > rcWindow.Bottom - m_lBorder(espbBottom)) Then
tP.y = rcWindow.Bottom - m_lBorder(espbBottom)
End If
ScreenToClient m_hWnd, tP
' Move the splitter to the validated final position:
If (m_eOrientation = espHorizontal) Then
m_oSplit.Top = (tP.y - 2) * Screen.TwipsPerPixelY
Else
m_oSplit.Left = (tP.x - 2) * Screen.TwipsPerPixelX
End If
' Return true to tell the owner we have completed splitting:
SplitterFormMouseUp = True
End If
End Function
Private Sub Class_Initialize()
m_eOrientation = espVertical
m_lBorder(espbLeft) = 64
m_lBorder(espbRight) = 64
End Sub
Private Function ClassName(ByVal lHwnd As Long) As String
Dim lLen As Long
Dim sBuf As String
lLen = 260
sBuf = String$(lLen, 0)
lLen = GetClassName(lHwnd, sBuf, lLen)
If (lLen <> 0) Then
ClassName = Left$(sBuf, lLen)
End If
End Function
