Cool Flat/3D Button *MUST SEE*

				
'**************************************
' Name: Cool Flat/3D Button *MUST SEE*
' Description:Do you also think, that the normal CommandButton is a bit ugly?
Here is a Button of the next generation...check it out!
' By: Henning Tillmann
'
' Inputs:T O D O:
New Project -> ActiveX Control
Add a Label ("lblCaption") and a Timer ("tmrHighlight").
That's it!
'
' Assumes:T O D O:
New Project -> ActiveX Control
Add a Label ("lblCaption") and a Timer ("tmrHighlight").
That's it!
'
' Side Effects:Caption cannot contain a LineBreak
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=7268&lngWId=1'for details.'**************************************

Option Explicit
' T O D O:
' ********
' New Project -> ActiveX Control
' Add a Label ("lblCaption")
' and a Timer ("tmrHighlight").
' That's it!
' Private Variables/Types/Enumerations/Constants
' **********************************************
Private Enum htWhatToApply
apyDrawBorder = 1
apyBackColor = 2
apyCaption = 4
apyEnabled = 8
apyFont = 16
apyAll = (apyBackColor Or apyCaption Or apyEnabled Or apyFont)
End Enum
Dim mbHasCapture As Boolean
Dim mpntLabelPos As POINTAPI
Dim mpntOldSize As POINTAPI
' API Declarations/Types/Constants
' ********************************
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
RightAs Long
BottomAs Long
End Type
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENINNER = &H8
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_MOUSEOVER = BDR_RAISEDINNER
Private Const BDR_MOUSEDOWN = BDR_SUNKENOUTER
Private Const BF_BOTTOM = &H8
Private Const BF_FLAT = &H4000
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Declare Function apiDrawEdge Lib "user32" _
 Alias "DrawEdge" _
(ByVal hdc As Long, _
 ByRef qrc As RECT, _
 ByVal edge As Long, _
 ByVal grfFlags As Long) As Long
 
Private Declare Function apiGetCursorPos Lib "user32" _
 Alias "GetCursorPos" _
(lpPoint As POINTAPI) As Long
 
Private Declare Function apiWindowFromPoint Lib "user32" _
 Alias "WindowFromPoint" _
(ByVal xPoint As Long, _
 ByVal yPoint As Long) As Long
 
Private Declare Function apiDrawFocusRect Lib "user32" _
 Alias "DrawFocusRect" _
(ByVal hdc As Long, _
 lpRect As RECT) As Long
 
' Properies (Variables/Constants)
' *******************************
Private mProp_AlwaysHighlighted As Boolean
Private mProp_BackColor As OLE_COLOR
Private mProp_CaptionAs String
Private mProp_EnabledAs Boolean
Private mProp_FocusRect As Boolean
Private mProp_FontAs StdFont
Private mProp_HoverColor As OLE_COLOR
Const mDef_AlwaysHighlighted = False
Const mDef_BackColor = vbButtonFace
Const mDef_Caption = "Button2K"
Const mDef_Enabled = True
Const mDef_FocusRect = True
Const mDef_Font = Null ' Ambient.Font
Const mDef_HoverColor = vbHighlight
' Public Enumerations
' *******************
Public Enum b2kClickReason
b2kReasonMouse
b2kReasonAccessKey
b2kReasonKeyboard
End Enum
' Events
' ******
Event Click(ByVal ClickReason As b2kClickReason)
Private Sub tmrHighlight_Timer()
Dim pntCursor As POINTAPI
apiGetCursorPos pntCursor
If apiWindowFromPoint(pntCursor.X, pntCursor.Y) = hWnd Then
 If Not mbHasCapture Then
 Call ApplyProperties(apyDrawBorder)
 lblCaption.ForeColor = mProp_HoverColor
 mbHasCapture = True
 End If
Else
 If mbHasCapture Then
 Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), mProp_BackColor, B
 lblCaption.ForeColor = vbButtonText
 mbHasCapture = False
 End If
End If
End Sub
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
RaiseEvent Click(b2kReasonAccessKey)
End Sub
Private Sub UserControl_Click()
RaiseEvent Click(b2kReasonMouse)
End Sub
Private Sub UserControl_EnterFocus()
Dim rctFocus As RECT
If Not mProp_FocusRect Then Exit Sub
rctFocus.Left = 3
rctFocus.Top = 3
rctFocus.Right = ScaleWidth - 3
rctFocus.Bottom = ScaleHeight - 3
apiDrawFocusRect hdc, rctFocus
Refresh
End Sub
Private Sub UserControl_ExitFocus()
If mProp_FocusRect Then Line (3, 3)-(ScaleWidth - 4, ScaleHeight - 4), mProp_BackColor, B
End Sub
Private Sub UserControl_Initialize()
AutoRedraw = True
ScaleMode = vbPixels
lblCaption.Alignment = vbCenter
lblCaption.AutoSize = True
lblCaption.BackStyle = vbTransparent
tmrHighlight.Enabled = False
tmrHighlight.Interval = 1
End Sub
Private Sub UserControl_InitProperties()
Width = 1215
Height = 375
mProp_AlwaysHighlighted = mDef_AlwaysHighlighted
mProp_BackColor = mDef_BackColor
mProp_Caption = mDef_Caption
mProp_Enabled = mDef_Enabled
mProp_FocusRect = mDef_FocusRect
Set mProp_Font = Ambient.Font
mProp_HoverColor = mDef_HoverColor
Call ApplyProperties(apyAll)
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
mProp_AlwaysHighlighted = PropBag.ReadProperty("AlwaysHighlighted", mDef_AlwaysHighlighted)
mProp_BackColor = PropBag.ReadProperty("BackColor", mDef_BackColor)
mProp_Caption = PropBag.ReadProperty("Caption", mDef_Caption)
mProp_Enabled = PropBag.ReadProperty("Enabled", mDef_Enabled)
mProp_FocusRect = PropBag.ReadProperty("FocusRect", mDef_FocusRect)
Set mProp_Font = PropBag.ReadProperty("Font", Ambient.Font)
mProp_HoverColor = PropBag.ReadProperty("HoverColor", mDef_HoverColor)
 
Call ApplyProperties(apyAll)
If Ambient.UserMode Then
 If mProp_AlwaysHighlighted Then
 Call ApplyProperties(apyDrawBorder)
 Else
 tmrHighlight = True
 End If
End If
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
 .WriteProperty "AlwaysHighlighted", mProp_AlwaysHighlighted, mDef_AlwaysHighlighted
 .WriteProperty "BackColor", mProp_BackColor, mDef_BackColor
 .WriteProperty "Caption", mProp_Caption, mDef_Caption
 .WriteProperty "Enabled", mProp_Enabled, mDef_Enabled
 .WriteProperty "FocusRect", mProp_FocusRect, mDef_FocusRect
 .WriteProperty "Font", mProp_Font, Ambient.Font
 .WriteProperty "HoverColor", mProp_HoverColor, mDef_HoverColor
End With
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then
 UserControl_MouseDown -2, -2, -2, -2
End If
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeySpace Or KeyAscii = vbKeyReturn Then
 RaiseEvent Click(b2kReasonKeyboard)
End If
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then
 UserControl_MouseUp -2, -2, -2, -2
End If
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim rctBtn As RECT
Dim dwRetVal As Long
tmrHighlight.Enabled = False
lblCaption.Left = mpntLabelPos.X + 1
lblCaption.Top = mpntLabelPos.Y + 1
Line (0, 0)-(Width, Height), mProp_BackColor, B
rctBtn.Left = 0
rctBtn.Top = 0
rctBtn.Right = ScaleWidth
rctBtn.Bottom = ScaleHeight
dwRetVal = apiDrawEdge(hdc, rctBtn, BDR_MOUSEDOWN, BF_RECT)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim pntCursor As POINTAPI
lblCaption.Left = mpntLabelPos.X
lblCaption.Top = mpntLabelPos.Y
apiGetCursorPos pntCursor
If apiWindowFromPoint(pntCursor.X, pntCursor.Y) = hWnd Or mProp_AlwaysHighlighted Then
 Call ApplyProperties(apyDrawBorder)
 mbHasCapture = True
Else
 Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), mProp_BackColor, B
 mbHasCapture = False
End If
If Not mProp_AlwaysHighlighted Then tmrHighlight.Enabled = True
End Sub
Private Sub lblCaption_Click()
RaiseEvent Click(b2kReasonMouse)
End Sub
Private Sub lblCaption_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseDown Button, Shift, -1, -1
End Sub
Private Sub lblCaption_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseUp Button, Shift, -1, -1
End Sub
Private Sub UserControl_Resize()
Dim rctBtn As RECT
Dim dwRetVal As Long
Static sbFirstTime As Boolean
If Not sbFirstTime Then
 sbFirstTime = True
Else
 Cls
End If
lblCaption.AutoSize = False
lblCaption.Top = (ScaleHeight / 2) - (lblCaption.Height / 2)
lblCaption.Left = 1
lblCaption.Width = ScaleWidth - 2
 
If Not Ambient.UserMode Or mProp_AlwaysHighlighted Then
 Call ApplyProperties(apyDrawBorder)
End If
mpntLabelPos.X = lblCaption.Left
mpntLabelPos.Y = lblCaption.Top
mpntOldSize.X = ScaleWidth
mpntOldSize.Y = ScaleHeight
End Sub
' Private Procedures
' ******************
Private Sub ApplyProperties(ByVal apyWhatToApply As htWhatToApply)
Dim rctBtn As RECT
Dim dwRetVal As Long
Dim n As Long
If (apyWhatToApply And apyBackColor) Then UserControl.BackColor = mProp_BackColor
If (apyWhatToApply And apyCaption) Then
 lblCaption.Caption = mProp_Caption
 AccessKeys = ""
 For n = Len(mProp_Caption) To 1 Step -1
 If Mid$(mProp_Caption, n, 1) = "&" Then
If n = 1 Then
AccessKeys = Mid$(mProp_Caption, n + 1, 1)
ElseIf Not Mid$(mProp_Caption, n - 1, 1) = "&" Then
AccessKeys = Mid$(mProp_Caption, n + 1, 1)
Exit For
Else
n = n - 1
End If
 End If
 Next n
End If
If (apyWhatToApply And apyFont) Then
 Set UserControl.Font = mProp_Font
 lblCaption.AutoSize = True
 Set lblCaption.Font = mProp_Font
 lblCaption.AutoSize = False
 lblCaption.Top = (ScaleHeight / 2) - (lblCaption.Height / 2)
 lblCaption.Left = 1
 lblCaption.Width = ScaleWidth - 2
End If
 
If (apyWhatToApply And apyEnabled) Then
 If Ambient.UserMode Then
 lblCaption.Enabled = mProp_Enabled
 UserControl.Enabled = mProp_Enabled
 End If
End If
 
If (apyWhatToApply And apyDrawBorder) Then
 Line (0, 0)-(Width, Height), mProp_BackColor, B
 rctBtn.Left = 0
 rctBtn.Top = 0
 rctBtn.Right = ScaleWidth
 rctBtn.Bottom = ScaleHeight
 
 dwRetVal = apiDrawEdge(hdc, rctBtn, BDR_MOUSEOVER, BF_RECT)
End If
End Sub
' Properies
' *********
Public Property Get AlwaysHighlighted() As Boolean
AlwaysHighlighted = mProp_AlwaysHighlighted
End Property
Public Property Let AlwaysHighlighted(ByVal bNewValue As Boolean)
If Ambient.UserMode Then
 Err.Raise 383
Else
 mProp_AlwaysHighlighted = bNewValue
 PropertyChanged "AlwaysHighlighted"
End If
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = mProp_BackColor
End Property
Public Property Let BackColor(ByVal oleNewValue As OLE_COLOR)
mProp_BackColor = oleNewValue
Call ApplyProperties(apyBackColor Or apyDrawBorder)
PropertyChanged "BackColor"
End Property
Public Property Get Caption() As String
Caption = mProp_Caption
End Property
Public Property Let Caption(ByVal sNewValue As String)
mProp_Caption = sNewValue
Call ApplyProperties(apyCaption)
PropertyChanged "Caption"
End Property
Public Property Get FocusRect() As Boolean
FocusRect = mProp_FocusRect
End Property
Public Property Let FocusRect(ByVal bNewValue As Boolean)
If Ambient.UserMode Then
 Err.Raise 383
Else
 mProp_FocusRect = bNewValue
 PropertyChanged "FocusRect"
End If
End Property
Public Property Get Font() As StdFont
Set Font = mProp_Font
End Property
Public Property Set Font(ByVal fntNewValue As StdFont)
Set mProp_Font = fntNewValue
Call ApplyProperties(apyFont)
PropertyChanged "Font"
End Property
Public Property Get Enabled() As Boolean
Enabled = mProp_Enabled
End Property
Public Property Let Enabled(ByVal bNewValue As Boolean)
mProp_Enabled = bNewValue
Call ApplyProperties(apyEnabled)
PropertyChanged "Enabled"
End Property
Public Property Get HoverColor() As OLE_COLOR
HoverColor = mProp_HoverColor
End Property
Public Property Let HoverColor(ByVal oleNewValue As OLE_COLOR)
mProp_HoverColor = oleNewValue
PropertyChanged "HoverColor"
End Property