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 GetBkColor Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hDc As Long) As Long
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_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_CENTER = &H1 Or DT_WORDBREAK
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
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 SelectObject Lib "gdi32" (ByVal hDc As Long, 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 Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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
[Flat Highlight] = 8 'again the flat button but this one has no border until the mouse is over it
End Enum
Public Enum ColorTypes
[Use Windows] = 1
[Custom] = 2
[Force Standard] = 3
[Use Container] = 4
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)
Public Event MouseOver()
Public Event MouseOut()
'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 ForeO As Long 'fore color when mouse is over
Private elTex As String 'current text
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, cTextO As Long
Private lastStat As Byte, TE As String 'used to avoid unnecessary repaints
Private isOver As Boolean
Private Sub OverTimer_Timer()
Dim pt As POINTAPI
GetCursorPos pt
If UserControl.hWnd <> WindowFromPoint(pt.x, pt.y) Then
OverTimer.Enabled = False
isOver = False
Call Redraw(0, True)
RaiseEvent MouseOut
End If
End Sub
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
Call UserControl_Click
End Sub
Private Sub UserControl_AmbientChanged(PropertyName As String)
If MyColorType = [Use Container] Then
Call SetColors
Call Redraw(lastStat, True)
End If
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
Call SetColors
End Sub
Private Sub UserControl_InitProperties()
isEnabled = True
showFocusR = True
elTex = Ambient.DisplayName
Set UserControl.font = Ambient.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)
RaiseEvent MouseDown(Button, Shift, x, y)
LastButton = Button
If Button <> 2 Then Call Redraw(2, False)
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseMove(Button, Shift, x, y)
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 = 0) And (isOver = False) Then
OverTimer.Enabled = True
isOver = True
RaiseEvent MouseOver
Call Redraw(0, True)
ElseIf Button = 1 Then
Call Redraw(2, False)
End If
End If
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseUp(Button, Shift, x, y)
If Button <> 2 Then Call Redraw(0, False)
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
If Ambient.UserMode = False Then ForeO = theCol
Call SetColors
Call Redraw(lastStat, True)
PropertyChanged "FCOL"
End Property
Public Property Get ForeOver() As OLE_COLOR
ForeOver = ForeO
End Property
Public Property Let ForeOver(ByVal theCol As OLE_COLOR)
ForeO = theCol
Call SetColors
Call Redraw(lastStat, True)
PropertyChanged "FCOLO"
End Property
Public Property Get ButtonType() As ButtonTypes
ButtonType = MyButtonType
End Property
Public Property Let ButtonType(ByVal newValue As ButtonTypes)
MyButtonType = newValue
If ButtonType = [Java metal] Then UserControl.FontBold = True
Call UserControl_Resize
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 CalcTextRects
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 = n
Call e Wift)
Lastme0 ieAl
Call SetColors
Call ReD
'#yChangetButton = 1
c Pt
isEnaublic PTerCw= tht ╖nty
hen
Public Property Let Enmutton = 1
c lors
Cl ReDeBackCol
UserControl.perty Let Enmut
Cal
Public
39) Or (KeyCodeCall Redraw9 LE_ud 'welare y nd PrE_ud 'welWENAB"
