VB icon

Cool Flat/3D Button *MUST SEE*

Email
Submitted on: 1/6/2015 1:08:00 AM
By: Henning Tillmann (from psc cd)  
Level: Intermediate
User Rating: By 22 Users
Compatibility: VB 5.0, VB 6.0
Views: 4546
 
     Do you also think, that the normal CommandButton is a bit ugly? Here is a Button of the next generation...check it out!

 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
'**************************************
' 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 (from psc cd)
'
' 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
'**************************************

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


Other 2 submission(s) by this author

 


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Intermediate category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.