button.ctl

一个功能特别的WINXP的科学计算器

VERSION 5.00
Begin VB.UserControl Button 
   AutoRedraw      =   -1  'True
   CanGetFocus     =   0   'False
   ClientHeight    =   1140
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2130
   DefaultCancel   =   -1  'True
   ForeColor       =   &H000000FF&
   ScaleHeight     =   76
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   142
End
Attribute VB_Name = "Button"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'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
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)

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
Private 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


'Single click
Private Sub UserControl_Click()
        RaiseEvent Click
        UserControl.Refresh
End Sub


'Double click
Private Sub UserControl_DblClick()
    
    If LastButton = 1 Then
        'Call the mousedown sub
        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

'Initialize
Private Sub UserControl_Initialize()

    LastButton = 1   'Lastbutton = right mouse button
    RC2.Left = 2
    RC2.Top = 2
    SetColors        'Get default colors
    
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)
    
    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


'Mousemove
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 > Width Or Y > Height Then   'Not inside button
            Redraw 0, False                                 'Redraw
        ElseIf Button = 1 Then                              'Right click
            Redraw 2, False                                 'Redraw
        End If
    End If
    
    'Raise mousemove event
    RaiseEvent MouseMove(Button, Shift, X, Y)
    
End Sub


'Mouseup
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    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)
    isEnabled = newValue            'Set enabled/disabled
    Redraw 0, True                  'Redraw
    UserControl.Enabled = isEnabled 'Set enabled/disabled
    PropertyChanged "ENAB"          'Last property changed is enabled
End Property


'Property Get: Font
Public Property Get Font() As Font
    Set Font = CurrFont             'Return font
End Property


'Property Set: Font
Public Property Set Font(ByRef newFont As Font)
    Set CurrFont = newFont          'Set font
    Set UserControl.Font = CurrFont 'Set font
    Redraw 0, True                  'Redraw
    PropertyChanged "FONT"          'Last property changed is font
End Property


'Property Get: hWnd
Public Property Get hwnd() As Long
    hwnd = UserControl.hwnd         'Return hWnd
End Property


'Resize
Private Sub UserControl_Resize()
    
    'Renew dimension variables
    Height = UserControl.ScaleHeight
    Width = UserControl.ScaleWidth
    
    'Set rect1
    RC.Bottom = Height
    RC.Right = Width
    
    'Set rect 2
    RC2.Bottom = Height
    RC2.Right = Width