command button.ctl

仿xp的计算器功能和普通计算器的功能一样

    RedrawButton 0

End Property

Public Property Get Font() As Font

    Set Font = UserControl.Font

End Property

Public Property Set Font(ByVal NewValue As Font)

    Set UserControl.Font = NewValue
    RedrawButton 0
    PropertyChanged "Font"

End Property

Public Property Get ForeColor() As OLE_COLOR

    ForeColor = UserControl.ForeColor

End Property

Public Property Let ForeColor(ByVal NewValue As OLE_COLOR)

    UserControl.ForeColor = NewValue
    RedrawButton 0
    PropertyChanged "ForeColor"

End Property

Public Property Get ForeHover() As OLE_COLOR

    ForeHover = mForeHover

End Property

Public Property Let ForeHover(ByVal NewValue As OLE_COLOR)

    mForeHover = NewValue
    PropertyChanged "ForeHover"

End Property

Private Sub HoverTimer_Timer()

    If Not isMouseOver Then
        HoverTimer.Enabled = False
        isOver = False
        flgHover = 0
        RedrawButton 0
        RaiseEvent MouseOut
    End If

End Sub

Private Function isMouseOver() As Boolean

Dim pt As POINTAPI

    GetCursorPos pt
    isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hwnd)

End Function

Private Sub MakeRegion()

    DeleteObject rgMain
    rgMain = CreateRectRgn(0, 0, w, H)
    rgn1 = CreateRectRgn(0, 0, 1, 1)            'Left top coner
    CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
    DeleteObject rgn1
    rgn1 = CreateRectRgn(0, H - 1, 1, H)      'Left bottom corner
    CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
    DeleteObject rgn1
    rgn1 = CreateRectRgn(w - 1, 0, w, 1)      'Right top corner
    CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
    DeleteObject rgn1
    rgn1 = CreateRectRgn(w - 1, H - 1, w, H) 'Right bottom corner
    CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
    DeleteObject rgn1
    SetWindowRgn UserControl.hwnd, rgMain, True

End Sub

Private Sub RedrawButton(Optional ByVal Stat As Integer = -1)

    If mEnabled Then
        If Stat = 1 And LastButton = 1 Then
            DrawButtonDown
        Else 'NOT STAT...
            DrawButtonFace
            If isOver Then
                DrawHighlight
            Else 'ISOVER = FALSE/0
                If flgFocus Then
                    DrawFocus
                End If
            End If
        End If
        DrawButton2
    Else 'MENABLED = FALSE/0
        DrawButtonDisabled
    End If
    DrawCaption
    MakeRegion

End Sub

Private Sub SetAccessKeys()

Dim I As Long

    UserControl.AccessKeys = vbNullString
    If Len(mCaption) > 1 Then
        I = InStr(1, mCaption, "&", vbTextCompare)
        If I < Len(mCaption) Then
            If I > 0 Then
                If Mid$(mCaption, I + 1, 1) <> "&" Then
                    UserControl.AccessKeys = LCase$(Mid$(mCaption, I + 1, 1))
                Else 'NOT MID$(MCAPTION,...
                    I = InStr(I + 2, mCaption, "&", vbTextCompare)
                    If Mid$(mCaption, I + 1, 1) <> "&" Then
                        UserControl.AccessKeys = LCase$(Mid$(mCaption, I + 1, 1))
                    End If
                End If
            End If
        End If
    End If

End Sub

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)

    LastButton = 1
    UserControl_Click

End Sub

Private Sub UserControl_Click()

    If LastButton = 1 Then
        RedrawButton 0
        '        LastButton = 1
        '        RedrawButton 1
        UserControl.Refresh
        RaiseEvent Click
    End If

End Sub

Private Sub UserControl_DblClick()

    If LastButton = 1 Then
        UserControl_MouseDown 1, 0, 0, 0
        SetCapture hwnd
    End If

End Sub

Private Sub UserControl_GotFocus()

    flgFocus = True
    If mEnabled Then
        LastButton = 1
        UserControl.Refresh
        RedrawButton 0
    End If

End Sub

Private Sub UserControl_InitProperties()

    Set UserControl.Font = Ambient.Font
    mCaption = "Command" & Mid$(Ambient.DisplayName, 9)
    mEnabled = True

End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, _
                                Shift As Integer)

    LastKey = KeyCode
    Select Case KeyCode
    Case vbKeySpace, vbKeyReturn
        RedrawButton 1
    Case vbKeyLeft, vbKeyRight 'right and down arrows
        SendKeys "{Tab}"
    Case vbKeyDown, vbKeyUp 'left and up arrows
        SendKeys "+{Tab}"
    End Select
    RaiseEvent KeyDown(KeyCode, Shift)

End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)

    RaiseEvent KeyPress(KeyAscii)

End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, _
                              Shift As Integer)

    If ((KeyCode = vbKeySpace) And (LastKey = vbKeySpace)) Or ((KeyCode = vbKeyReturn) And (LastKey = vbKeyReturn)) Then
        RedrawButton 0
        LastButton = 1
        UserControl.Refresh
        RaiseEvent Click
    End If
    RaiseEvent KeyUp(KeyCode, Shift)

End Sub

Private Sub UserControl_LostFocus()

    flgFocus = False
    RedrawButton 0

End Sub

Private Sub UserControl_MouseDown(Button As Integer, _
                                  Shift As Integer, _
                                  X As Single, _
                                  Y As Single)

    If mEnabled Then
        RaiseEvent MouseDown(Button, Shift, X, Y)
        LastButton = Button
        UserControl.Refresh
        DoEvents
        RedrawButton 1
    End If

End Sub

Private Sub UserControl_MouseMove(Button As Integer, _
                                  Shift As Integer, _
                                  X As Single, _
                                  Y As Single)

'  UserControl_GotFocus

    If Button < 2 Then
        If Not isMouseOver Then
            If flgHover = 0 Then
                Exit Sub
                '<:-) :SUGGESTION: (EXPERIMENTAL follow advice with care )
                '<:-) Explict 'Exit ProcedureType' can make code flow harder to follow.(Fix ID 11)
                '<:-) No recommended action but consider coding around it.
            End If
            RedrawButton 0
        Else 'NOT NOT...
            If flgHover = 1 Then
                Exit Sub
                '<:-) :SUGGESTION: (EXPERIMENTAL follow advice with care )
                '<:-) Explict 'Exit ProcedureType' can make code flow harder to follow.(Fix ID 11)
                '<:-) No recommended action but consider coding around it.
            End If
            flgHover = 1
            If Button = 0 And Not isOver Then
                HoverTimer.Enabled = True
                isOver = True
                flgHover = 0
                RedrawButton 0
                RaiseEvent MouseOver
            ElseIf Button = 1 Then 'NOT BUTTON...
                isOver = True
                RedrawButton 1
                isOver = False
            End If
        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)

    RaiseEvent MouseUp(Button, Shift, X, Y)
    RedrawButton 0
    UserControl.Refresh

End Sub

Private Sub usercontrol_readproperties(propbag As PropertyBag)

    With propbag
        Set UserControl.Font = .ReadProperty("Font", Ambient.Font)
        mEnabled = .ReadProperty("Enabled", True)
        mCaption = .ReadProperty("Caption", Ambient.DisplayName)
        UserControl.ForeColor = .ReadProperty("ForeColor", Ambient.ForeColor)
        mForeHover = .ReadProperty("ForeHover", UserControl.ForeColor)
    End With 'PROPBAG
    UserControl.Enabled = mEnabled
    SetAccessKeys

End Sub

Private Sub UserControl_Resize()

    GetClientRect UserControl.hwnd, rc
    With rc
        R = .Right - 1
        L = .Left
        t = .Top
        B = .Bottom
        w = .Right
        H = .Bottom
    End With 'RC
    RedrawButton 0

End Sub

Private Sub UserControl_Show()

    RedrawButton 0

End Sub

Private Sub usercontrol_writeproperties(propbag As PropertyBag)

    With propbag
        .WriteProperty "Enabled", mEnabled, True
        .WriteProperty "Font", UserControl.Font, Ambient.Font
        .WriteProperty "Caption", mCaption, Ambient.DisplayName
        .WriteProperty "ForeColor", UserControl.ForeColor
        .WriteProperty "ForeHover", mForeHover, Ambient.ForeColor
    End With 'PROPBAG

End Sub

':)Code Fixer V3.0.9 (2006-12-2 23:31:22) 94 + 844 = 938 Lines Thanks Ulli for inspiration and lots of code.