'during programming the auto-type (auto completion) will not work properly
'if a form using the XP-Style button is open
Option Explicit
Private m_lngHeight As Long
Private m_lngWidth As Long
Private m_blnSkinFromRes As Boolean
'
' Index values for the resource file.
'
Public Enum eImages
eNone = 0 ' No Value.
eSkin1 = 1 ' Skin Image 1.
End Enum
'
' Win32 API-Constants.
'
Private Const RGN_OR = 2
'
' Win32 API-Declarations.
'
'*********************************************
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y 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 ButtonLeftPressed As Boolean
'*********************************************
'For drawing the caption
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
'Rect drawing
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
'Create/Delete brush
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'For drawing lines
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
'Misc
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 Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim m_CurrPoint As POINTAPI
Dim cColor As Long
'Center
Private Const DT_CENTERABS = &H65
'Default system colours
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
'Rectangle
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Point
Private Type POINTAPI
x As Long
y As Long
End Type
'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)
Event MouseOut()
Private Height As Long 'Width
Private Width As Long 'Height
Private CurrText As String 'Current caption
Private CurrFont As StdFont 'Current font
'Rects structures
Private RC As RECT
Private RC2 As RECT
Private RC3 As RECT
Private LastButton As Byte 'Last button pressed
Private isEnabled As Boolean 'Enabled or not
'Default system colors
Public cFace As Long
Private cLight As Long
Private cHighLight As Long
Private cShadow As Long
Private cDarkShadow As Long
Private cText As Long
Private lastStat As Byte 'Last property
Private TE As String 'Text
Public MausOvr As Boolean 'maus ⁿber dem Button
Private FocusFlag As Boolean 'button hat den focus
Private MausOvrDrawn As Boolean 'maus highlight bereits gemalt
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Dim n As Integer
'Single click
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
'Double click
Private Sub UserControl_DblClick()
If LastButton = 1 Then
'Call the mousedown sub
RaiseEvent Click
'UserControl.Refresh
UserControl_MouseDown 1, 1, 1, 1
End If
End Sub
Public Property Get ForeColor() As OLE_COLOR
ForeColor = cColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
cColor = New_ForeColor
PropertyChanged "ForeColor"
End Property
Private Sub UserControl_GotFocus()
FocusFlag = True
If Not FocusFlag Then
Redraw 0, False
End If
End Sub
Private Sub UserControl_LostFocus()
FocusFlag = False
Redraw 0, False
End Sub
'Initialize
Private Sub UserControl_Initialize()
LastButton = 1 'Lastbutton = right mouse button
RC2.Left = 2
RC2.Top = 2
SetColors 'Get default colors
TimerMouseOvrCheck.Enabled = True
End Sub
'Initialize properties
Private Sub UserControl_InitProperties()
CurrText = "Caption" 'Caption
isEnabled = True 'Enabled
Set CurrFont = UserControl.Font 'Font
End Sub
'Mousedown
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then ButtonLeftPressed = True
LastButton = Button 'Set lastbutton
If Button <> 2 Then
Redraw 2, False 'Redraw button
End If
'Raise mousedown event
RaiseEvent MouseDown(Button, Shift, x, y)
End Sub
'Mouseup
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
ButtonLeftPressed = False
If Button <> 2 Then
Redraw 0, False 'Redraw
End If
'Raise mousrup event
RaiseEvent MouseUp(Button, Shift, x, y)
End Sub
'Property Get: Caption
Public Property Get Caption() As String
Caption = CurrText 'Return caption
End Property
'Property Let: Caption
Public Property Let Caption(ByVal newValue As String)
CurrText = newValue 'Set caption
Redraw 0, True 'Redraw
PropertyChanged "TX" 'Last property changed is text
End Property
'Property Get: Enabled
Public Property Get Enabled() As Boolean
Enabled = isEnabled 'Set enabled/disabled
End Property
'Property Let: Enabled
Public Property Let Enabled(ByVal newValue As Boolean)
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)
Dim bRect As RECT
Dim hBrush As Long
Dim Ret As Long
'Fill out rect
bRect.Left = x
bRect.Top = y
bRect.Right = x + Width
bRect.Bottom = y + Height
'Create brush
hBrush = CreateSolidBrush(Color)
If OnlyBorder = False Then 'Just border
Ret = FillRect(UserControl.hdc, bRect, hBrush)
Else 'Fill whole rect
Ret = FrameRect(UserControl.hdc, bRect, hBrush)
End If
'Delete brush
Ret = DeleteObject(hBrush)
End Sub
'Draw line
Private Sub DrawLine(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As Long)
Dim pt As POINTAPI
UserControl.ForeColor = Color 'Set forecolor
MoveToEx UserControl.hdc, X1, Y1, pt 'Move to X1/Y1
LineTo UserControl.hdc, X2, Y2 'Draw line to X2/Y2
End Sub
'Set Colours
Private Sub SetColors()
'Get system colours and save into variables
cFace = RGB(200, 200, 255)
'cFace = RGB(100, 100, 255)
'####################################
'# 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 Sub
'Shift colors
Private Function ShiftColor(ByVal Color As Long, ByVal value As Long) As Long
Dim Red As Long, Blue As Long, Green As Long
'Shift blue
Blue = ((Color \ &H10000) Mod &H100)
Blue = Blue + ((Blue * value) \ &HC0)
'Shift green
Green = ((Color \ &H100) Mod &H100) + value
'Shift red
Red = (Color And &HFF) + value
'Check red bounds
If Red < 0 Then
Red = 0
ElseIf Red > 255 Then
Red = 255
End If
'Check green bounds
If Green < 0 Then
Green = 0
ElseIf Green > 255 Then
Green = 255
End If
'Check blue bounds
If Blue < 0 Then
Blue = 0
ElseIf Blue > 255 Then
Blue = 255
End If
'Return color
ShiftColor = RGB(Red, Green, Blue)
End Function
Private Sub Timer1_Timer()
GetCursorPos m_CurrPoint
ScreenToClient hwnd, m_CurrPoint
MausOvrDrawn = False
'if the mouse has left the button, reset everything....
'Call UserControl_MouseMove(Button, Shift, X, Y)
'Call Image1_MouseMove(Button, Shift, X, Y)
If m_CurrPoint.x < UserControl.ScaleLeft Or _
m_CurrPoint.y < UserControl.ScaleTop Or _
m_CurrPoint.x > UserControl.ScaleLeft + UserControl.Width / 15 Or _
m_CurrPoint.y > UserControl.ScaleTop + UserControl.Height / 15 Then
Timer1.Enabled = False
'Raise the mouse leave event....
MausOvr = False
Redraw 0, False
RaiseEvent MouseOut
TimerMouseOvrCheck.Enabled = True
End If
End Sub
Private Sub TimerMouseOvrCheck_Timer()
GetCursorPos m_CurrPoint
ScreenToClient hwnd, m_CurrPoint
'if the mouse has left the button, reset everything....
'Call UserControl_MouseMove(Button, Shift, X, Y)
'Call Image1_MouseMove(Button, Shift, X, Y)
If Not (m_CurrPoint.x < UserControl.ScaleLeft Or _
m_CurrPoint.y < UserControl.ScaleTop Or _
m_CurrPoint.x > UserControl.ScaleLeft + UserControl.Width / 15 Or _
m_CurrPoint.y > UserControl.ScaleTop + UserControl.Height / 15) Then
TimerMouseOvrCheck.Enabled = False
MausOvr = True
'Redraw 0, False
If ButtonLeftPressed = True Then 'Right click
Redraw 2, False 'Redraw Button pressed
Else
If Not MausOvrDrawn Then
Redraw 0, False 'Redraw Button up
End If
End If
MausOvrDrawn = True
Timer1.Enabled = True
'Raise mousemove event
'RaiseEvent MouseMove(Button, Shift, X, Y)
End If
End Sub
Public Sub Refesh()
Redraw 0, False
End Sub
'Skin Part **********************************************
'
' The optional last parameter allows you to specify the image's background color. If left blank, the
' color of the image's top left pixel is used.
'
Public Function fRegionFromBitmap(picSource As Picture, Optional lngBackColor As Long) As Long
Dim lngReturn As Long
Dim lngRgnTmp As Long
Dim lngSkinRgn As Long
Dim lngStart As Long
Dim lngRow As Long
Dim lngCol As Long
'
' Create a rectangular region.
' A region is a rectangle, polygon, or ellipse (or a combination of two or more of these shapes)
' that can be filled, painted, inverted, framed, and used to perform hit testing (testing for
' the cursor location).
'
lngSkinRgn = CreateRectRgn(0, 0, 0, 0)
With UserControl
'
' Get the dimensions of the bitmap.
'
m_lngHeight = .Height / Screen.TwipsPerPixelY
m_lngWidth = .Width / Screen.TwipsPerPixelX
'
' If no background color is passed in, get the red, green, blue (RGB) color value of the top
' left pixel in the picturebox's device context (DC).
'
If lngBackColor < 1 Then lngBackColor = GetPixel(UserControl.hdc, 0, 0)
'
' Loop through the bitmap, row by row, examining each pixel.
' In each row, work from left to right comparing each pixel to the background color.
'
For lngRow = 0 To m_lngHeight - 1
lngCol = 0
Do While lngCol < m_lngWidth
'
' Skip all pixels in a row with the same color as the background color.
'
Do While lngCol < m_lngWidth And GetPixel(.hdc, lngCol, lngRow) = lngBackColor
lngCol = lngCol + 1
Loop
If lngCol < m_lngWidth Then
'
' Get the start and end of the block of pixels in the row that are not the same
' color as the background.
'
lngStart = lngCol
Do While lngCol < m_lngWidth And GetPixel(.hdc, lngCol, lngRow) <> lngBackColor
lngCol = lngCol + 1
Loop
If lngCol > m_lngWidth Then lngCol = m_lngWidth
'
' Create a region equal in size to the line of pixels that don't match the
' background color. Combine this region with our final region.
