编辑框

开发平台：
Visual Basic

HoverButton.ctl：源码内容
							VERSION 5.00
Begin VB.UserControl HoverControl 
   ClientHeight    =   600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2145
   ScaleHeight     =   40
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   143
End
Attribute VB_Name = "HoverControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
 'Project:       Hover button control
'Description:   A flat button like simple button with hovering effect
'               which uses differnet Win32 api for effects
'Author:        Muhammad Saleem Mirza
'Email:         saleem_mirza@yahoo.com
'               For more information and questions, please feel free to contact me
'               at saleem_mirza@yahoo.com
'               I will welcome your sugestions
'''''''''''''''''''''''''''''''
'
'
Option Explicit
Dim m_Caption As String
Dim m_SingleLine As Boolean
Dim m_Image As Picture
'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
Event MouseEnter(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Event MouseOut(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Private HiColor As OLE_COLOR
Private ShadowColor As OLE_COLOR
Private IsButtonPressed As Boolean
Private rcText As RECT
'Default Property Values:
Const m_def_Caption = "Hover Button"
Const m_def_SingleLine = True
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
'LHJ
Private m_bFlat As Boolean
Private Const P2P_COLOR_HLIGHT = &HFFFFFF
Private Const P2P_COLOR_SHADOW = &HFF8080
Private m_nDrawWidth  As Integer
'Private m_HightColor As Long
'Private m_ShadowColor As Long
Public m_bStrech As Boolean
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
    Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    UserControl.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
    Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
    Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
    Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
    Set UserControl.Font = New_Font
    PropertyChanged "Font"
    Refresh
End Property
'
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Refresh
Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
    UserControl.Refresh
End Sub
Private Sub UserControl_Click()
    RaiseEvent Click
   ' Draw3Drect rcText, HiColor, ShadowColor
  '  Debug.Print "UserControl_Click()"
End Sub
Private Sub UserControl_DblClick()
    RaiseEvent DblClick
    ButtonDown vbLeftButton
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    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)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    ButtonDown Button
    RaiseEvent MouseDown(Button, Shift, x, y)
End Sub
'Capture mouse movement, changes look according to mouse position
'like hovering effect
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseMove(Button, Shift, x, y)
    If Button = vbLeftButton Then
        Exit Sub
    End If
    
    Dim m_rect As RECT
    CopyRect rcText, m_rect
    
    If GetCapture() <> UserControl.hwnd Then
        SetCapture (UserControl.hwnd)
        Draw3DRect m_rect, HiColor, ShadowColor
        RaiseEvent MouseEnter(Button, Shift, x, y)
       ' m_Image.t
    Else
        Dim PT As POINTAPI
        PT.x = x
        PT.y = y
        ClientToScreen UserControl.hwnd, PT
        If WindowFromPoint(PT.x, PT.y) <> UserControl.hwnd Then
            Refresh
            If Button <> vbLeftButton Then
                   RaiseEvent MouseOut(Button, Shift, x, y)
  
                ReleaseCapture
            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)
    ButtonUp Button
    
End Sub
'
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    Set UserControl.Font = Ambient.Font
    Set m_Image = Nothing
    m_SingleLine = m_def_SingleLine
    m_Caption = m_def_Caption
    m_nDrawWidth = 1
End Sub
Private Sub UserControl_Paint()
    If IsButtonPressed = False Then
        PrintCaption UserControl.hwnd, UserControl.hdc, m_Caption
    End If
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    Set m_Image = PropBag.ReadProperty("Image", Nothing)
    m_SingleLine = PropBag.ReadProperty("SingleLine", m_def_SingleLine)
    m_Caption = PropBag.ReadProperty("Caption", m_def_Caption)
    m_bFlat = PropBag.ReadProperty("bFlat", False)
    HiColor = PropBag.ReadProperty("HlightColor", P2P_COLOR_HLIGHT)
    ShadowColor = PropBag.ReadProperty("ShadowColor2", P2P_COLOR_SHADOW)
    m_nDrawWidth = PropBag.ReadProperty("nDrawWidth", 1)
End Sub
Private Sub UserControl_Resize()
   ' HiColor = HiColor
   ' ShadowColor = ShadowColor
    GetClientRect UserControl.hwnd, rcText
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
    Call PropBag.WriteProperty("Image", m_Image, Nothing)
    Call PropBag.WriteProperty("SingleLine", m_SingleLine, m_def_SingleLine)
    Call PropBag.WriteProperty("Caption", m_Caption, m_def_Caption)
    Call PropBag.WriteProperty("bFlat", m_bFlat, False)
    Call PropBag.WriteProperty("ShadowColor2", ShadowColor, P2P_COLOR_SHADOW)
    Call PropBag.WriteProperty("HlightColor", HiColor, P2P_COLOR_HLIGHT)
      Call PropBag.WriteProperty("nDrawWidth", m_nDrawWidth, 1)
 
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=11,0,0,0
Public Property Get Image() As Picture
    Set Image = m_Image
End Property
Public Property Set Image(ByVal New_Image As Picture)
    Set m_Image = New_Image
    PropertyChanged "Image"
    Refresh
End Property
' Draw Caption and image on button
Private Sub PrintCaption(hwnd As Long, hdc As Long, mCaption As String)
    
    Dim rText As RECT, rTemp As RECT, rcBRect As RECT
    Dim mCap As String
    Dim textHeight  As Long
    Dim Rgn As Long
    Cls
    
    
   ' CopyRect rcBRect, m_rect
     Dim rct As RECT
    Dim hBr As Long
    'Fill in the hDC with the form's
    'background color. Otherwise the form
    'may appear Totally Garbage.
    rct.Left = 0
    rct.Top = 0
    rct.Right = ScaleX(UserControl.Width, vbPixels, vbPixels)
    rct.Bottom = ScaleY(UserControl.Height, vbPixels, vbPixels)
    hBr = CreateSolidBrush(TranslateColor(&H80000005))
    FillRect hdc, rct, hBr
    DeleteObject hBr
   
     
    
    mCap = mCaption
    CopyRect rcText, rTemp
    InflateRect rTemp, -1, -1
    
    Rgn = CreateRectRgnIndirect(rTemp)
    SelectClipRgn hdc, Rgn
    
    CopyRect rTemp, rText
    
    SelectFont hdc, Font(), ForeColor()
    If m_SingleLine = True Then
        textHeight = DrawText(hdc, mCap, Len(mCap), rText, DT_CENTER Or DT_CALCRECT Or DT_BOTTOM Or DT_WORD_ELLIPSIS)
    Else
        textHeight = DrawText(hdc, mCap, Len(mCap), rText, DT_CENTER Or DT_CALCRECT Or DT_WORDBREAK)
    End If
    
    If m_Image Is Nothing Then
        rText.Top = (rTemp.Bottom - textHeight) / 2
    Else
        rText.Top = rTemp.Bottom - textHeight
    End If
    rText.Bottom = rTemp.Bottom
    rText.Right = rTemp.Right
    'If image is not specified then draw caption at center of button
    'otherwise draw image
    If Not m_Image Is Nothing Then
        Dim ImageWidth As Long, ImageHeight As Long, ImageLeft As Long, ImageTop As Long
        
        rTemp.Bottom = rText.Top + rTemp.Top
        ImageWidth = ScaleX(m_Image.Width, vbHimetric, vbPixels)
        ImageHeight = ScaleX(m_Image.Height, vbHimetric, vbPixels)
        ImageLeft = (rTemp.Right - ImageWidth) / 2
        ImageLeft = IIf(ImageLeft <= 0, rTemp.Left, ImageLeft)
        ImageTop = (rTemp.Bottom - ImageHeight) / 2
        ImageTop = IIf(ImageTop <= 0, rTemp.Top, ImageTop)
        If IsButtonPressed = True Then
            ImageLeft = ImageLeft + 1
            ImageTop = ImageTop + 1
        End If
        If m_bStrech Then
            PaintPicture m_Image, ImageLeft, ImageTop, ScaleX(UserControl.Width, vbHimetric, vbPixels), ScaleX(UserControl.Height, vbHimetric, vbPixels)
        Else
            If m_bFlat Then
                PaintPicture m_Image, ImageLeft, ImageTop + 1
            Else
                PaintPicture m_Image, ImageLeft + 1, ImageTop + 1
            End If
           ' Debug.Print ImageLeft & " top:" & ImageTop
        End If
    End If
    If IsButtonPressed = True Then
        OffsetRect rText, 1, 1
    End If
    
    If m_SingleLine = True Then
        DrawText hdc, mCap, Len(mCap), rText, DT_CENTER Or DT_BOTTOM Or DT_WORD_ELLIPSIS
    Else
        DrawText hdc, mCap, Len(mCap), rText, DT_CENTER Or DT_WORDBREAK
    End If
    SelectClipRgn hdc, 0
    DeleteObject Rgn
    
     ' SetBkColor hdc, &H80000005
  
End Sub
' Draw 3D border around the button
Private Function Draw3DRect(pRect As RECT, Optional ColorHilight As Long, Optional ColorShadow As Long) As Boolean
       
    If m_bFlat Then
        Draw3DRect = DrawFlatEdges(pRect, ColorHilight, ColorShadow)
        Exit Function
    End If
    
    
    Dim lpRect As RECT
    CopyRect pRect, lpRect
    DrawWidth = 1
    
    InflateRect lpRect, -1, -1
    Line (lpRect.Left, lpRect.Bottom)-(lpRect.Left, lpRect.Top), ColorHilight
    Line -(lpRect.Right, lpRect.Top), ColorHilight
    Line -(lpRect.Right, lpRect.Bottom), ColorShadow
    Line -(lpRect.Left, lpRect.Bottom), ColorShadow
    Draw3DRect = True
End Function
Private Function DrawFlatEdges(pRect As RECT, Optional ColorHilight As Long, Optional ColorShadow As Long) As Boolean
    Dim lpRect As RECT
    CopyRect pRect, lpRect
    If m_nDrawWidth <= 0 Then
        m_nDrawWidth = 1
    End If
    DrawWidth = m_nDrawWidth
    Dim Color As Long
    If ColorShadow > -1 Then
        Color = ColorShadow
    Else
       Color = ColorHilight
    End If
    If Color < 0 Then
        Color = 0
    End If
    
    InflateRect lpRect, -0, -0
    Line (lpRect.Left, lpRect.Bottom - 1)-(lpRect.Left, lpRect.Top), Color
    Line -(lpRect.Right - 1, lpRect.Top), Color
    Line -(lpRect.Right - 1, lpRect.Bottom - 1), Color
    Line -(lpRect.Left, lpRect.Bottom - 1), Color
    DrawFlatEdges = True
End Function
Private Sub CopyRect(Src As RECT, dest As RECT)
    With dest
        .Bottom = Src.Bottom
        .Left = Src.Left
        .Right = Src.Right
        .Top = Src.Top
    End With
End Sub
Private Sub ButtonDown(Optional Button As Integer)
    
    If Button = vbLeftButton And Button <> vbRightButton Then
        IsButtonPressed = True
        PrintCaption UserControl.hwnd, UserControl.hdc, m_Caption
        Dim m_rect As RECT
        CopyRect rcText, m_rect
        Draw3DRect m_rect, ShadowColor, HiColor
    End If
End Sub
Private Sub ButtonUp(Optional Button As Integer)
    IsButtonPressed = False
   ' ButtonDown Button
    Refresh
End Sub
'MemberInfo=0,0,0,True
Public Property Get SingleLine() As Boolean
    SingleLine = m_SingleLine
End Property
Public Property Let SingleLine(ByVal New_SingleLine As Boolean)
    m_SingleLine = New_SingleLine
    PropertyChanged "SingleLine"
    Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get Caption() As String
    Caption = m_Caption
End Property
Public Property Let Caption(ByVal New_Caption As String)
    m_Caption = New_Caption
    PropertyChanged "Caption"
    Refresh
End Property
Public Sub About()
   ' frmAbout.Show 1, Me
End Sub
Public Property Get bFlat() As Boolean
    bFlat = m_bFlat
End Property
Public Property Let bFlat(ByVal vNewValue As Boolean)
    m_bFlat = vNewValue
    PropertyChanged "bFlat"
    Refresh
End Property
Public Property Get HlightColor() As OLE_COLOR
    HlightColor = HiColor
End Property
Public Property Let HlightColor(ByVal vNewValue As OLE_COLOR)
    HiColor = vNewValue
    PropertyChanged "HlightColor"
    Refresh
End Property
Public Property Get ShadowColor2() As OLE_COLOR
    ShadowColor2 = ShadowColor
End Property
Public Property Let ShadowColor2(ByVal vNewValue As OLE_COLOR)
   ShadowColor = vNewValue
    PropertyChanged "ShadowColor2"
    Refresh
End Property
Public Property Get nDrawWidth() As Integer
    nDrawWidth = m_nDrawWidth
End Property
Public Property Let nDrawWidth(ByVal vNewValue As Integer)
    m_nDrawWidth = vNewValue
    PropertyChanged "nDrawWidth"
    Refresh
End Property

						