button.ctl

非常漂亮的VB控件

Private Function isMouseOver() As Boolean
Dim pt As POINTAPI

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



'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_ButtonStyle = m_def_ButtonStyle
'    Set m_ButtonIcon = LoadPicture("")
    Set m_ButtonIcon = LoadPicture("")
    Set m_NoPicture = LoadPicture("")
    Set m_OnPicture = LoadPicture("")
    Set m_DownPicture = LoadPicture("")
    m_UsePicture = m_def_UsePicture
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    L.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    Set L.Font = PropBag.ReadProperty("Font", Ambient.Font)
    L.Caption = PropBag.ReadProperty("Caption", "Label1")
    Set Picture = PropBag.ReadProperty("PicNoFocus", LoadResPicture(2000 + m_ButtonStyle, 0))
    Set Picture = PropBag.ReadProperty("PicGetFocus", LoadResPicture(2100 + m_ButtonStyle, 0))
    Set Picture = PropBag.ReadProperty("PicMouseDown", LoadResPicture(2200 + m_ButtonStyle, 0))
'    BT.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
    m_ButtonStyle = PropBag.ReadProperty("ButtonStyle", m_def_ButtonStyle)
    Set Picture = PropBag.ReadProperty("ButtonIcon", Nothing)
    If Not m_UsePicture Then
        BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
    Else
        BT.Picture = m_NoPicture
    End If
    SetAccessKeys
'    Set m_ButtonIcon = PropBag.ReadProperty("ButtonIcon", Nothing)
    Ico.Picture = m_ButtonIcon
    UserControl_Resize
    Set m_ButtonIcon = PropBag.ReadProperty("ButtonIcon", Nothing)
    Set m_NoPicture = PropBag.ReadProperty("NoPicture", Nothing)
    Set m_OnPicture = PropBag.ReadProperty("OnPicture", Nothing)
    Set m_DownPicture = PropBag.ReadProperty("DownPicture", Nothing)
    m_UsePicture = PropBag.ReadProperty("UsePicture", m_def_UsePicture)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("ForeColor", L.ForeColor, &H80000012)
    Call PropBag.WriteProperty("Font", L.Font, Ambient.Font)
    Call PropBag.WriteProperty("Caption", L.Caption, "Label1")
    Call PropBag.WriteProperty("PicNoFocus", Picture, LoadResPicture(2000 + m_ButtonStyle, 0))
    Call PropBag.WriteProperty("PicGetFocus", Picture, LoadResPicture(2100 + m_ButtonStyle, 0))
    Call PropBag.WriteProperty("PicMouseDown", Picture, LoadResPicture(2200 + m_ButtonStyle, 0))
    Call PropBag.WriteProperty("ToolTipText", L.ToolTipText, "")
    Call PropBag.WriteProperty("ButtonStyle", m_ButtonStyle, m_def_ButtonStyle)
    If Not m_UsePicture Then
        BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
    Else
        BT.Picture = m_NoPicture
    End If
    Call PropBag.WriteProperty("ButtonIcon", Picture, Nothing)
'    Call PropBag.WriteProperty("ButtonIcon", m_ButtonIcon, Nothing)
    Call PropBag.WriteProperty("ButtonIcon", m_ButtonIcon, Nothing)
    Call PropBag.WriteProperty("NoPicture", m_NoPicture, Nothing)
    Call PropBag.WriteProperty("OnPicture", m_OnPicture, Nothing)
    Call PropBag.WriteProperty("DownPicture", m_DownPicture, Nothing)
    Call PropBag.WriteProperty("UsePicture", m_UsePicture, m_def_UsePicture)
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=L,L,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "返回/设置对象中文本和图形的前景色。"
    ForeColor = L.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    L.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=L,L,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "返回一个 Font 对象。"
Attribute Font.VB_UserMemId = -512
    Set Font = L.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set L.Font = New_Font
    PropertyChanged "Font"
End Property


'注意！不要删除或修改下列被注释的行！
'MappingInfo=L,L,-1,Caption
Public Property Get Caption() As String
Attribute Caption.VB_Description = "返回/设置对象的标题栏中或图标下面的文本。"
    Caption = L.Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
    L.Caption() = New_Caption
    SetAccessKeys
    PropertyChanged "Caption"
End Property

Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub BT_Click()
UserControl_Click
End Sub
Private Sub L_Click()
UserControl_Click
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub
Private Sub BT_DblClick()
UserControl_DblClick
End Sub
Private Sub L_DblClick()
UserControl_DblClick
End Sub
''
''注意！不要删除或修改下列被注释的行！
''MappingInfo=BT,BT,-1,ToolTipText
'Public Property Get ToolTipText() As String
'    ToolTipText = L.ToolTipText
'End Property
'

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get Style() As MnuStyle
Attribute Style.VB_Description = "按钮样式"
    ButtonStyle = m_ButtonStyle
End Property

Public Property Let Style(ByVal New_ButtonStyle As MnuStyle)
    m_ButtonStyle = New_ButtonStyle
    PropertyChanged "ButtonStyle"
    BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
    m_UsePicture = False
End Property

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
    LastKeyDown = KeyCode
    Select Case KeyCode
    Case 32 'spacebar pressed
        If Not m_UsePicture Then
            BT.Picture = LoadResPicture(2200 + m_ButtonStyle, 0)
        Else
            BT.Picture = m_DownPicture
        End If
        L.Top = (UserControl.Height / 2 - L.Height / 2) + 20
        Ico.Top = (UserControl.Height / 2 - Ico.Height / 2) + 20
        Md = True
        
    End Select

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, and not cancelled by the user
    If Not m_UsePicture Then
        BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
    Else
        BT.Picture = m_NoPicture
    End If
    
    L.Top = (UserControl.Height / 2 - L.Height / 2)
    Ico.Top = (UserControl.Height / 2 - Ico.Height / 2)
    Md = False
    RaiseEvent Click
End If
End Sub
''
'''注意！不要删除或修改下列被注释的行！
'''MappingInfo=Ico,Ico,-1,Picture
''Public Property Get ButtonIcon() As Picture
''    Set ButtonIcon = Ico.Picture
''End Property
''
''Public Property Set ButtonIcon(ByVal New_ButtonIcon As Picture)
''    Set Ico.Picture = New_ButtonIcon
''    PropertyChanged "ButtonIcon"
''End Property
''
''注意！不要删除或修改下列被注释的行！
''MemberInfo=11,0,0,0
'Public Property Get ButtonIcon() As Picture
'    Set ButtonIcon = m_ButtonIcon
'End Property
'
'Public Property Set ButtonIcon(ByVal New_ButtonIcon As Picture)
'    Set m_ButtonIcon = New_ButtonIcon
'    Ico.Picture = m_ButtonIcon
'    UserControl_Resize
'    PropertyChanged "ButtonIcon"
'End Property
Private Sub DoGrey(Icon As PictureBox)

    Dim Grey&
    Dim C1&, C2&
    Dim B&, G&, R&
    Dim H%, W%, pH%, pW%

       pH = Icon.Height - 1
       pW = Icon.Width - 1
       For H = 0 To pH
           For W = 0 To pW
               C1 = GetPixel(Icon.hdc, W, H)
               If C1 <> &HFFFFFF Then
                  B = C1 \ 65536
                  G = (C1 - B * 65536) \ 256
                  R = C1 - B * 65536 - G * 256
                  Grey = (222 * R + 707 * G + 71 * B) / 1000
                  R = Grey
                  G = Grey
                  B = Grey
                  SetPixelV Icon.hdc, W, H, RGB(R, G, B)
               End If
           Next
       Next
Icon.Picture = Icon.Image
End Sub


'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
Dim C1 As Long
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
    If New_Enabled = False Then
        C1 = L.ForeColor
        L.ForeColor = vb3DShadow
        PicTmp.Picture = Ico.Picture
        DoGrey PicTmp
        Ico.Picture = PicTmp.Picture
    Else
        L.ForeColor = C1
    End If
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=L,L,-1,ToolTipText
Public Property Get ToolTipText() As String
Attribute ToolTipText.VB_Description = "返回/设置当鼠标在控件上暂停时显示的文本。"
    ToolTipText = m_ToolTipText
End Property
Public Property Let ToolTipText(ByVal New_ToolTipText As String)
    m_ToolTipText = New_ToolTipText
    L.ToolTipText = m_ToolTipText
    BT.ToolTipText = m_ToolTipText
    PropertyChanged "ToolTipText"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=11,0,0,
Public Property Get ButtonIcon() As Picture
Attribute ButtonIcon.VB_Description = "返回/设置控件中显示的图形。"
    Set ButtonIcon = m_ButtonIcon
End Property

Public Property Set ButtonIcon(ByVal New_ButtonIcon As Picture)
    Set m_ButtonIcon = New_ButtonIcon
    PropertyChanged "ButtonIcon"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=11,0,0,0
Public Property Get NoPicture() As Picture
Attribute NoPicture.VB_Description = "按钮图片"
    Set NoPicture = m_NoPicture
End Property

Public Property Set NoPicture(ByVal New_NoPicture As Picture)
    Set m_NoPicture = New_NoPicture
    If m_UsePicture Then
        BT.Picture = m_NoPicture
    End If
    PropertyChanged "NoPicture"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=11,0,0,0
Public Property Get OnPicture() As Picture
Attribute OnPicture.VB_Description = "鼠标经过按钮时的图片"
    Set OnPicture = m_OnPicture
End Property

Public Property Set OnPicture(ByVal New_OnPicture As Picture)
    Set m_OnPicture = New_OnPicture
    PropertyChanged "OnPicture"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=11,0,0,0
Public Property Get DownPicture() As Picture
Attribute DownPicture.VB_Description = "按钮按下的图片"
    Set DownPicture = m_DownPicture
End Property

Public Property Set DownPicture(ByVal New_DownPicture As Picture)
    Set m_DownPicture = New_DownPicture
    PropertyChanged "DownPicture"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get UsePicture() As Boolean
    UsePicture = m_UsePicture
End Property

Public Property Let UsePicture(ByVal New_UsePicture As Boolean)
    m_UsePicture = New_UsePicture
    If Not m_UsePicture Then
        BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
    Else
        BT.Picture = m_NoPicture
    End If
    PropertyChanged "UsePicture"
End Property