Private Declare Function SetPixel Lib "gdi32" Alias "SetPixelV" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_BTNDKSHADOW = 21
Private Const COLOR_BTNLIGHT = 22
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_LEFT = &H0
Private Const DT_CENTERABS = &H65
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Const RGN_DIFF = 4
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Public Enum ButtonTypes
[Windows 16-bit] = 1 'the old-fashioned Win16 button
[Windows 32-bit] = 2 'the classic windows button
[Windows XP] = 3 'the new brand XP button totally owner-drawn
[Mac] = 4 'i suppose it looks exactly as a Mac button... i took the style from a GetRight skin!!!
[Java metal] = 5 'there are also other styles but not so different from windows one
[Netscape 6] = 6 'this is the button displayed in web-pages, it also appears in some java apps
[Simple Flat] = 7 'the standard flat button seen on toolbars
End Enum
Public Enum ColorTypes
[Use Windows] = 1
[Custom] = 2
[Force Standard] = 3
End Enum
'events
Public Event Click()
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
'variables
Private MyButtonType As ButtonTypes
Private MyColorType As ColorTypes
Private He As Long 'the height of the button
Private Wi As Long 'the width of the button
Private BackC As Long 'back color
Private ForeC As Long 'fore color
Private elTex As String 'current text
Private TextFont As StdFont 'current font
Private rc As RECT, rc2 As RECT, rc3 As RECT
Private rgnNorm As Long
Private LastButton As Byte, LastKeyDown As Byte
Private isEnabled As Boolean
Private hasFocus As Boolean, showFocusR As Boolean
Private cFace As Long, cLight As Long, cHighLight As Long, cShadow As Long, cDarkShadow As Long, cText As Long
Private lastStat As Byte, TE As String 'used to avoid unnecessary repaints
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
Call UserControl_Click
End Sub
Private Sub UserControl_AmbientChanged(PropertyName As String)
Call Redraw(lastStat, True)
End Sub
Private Sub UserControl_Click()
If (LastButton = 1) And (isEnabled = True) Then
Call Redraw(0, True) 'be sure that the normal status is drawn
UserControl.Refresh
RaiseEvent Click
End If
End Sub
Private Sub UserControl_DblClick()
If LastButton = 1 Then
Call UserControl_MouseDown(1, 1, 1, 1)
End If
End Sub
Private Sub UserControl_GotFocus()
hasFocus = True
Call Redraw(lastStat, True)
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
LastKeyDown = KeyCode
If KeyCode = 32 Then 'spacebar pressed
Call UserControl_MouseDown(1, 1, 1, 1)
ElseIf (KeyCode = 39) Or (KeyCode = 40) Then 'right and down arrows
SendKeys "{Tab}"
ElseIf (KeyCode = 37) Or (KeyCode = 38) Then 'left and up arrows
SendKeys "+{Tab}"
End If
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
If (KeyCode = 32) And (LastKeyDown = 32) Then 'spacebar pressed
Call UserControl_MouseUp(1, 1, 1, 1)
LastButton = 1
Call UserControl_Click
End If
End Sub
Private Sub UserControl_LostFocus()
hasFocus = False
Call Redraw(lastStat, True)
End Sub
Private Sub UserControl_Initialize()
LastButton = 1
rc2.Left = 2: rc2.Top = 2
Call SetColors
End Sub
Private Sub UserControl_InitProperties()
isEnabled = True
showFocusR = True
Set TextFont = UserControl.Font
MyButtonType = [Windows 32-bit]
MyColorType = [Use Windows]
BackC = GetSysColor(COLOR_BTNFACE)
ForeC = GetSysColor(COLOR_BTNTEXT)
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
LastButton = Button
If Button <> 2 Then Call Redraw(2, False)
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button < 2 Then
If X < 0 Or Y < 0 Or X > Wi Or Y > He Then
'we are outside the button
Call Redraw(0, False)
Else
'we are inside the button
If Button = 1 Then Call Redraw(2, False)
End If
End If
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 2 Then Call Redraw(0, False)
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
'########## BUTTON PROPERTIES ##########
Public Property Get BackColor() As OLE_COLOR
BackColor = BackC
End Property
Public Property Let BackColor(ByVal theCol As OLE_COLOR)
BackC = theCol
Call SetColors
Call Redraw(lastStat, True)
PropertyChanged "BCOL"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = ForeC
End Property
Public Property Let ForeColor(ByVal theCol As OLE_COLOR)
ForeC = theCol
Call SetColors
Call Redraw(lastStat, True)
PropertyChanged "FCOL"
End Property
Public Property Get ButtonType() As ButtonTypes
ButtonType = MyButtonType
End Property
Public Property Let ButtonType(ByVal newValue As ButtonTypes)
MyButtonType = newValue
Call UserControl_Resize
Call Redraw(0, True)
PropertyChanged "BTYPE"
End Property
Public Property Get Caption() As String
Caption = elTex
End Property
Public Property Let Caption(ByVal newValue As String)
elTex = newValue
Call SetAccessKeys
Call Redraw(0, True)
PropertyChanged "TX"
End Property
Public Property Get Enabled() As Boolean
Enabled = isEnabled
End Property
Public Property Let Enabled(ByVal newValue As Boolean)
isEnabled = newValue
Call Redraw(0, True)
UserControl.Enabled = isEnabled
PropertyChanged "ENAB"
End Property
Public Property Get Font() As Font
Set Font = TextFont
End Property
Public Property Set Font(ByRef newFont As Font)
Set TextFont = newFont
Set UserControl.Font = TextFont
Call Redraw(0, True)
PropertyChanged "FONT"
End Property
'is very common that a windows user uses custom color
'schemes to view his/her desktop, and is also very
'common that this color scheme has weird colors that
'would alter the nice look of my buttons.
'So if you want to force the button to use the windows
'standard colors you may change this property to "Force Standard"
'UPDATE!!!
'you may now use your custom colors to display the button!!!
Public Property Get ColorScheme() As ColorTypes
ColorScheme = MyColorType
End Property
Public Property Let ColorScheme(ByVal newValue As ColorTypes)
MyColorType = newValue
Call SetColors
Call Redraw(0, True)
PropertyChanged "COLTYPE"
End Property
Public Property Get ShowFocusRect() As Boolean
ShowFocusRect = showFocusR
End Property
Public Property Let ShowFocusRect(ByVal newValue As Boolean)
showFocusR = newValue
Call Redraw(lastStat, True)
PropertyChanged "FOCUSR"
End Property
Public Property Get hwnd() As Long
hwnd = UserControl.hwnd
End Property
'########## END OF PROPERTIES ##########
Private Sub UserControl_Resize()
He = UserControl.ScaleHeight
Wi = UserControl.ScaleWidth
rc.Bottom = He: rc.Right = Wi
rc2.Bottom = He: rc2.Right = Wi
rc3.Left = 4: rc3.Top = 4: rc3.Right = Wi - 4: rc3.Bottom = He - 4
DeleteObject rgnNorm
Call MakeRegion
SetWindowRgn UserControl.hwnd, rgnNorm, True
Call Redraw(0, True)
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
MyButtonType = PropBag.ReadProperty("BTYPE", 2)
elTex = PropBag.ReadProperty("TX", "")
isEnabled = PropBag.ReadProperty("ENAB", True)
Set TextFont = PropBag.ReadProperty("FONT", UserControl.Font)
Private Sub DrawRectangle(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As Long, Optional OnlyBorder As Boolean = False)
'this is my custom function to draw rectangles and frames
'it's faster and smoother than using the line method
Dim bRect As RECT
Dim hBrush As Long
Dim Ret As Long
bRect.Left = X
bRect.Top = Y
bRect.Right = X + Width
bRect.Bottom = Y + Height
hBrush = CreateSolidBrush(Color)
If OnlyBorder = False Then
Ret = FillRect(UserControl.hdc, bRect, hBrush)
Else
Ret = FrameRect(UserControl.hdc, bRect, hBrush)
End If
Ret = DeleteObject(hBrush)
End Sub
Private Sub DrawLine(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As Long)
'a fast way to draw lines
Dim pt As POINTAPI
UserControl.ForeColor = Color
MoveToEx UserControl.hdc, X1, Y1, pt
LineTo UserControl.hdc, X2, Y2
End Sub
Private Sub mSetPixel(ByVal X As Long, ByVal Y As Long, ByVal Color As Long)
Call SetPixel(UserControl.hdc, X, Y, Color)
End Sub
Private Sub DrawFocusR()
SetTextColor UserControl.hdc, cText
DrawFocusRect UserControl.hdc, rc3
End Sub
Private Sub SetColors()
'this function sets the colors taken as a base to build
'all the other colors and styles.
If MyColorType = Custom Then
cFace = BackC
cText = ForeC
cShadow = ShiftColor(cFace, -&H40)
cLight = ShiftColor(cFace, &H1F)
cHighLight = ShiftColor(cFace, &H2F) 'it should be 3F but it looks too lighter
cDarkShadow = ShiftColor(cFace, -&HC0)
ElseIf MyColorType = [Force Standard] Then
cFace = &HC0C0C0
cShadow = &H808080
cLight = &HDFDFDF
cDarkShadow = &H0
cHighLight = &HFFFFFF
cText = &H0
Else
'if MyColorType is 1 or has not been set then use windows colors
cFace = GetSysColor(COLOR_BTNFACE)
cShadow = GetSysColor(COLOR_BTNSHADOW)
cLight = GetSysColor(COLOR_BTNLIGHT)
cDarkShadow = GetSysColor(COLOR_BTNDKSHADOW)
cHighLight = GetSysColor(COLOR_BTNHIGHLIGHT)
cText = GetSysColor(COLOR_BTNTEXT)
End If
End Sub
Private Sub MakeRegion()
'this function creates the regions to "cut" the UserControl
'so it will be transparent in certain areas
Dim rgn1 As Long, rgn2 As Long
DeleteObject rgnNorm
rgnNorm = CreateRectRgn(0, 0, Wi, He)
rgn2 = CreateRectRgn(0, 0, 0, 0)
Select Case MyButtonType
Case 1 'Windows 16-bit
rgn1 = CreateRectRgn(0, 0, 1, 1)
CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(0, He, 1, He - 1)
CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(Wi, 0, Wi - 1, 1)
CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(Wi, He, Wi - 1, He - 1)
CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
DeleteObject rgn1
Case 3, 4 'Windows XP and Mac
rgn1 = CreateRectRgn(0, 0, 2, 1)
CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(0, He, 2, He - 1)
CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(Wi, 0, Wi - 2, 1)
CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(Wi, He, Wi - 2, He - 1)
CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(0, 1, 1, 2)
CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(0, He - 1, 1, He - 2)
CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(Wi, 1, Wi - 1, 2)
CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(Wi, He - 1, Wi - 1, He - 2)
CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
DeleteObject rgn1
Case 5 'Java
rgn1 = CreateRectRgn(0, He, 1, He - 1)
CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(Wi, 0, Wi - 1, 1)
CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
DeleteObject rgn1
End Select
DeleteObject rgn2
End Sub
Private Sub SetAccessKeys()
'this is a TRUE access keys parser
'i hate seeing how other programmers just check for the
'existence of the ampersand regardless of what follows it
