|
|
|
 |
Since Microsoft introduced the flat button with Internet Explorer 4 and Office
97, this button has become a frequent member of all good GUIs. I was very disappointed
when I realised that this new control wasn't available in VB6. I was
expecting VB6 to include all the new controls (splitters, flat buttons, floating
toolbars...). Therefore all VB developers had 3 options: buy a flat button from
a third-party company, get a free flat button from the net or try to implement
this control themselves. In this article I'm going to describe all necessary steps
to implement a flat button with VB, only with a difference:
The solution is NOT going to use the API SetCapture
|
 |
About this page
Step-by-step, this article describes how to build a flat button
using the API TrackMouseEvent rather than typical API
SetCapture.
Downloads
Requires SmartSubclass
|
|
Well, let's describe step by step how we can create a usercontrol that behaves
as a flat button. From VB open a new ActiveX project and save it as MyFlatButton.ctl.
Events "MouseDown" and "MouseUp" will help us to draw the
edge sunken or raised when the user mouse-clicks the usercontrol. When the MouseDown
event is fired we will draw a sunken edge. When the MouseUp event is fired we
will draw a raised edge. This is when we should take the first decision: do we
draw the edge directly from the mouse event? or should we call the Paint event
instead? Is there a difference? The answer is yes, there's a big difference! Always
try to have as little code as you can in procedures that are message consumers.
The more code we add to the MouseDown message the slower our application will
process mouse events. It is a better approach to put all drawing code in the Paint
event and let the MouseDown and MouseUp events flow faster.
Let's see this with more detail. If we were drawing the button edge directly from
the MouseDown event we would code something like:
Private Sub UserControl_MouseDown(Button
As Integer, Shift As Integer,
X As Single, Y As Single)
If Button = vbLeftButton Then
Call pDrawEdgeSunken
End If
End Sub
Where pDrawEdgeRaised would be a procedure that draws the usercontrol
edge with a sunken style. On the other hand, if we just call the Paint event our
code would be:
Private Sub UserControl_MouseDown(Button
As Integer, Shift As Integer,
X As Single, Y As Single)
If Button = vbLeftButton Then
m_MouseDown = True
Call UserControl_Paint
End If
End Sub
Where m_MouseDown is a boolean flag we've created to let the rest of the code
know when the mouse is down. The UserControl_Paint event will have all necessary
drawing code. What's the difference? well, the first version is calling procedure
pDrawEdgeSunken and therefore the MouseDown event will not finish until pDrawEdgeSunken
does. On the other hand, the second version calls UserControl_Paint and doesn't
wait for this procedure to finish (Paint is an event procedure). It just posts
a message WM_PAINT to itself and quits. This second version is more efficient
and would not convert the MouseDown procedure in a potential "bottle-neck".
Using this second approach we are now going to create the first version of our
flat button. You can paste the following code into your usercontrol:
Option Explicit
Public Event Click()
Private m_MouseDown As Boolean
Private m_MouseOver As Boolean
Private m_ClientRec As RECT
'API declarations:
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENOUTER = &H2
Private Const BF_RECT = &HF
Private Declare Function DrawEdge
Lib "user32" ( _
ByVal hdc As Long, _
qrc As RECT, _
ByVal edge As Long, _
ByVal grfFlags As Long) As
Long
Private Declare Function GetWindowRect Lib "user32"
( _
ByVal hwnd As Long, _
lpRect As RECT) As
Long
Private Sub UserControl_MouseDown(Button As Integer,
Shift As Integer, X As Single,
Y As Single)
If Button = vbLeftButton Then
m_MouseDown = True
Call UserControl_Paint
End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer,
Shift As Integer, X As Single,
Y As Single)
If Not m_MouseOver Then
m_MouseOver = True
UserControl_Paint
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer,
Shift As Integer, X As Single,
Y As Single)
If Button = vbLeftButton Then
m_MouseDown = False
UserControl_Paint
RaiseEvent Click
End If
End Sub
Private Sub
UserControl_Resize()
GetWindowRect UserControl.hwnd, m_ClientRec
'Transform from screen to client coordinates
With m_ClientRec
.Right =
.Right - .Left
.Bottom = .Bottom - .Top
.Left =
0
.Top = 0
End With
UserControl_Paint
End Sub
Private Sub UserControl_Paint()
Dim lEdge As
Long
If Not UserControl.Ambient.UserMode Then
m_MouseOver = True
End If
UserControl.Cls
lEdge = 0
If m_MouseOver Then
If m_MouseDown Then
lEdge
= BDR_SUNKENOUTER
Else
lEdge
= BDR_RAISEDINNER
End If
DrawEdge UserControl.hdc,
m_ClientRec, lEdge, BF_RECT
End If
'
'Add your code here to draw the picture and caption...
'
End Sub
Let's review this code before we test it. As you can see, MouseUp and MouseDown
only check whether the right mouse button has been pressed and they both set the
flag m_MouseDown to either True or False depending on the event. MouseMove only
takes care of flag m_MouseOver and all three events call Paint to force a re-painting
of the object. Resize is responsible for getting the size of the client area -
using the API GetWindowRect - and also forces a re-paint. Finally the Paint event
clears the usercontrol and draws the appropriate edge based on the values of m_MouseOver
and m_MouseDown. Easy, isn't it?
We can now test the usercontrol. If we do so, we can see that the control first
shows flat. Then, as soon as the mouse enters its client area, the control shows
raised. We can now start clicking the button and the edge turns sunken when we
down-click and it turns back to raised when the mouse is released.
Good, it seems to work! There are only two remaining problems:
1. The edge doesn't show flat when the mouse leaves the
button.
2. The push-pop effect seems to be wrong if we mouse-click
quickly.
In the next section I'm going to discuss how these two problems can be solved.
The first question that arises is: how can we know when the mouse leaves the button?
In March 1997 Microsoft published the source code of a flat button implemented
with Visual Basic. The project was called Visual
Basic Soft Button Sample. Since then, many soft buttons have appeared on the
net and I would say all share the same technique: they use APIS SetCapture
and ReleaseCapture in order to detect when the mouse leaves the button.
How does this solution work and what sort of problems does it have? Basically
the solution presented by Microsoft is based on capturing the mouse when the mouse
gets into the button client area. Using SetCapture, it holds the mouse until detects
that it has moved outside of the button to then release it. Sounds logical? I
think it is a very good approach. So what's the problem then? Well, I would say
the implementation of this solution has mainly two problems:
1. SetCapture only allows one window to be holding the mouse.
2. MouseMove event will have to release and capture the mouse every time this
event is fired.
We'll better understand this if we have a code sample. If we were using SetCapture
and ReleaseCapture we would have to modify the MouseMove event with the following
code:
Private Sub UserControl_MouseMove(Button
As Integer, Shift As Integer,
X As Single, Y As Single)
ReleaseCapture
If X >= 0 And
_
Y >= 0 And _
X <= UserControl.ScaleWidth And
_
Y <= UserControl.ScaleHeight Then
SetCapture UserControl.hwnd
m_MouseOver = True
UserControl_Paint
End If
End Sub
After calling the SetCapture API, all mouse messages, no matter where the mouse
is, are posted to our window. It would be more logical if we just call SetCapture
the first time we detect the mouse has entered the button area and call ReleaseCapture
only once too, as soon as we detect that the mouse has left the button. We can't!
Why? because only one window can hold the mouse by calling SetCapture. If an external
application/code calls SetCapture while the mouse is over the button, we would
lose its messages and we would never know when to call ReleaseCapture and draw
the edge flat again. Therefore, the solution is based on releasing and capturing
the mouse every time the user moves the mouse over the button. Not very efficient
and still containing potential problems...
There's a better way to detect when the mouse leaves the button: using API TrackMouseEvent
and WM_MOUSELEAVE message. TrackMouseEvent can be used to ask the system to track
the mouse for us and post a WM_MOUSELEAVE message as soon as the mouse leaves
our window area. It is a cleaner and more efficient approach but, how can we detect
the WM_MOUSELEAVE message? We're going to use the SmartSubclass
library to trap all messages posted to the usercontrol. You will have to add
a reference to SmartSubclass.dll, as described in the article, and you'll be able
to create a SmartSubclass variable. You'll find another example on how to use
this class in Trap the Mouse!
Add the following code to the usercontrol:
Private WithEvents m_Sniff As
SmartSubClass
Private Type TrackMouseEvent
cbSize As Long
dwFlags As Long
hwnd As Long
dwHoverTime As Long
End Type
Private Const WM_MOUSELEAVE = &H2A3
Private Const TME_LEAVE = &H2
Private Declare Function TrackMouseEvent
Lib "comctl32.dll" Alias "_TrackMouseEvent" ( _
ByRef lpEventTrack As TrackMouseEvent)
As Long
Private Sub UserControl_Initialize()
Set m_Sniff = New
SmartSubClass
m_Sniff.SubClassHwnd UserControl.hwnd, True
End Sub
Private Sub UserControl_Terminate()
m_Sniff.SubClassHwnd UserControl.hwnd, False
End Sub
Private Sub UserControl_MouseMove(Button As Integer,
Shift As Integer, X As Single,
Y As Single)
Dim tTrackMouseEvent As
TrackMouseEvent
If Not m_MouseOver Then
With tTrackMouseEvent
.cbSize
= Len(tTrackMouseEvent)
.dwFlags
= TME_LEAVE
.hwnd
= UserControl.hwnd
End With
TrackMouseEvent tTrackMouseEvent
m_MouseOver = True
UserControl_Paint
End If
End Sub
Private Sub m_Sniff_NewMessage(
_
ByVal hwnd As Long, _
uMsg As Long, _
wParam As Long, _
lParam As Long, _
Cancel As Boolean)
Select Case uMsg
Case WM_MOUSELEAVE
m_MouseOver
= False
UserControl_Paint
End Select
End Sub
If you add the code to your usercontrol and you test it again, you will see that
the button turns flat again as soon as the mouse leaves its client area. We've
had to call TrackMouseEvent just once and when our 'sniffer' gets the WM_MOUSELEAVE
message, it sets the m_MouseOver flag to False and forces a control re-painting.
I honestly prefer TrackMouseEvent to SetCapture, basically because we don't get
conflicts with other windows, we rely on the system to track the mouse position
and we don't need to over-charge the MouseMove event.
Now let's go back to our usercontrol. If you remember there's still a remaining
problem: The "push-pop" effect seems to be wrong if we click the button
fast. I describe this problem with more details in Trap
the mouse!. I will only tell you that this problem is due to receiving DblClick
rather than MouseDown. To fix the problem we need to get rid of the DblClick event
and get MouseDown instead.
Add the following code to the usercontrol:
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private
Sub m_Sniff_NewMessage( _
ByVal hwnd As Long, _
uMsg As Long, _
wParam As Long, _
lParam As Long, _
Cancel As Boolean)
Select Case uMsg
Case WM_MOUSELEAVE
m_MouseOver
= False
UserControl_Paint
Case WM_LBUTTONDBLCLK
uMsg =
WM_LBUTTONDOWN
End Select
End Sub
You can now click the flat button as fast as you want.
You will always get the right "push-pop" effect. We've used our "sniffer"
to get the WM_LBUTTONDBLCLK message and replaced it with a WM_LBUTTONDOWN. It
couldn't be easier!
The flat button has now a very solid structure. We can only add enhancements
to it. In the next section I will describe how we can make the flat button post
click events when we hold the mouse down-clicked.
When you hold the mouse down-clicked on the button you will get only one MouseDown
message. You need to release the mouse and down-click again in order to receive
the next MouseDown message. This could be a problem if we would like to use
our flat button on the implementation of let's say a viewport control. The user
may want to scroll the viewport area by holding the mouse down on the flat button.
Makes sense. So how can we do that if Windows sends only one message? We will
need to do it ourselves!
We need a timer. Actually we need two timers! We could use the Timer control
that comes with Visual Basic, but we're going to use API calls. Why? because
it is a good way of learning Windows core functions!
Once the user down-clicks the button we need a timer to control when to start
posting Click events and we need another timer to control the frequency of this
posting. Windows provides two very good timer functions, SetTimer
and KillTimer,
and a timer message WM_TIMER.
In order to implement the repeated click you should add the following code:
Private Const m_TimerDelay = 1
Private Const m_TimerLapse = 2
Private Const m_RepeatDelay = 250
Private Const m_RepeatLapse = 125
Private Const WM_TIMER = &H113
Private Declare Function SetTimer
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As
Long
Private Declare Function KillTimer Lib "user32"
( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As
Long
Private Sub m_Sniff_NewMessage(ByVal
hwnd As Long, uMsg As Long,
wParam As Long, lParam As Long,
Cancel As Boolean)
Select Case uMsg
Case WM_MOUSELEAVE
m_MouseOver
= False
UserControl_Paint
Case WM_LBUTTONDBLCLK
uMsg
= WM_LBUTTONDOWN
Case WM_TIMER
Select
Case wParam
Case
m_TimerDelay
KillTimer
UserControl.hwnd, m_TimerDelay
If
m_MouseDown Then
SetTimer
UserControl.hwnd, m_TimerLapse, m_RepeatLapse, 0
End
If
Case
m_TimerLapse
If
m_MouseDown Then
RaiseEvent
Click
End
If
End
Select
End Select
End Sub
Private Sub UserControl_MouseDown(Button As
Integer, Shift As Integer, X As
Single, Y As Single)
If Button = vbLeftButton Then
m_MouseDown = True
UserControl_Paint
If m_RepeatDelay
> 0 Then
SetTimer
UserControl.hwnd, m_TimerDelay, m_RepeatDelay, 0
End If
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer,
Shift As Integer, X As Single,
Y As Single)
If Button = vbLeftButton Then
m_MouseDown = False
KillTimer UserControl.hwnd,
m_TimerDelay
KillTimer UserControl.hwnd,
m_TimerLapse
UserControl_Paint
RaiseEvent Click
End If
End Sub
Now the flat button starts waiting m_RepeatDelay milliseconds once the user
down-clicks. After this time it will start posting Click events every m_RepeatLapse
milliseconds.
Let's review the solution: we've modified MouseDown to program the first timer
(m_TimerDelay). When the "sniffer" gets a WM_TIMER message it checks
for its timer ID. If it is the first timer, the delay lapse has expired and
it programs the second timer (m_TimerLapse). It also kills the first timer.
Otherwise, if the WM_TIMER message belongs to the second timer, it posts a Click
event (the user is holding the mouse down). Finally, the MouseUp event only
has to kill both timers.
Well, that's it! Now you have a flat button working that only needs extra properties
like Caption, Font, Picture, ForeColor... I will leave it up to you to implement
the enhancements.
You can also download the SmartButton.ocx. I would
say is a good implementation of a flat button that you can freely use in your
applications.
|
|
SmartButton.ocx