Quick Search for:  in language:    
also,think,normal,CommandButton,uglyHere,next
   Code/Articles » |  Newest/Best » |  Community » |  Jobs » |  Other » |  Goto » | 
CategoriesSearch Newest CodeCoding ContestCode of the DayAsk A ProJobsUpload
Visual Basic Stats

 Code: 3,014,970. lines
 Jobs: 119. postings

 How to support the site

 
Sponsored by:

 

You are in:

 
Login



Latest Code Ticker for Visual Basic.
Unroll2 - Update
By Cyber Chris on 7/2


MultilinePWD
By Cyber Chris on 7/2


Click here to see a screenshot of this code!Song/Poem Assistant
By Peter Rowan on 7/2

(Screen Shot)

Click here to see a screenshot of this code!GPA Cal
By KBM-00 on 7/2

(Screen Shot)

Click here to see a screenshot of this code!Connection Via the Telephone line.No internet or cable.Just the telephone line
By Nass ClickMan on 7/2

(Screen Shot)

DBTool
By Make Strömberg on 7/2


Click here to see a screenshot of this code!MSChart Simple Example
By Sebastian Pereira on 7/2

(Screen Shot)

CString v1.5
By Ultimatum on 7/2


Tablature Pro
By Michael McMullen on 7/2


Click here to put this ticker on your site!


Add this ticker to your desktop!


Daily Code Email
To join the 'Code of the Day' Mailing List click here!





Affiliate Sites



 
 
   

Cool Flat/3D Button *MUST SEE*

Print
Email
 

Submitted on: 4/14/2000 9:11:47 AM
By: Henning Tillmann  
Level: Intermediate
User Rating: By 22 Users
Compatibility:VB 5.0, VB 6.0

Users have accessed this code 11715 times.
 
 
     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!
 
Terms of Agreement:   
By using this code, you agree to the following terms...   
1) You may use this code in your own programs (and may compile it into a program and distribute it in compiled format for languages that allow it) freely and with no charge.   
2) You MAY NOT redistribute this code (for example to a web site) without written permission from the original author. Failure to do so is a violation of copyright laws.   
3) You may link to this code from another website, but ONLY if it is not wrapped in a frame. 
4) You will abide by any additional copyright restrictions which the author may have placed in the code or code's description.

'**************************************
' Name: Cool Flat/3D Button *MUST SEE*
' Description:Do you also think, that th
'     e 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://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.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/C
'     onstants
' **************************************
'     ********

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 6 submission(s) by this author

 

 
Report Bad Submission
Use this form to notify us if this entry should be deleted (i.e contains no code, is a virus, etc.).
Reason:
 
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
4/14/2000 12:38:49 PM:Mau The Man !!!
Cool Button!
I used to envy Delphi 
because of its Speed Button, now I got 
my flat button too!! hehehe
I rated it 
excellent
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
4/14/2000 5:24:14 PM:Jess
Good...but somewhat difficult to 
understand.
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
4/15/2000 1:57:40 AM:Amritanshu Gupta
Man it looks coooolll.....
I'll rate 
it xcellent
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
4/15/2000 2:30:18 AM:villain
Excellent! No bugs in the code or 
anything - worked on first try - 
amazing...         Thank you!
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
4/15/2000 2:25:39 PM:magik
excellent code, but for those 
begginers, i think that this code would 
be a lot easier to understand and use 
if it was in a ZIP file along with an 
example or two... heh, if i have time 
maybe i'll submit one to PSC
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
4/15/2000 6:38:14 PM:Nacho
Hey, this is excellent
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
4/15/2000 6:39:39 PM:Nacho
Hey, this is excellent I've looking for 
something like dis for a long time 
Thanx ... really thanx It makes 
programs look professional. I rated it 
excellent.
Hope u win :)
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
5/11/2000 4:27:42 PM:Dave
Hi, pretty cool button man. It looks 
much better than the standard eye-sore 
Command button for VB. Only problem I 
had with it was the fact that the 
button would click down whether you 
left or right clicked it. To fix that I 
just went into the code: Private Sub 
lblCaption_MouseDown(Button As Integer, 
Shift As Integer, X As Single, Y As 
Single)UserControl_MouseDown Button, 
Shift, -1, -1End Suband added 
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
5/13/2000 8:55:10 AM:Jeffrey
Hi,
Difficult to understand, maby 
you could make a zip with the code !
I 
rate it excellent ! 
Jeffrey
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
5/17/2000 1:33:14 AM:Roma
THANX A LOT!!! This thing is really 
great!
I've rated it Excellent!
Keep 
up the good work! :)
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
5/23/2000 5:27:36 PM:Daniel Maresca Jr.
Excellent code man. Now I dont got to 
use the original boring 3d 
button.
Great job.
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
8/28/2001 4:49:43 PM:markman
Great code. One thing you might also 
want to do is make it so it looks like 
it is .alwayshighlighted=true, then 
when you have mouseover, it turns to a 
normal command button, then on click, 
the button would be flat again and 
clicked, then when released it would 
become 3d again, then when the mouse 
leaves it becomes flat again but still 
alwayshighlighted=true. Kind of like 
corel office. I hope you understand 
that.
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
9/24/2001 8:40:08 AM:Patrick_R
Great Code...But...I really don't like 
the idea of using a timer to control 
the hightlighting.  On machines running 
lots of operations, I wouldn't want to 
tie up even the smallest amount of CPU 
usage for a hover button.  Beyond that 
(not that it is really even a problem 
for most people)...this is great 
code..very well written
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
11/1/2001 4:03:27 PM:markman
How do you get it to fire the click 
event when you hit Alt+ the letter with 
an 
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
11/1/2001 4:05:17 PM:markman
Sorry. Apparently the AND symbol cuts 
off comments. Anyways:
How do you get 
it to fire the click event when you hit 
Alt+ the the underlined letter in the 
Label?
Keep the Planet clean! If this comment was disrespectful, please report it:
Reason:

 
Add Your Feedback!
Note:Not only will your feedback be posted, but an email will be sent to the code's author in your name.

NOTICE: The author of this code has been kind enough to share it with you.  If you have a criticism, please state it politely or it will be deleted.

For feedback not related to this particular code, please click here.
 
Name:
Comment:

 

Categories | Articles and Tutorials | Advanced Search | Recommended Reading | Upload | Newest Code | Code of the Month | Code of the Day | All Time Hall of Fame | Coding Contest | Search for a job | Post a Job | Ask a Pro Discussion Forum | Live Chat | Feedback | Customize | Visual Basic Home | Site Home | Other Sites | About the Site | Feedback | Link to the Site | Awards | Advertising | Privacy

Copyright© 1997 by Exhedra Solutions, Inc. All Rights Reserved.  By using this site you agree to its Terms and Conditions.  Planet Source Code (tm) and the phrase "Dream It. Code It" (tm) are trademarks of Exhedra Solutions, Inc.