• 欢迎访问金刀客博客!
  • 2019,春节快乐!

一个不错的VB按钮控件xpcmdbutton

精品收藏 admin 9866次浏览 已收录 0个评论

一个不错的按钮,今天终于修正了屏蔽右键和点击空白无效的问题,感谢VBGOOD的兄弟,就不一一列名字了!
xpcmdbutton:点击下载此文件
修正后的源码如下:
‘Created by Teh Ming Han (teh_minghan@hotmail.com)
‘Option Explicit
Private Declare Function GetCursorPos Lib “user32” (lpPoint As POINT_API) As Long
Private Declare Function ScreenToClient Lib “user32” (ByVal hWnd As Long, lpPoint As POINT_API) As Long
Public Enum State_b
Normal_ = 0
Default_ = 1
End Enum
Dim m_State As State_b
Dim m_Font As Font
Const m_Def_State = State_b.Normal_
Private Type POINT_API
x As Long
y As Long
End Type
Dim s As Integer
Event Click()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseOut()
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Private m_left As Integer
Private Sub lbl_Change()
UserControl_Resize
End Sub
Private Sub lbl_Click()
UserControl_Click
End Sub
Private Sub lbl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
m_left = Button
If m_left = 1 Then Call UserControl_MouseDown(Button, Shift, x, y)
‘ Call UserControl_MouseDown(Button, Shift, x, y)
End Sub
Private Sub lbl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Call UserControl_MouseMove(Button, Shift, x, y)
End Sub
Private Sub lbl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Call UserControl_MouseUp(Button, Shift, x, y)
End Sub
Private Sub Timer1_Timer()
Dim pnt As POINT_API
GetCursorPos pnt
ScreenToClient UserControl.hWnd, pnt
If pnt.x < UserControl.ScaleLeft or _ pnt.y < UserControl.ScaleTop or _ pnt.x > (UserControl.ScaleLeft + UserControl.ScaleWidth) or _
pnt.y > (UserControl.ScaleTop + UserControl.ScaleHeight) Then
Timer1.Enabled = False
RaiseEvent MouseOut
statevalue_pic
End If
End Sub
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
RaiseEvent Click
End Sub
Private Sub UserControl_Click()
If m_left = 1 Then RaiseEvent Click
‘ RaiseEvent Click
End Sub
Private Sub UserControl_Initialize()
statevalue_pic
End Sub
Private Sub UserControl_InitProperties()
state_value = m_Def_State
Enabled = True
Caption = Ambient.DisplayName
Set Font = UserControl.Ambient.Font
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)
m_left = Button
If m_left = 1 Then RaiseEvent MouseDown(Button, Shift, x, y)
make_xpbutton 1
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer1.Enabled = True
If x >= 0 And y >= 0 And _
x <= UserControl.ScaleWidth And y <= UserControl.ScaleHeight Then RaiseEvent MouseMove(Button, Shift, x, y) If Button = vbLeftButton Then make_xpbutton 1 Else: make_xpbutton 3 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) statevalue_pic End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) state_value = PropBag.ReadProperty("State", m_Def_State) Enabled = PropBag.ReadProperty("Enabled", True) Caption = PropBag.ReadProperty("Caption", Ambient.DisplayName) Set Font = PropBag.ReadProperty("Font", UserControl.Ambient.Font) End Sub Public Property Get Enabled() As Boolean Enabled = UserControl.Enabled End Property Public Property Let Enabled(ByVal New_Enabled As Boolean) UserControl.Enabled() = New_Enabled PropertyChanged "Enabled" statevalue_pic If Enabled = True Then lbl.ForeColor = vbBlack Else lbl.ForeColor = RGB(161, 161, 146) End Property Private Sub UserControl_Resize() statevalue_pic lbl.Top = (UserControl.ScaleHeight - lbl.Height) / 2 lbl.Left = (UserControl.ScaleWidth - lbl.Width) / 2 End Sub Private Sub UserControl_Show() statevalue_pic End Sub Private Sub UserControl_Terminate() statevalue_pic End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("State", m_State, m_Def_State) Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True) Call PropBag.WriteProperty("Caption", lbl.Caption, Ambient.DisplayName) Call PropBag.WriteProperty("Font", m_Font, UserControl.Ambient.Font) End Sub Public Property Get State() As State_b State = m_State End Property Public Property Let State(ByVal vNewValue As State_b) m_State = vNewValue PropertyChanged "State" statevalue_pic End Property Private Sub statevalue_pic() If State = Default_ Then s = 4 ElseIf State = Normal_ Then s = 0 End If If UserControl.Enabled = True Then make_xpbutton s Else: make_xpbutton 2 End If End Sub Private Sub make_xpbutton(z As Integer) UserControl.ScaleMode = 3 'Draw in pixels Dim brx, bry, bw, bh As Integer 'Short cuts brx = UserControl.ScaleWidth - 3 'right x bry = UserControl.ScaleHeight - 3 'right y bw = UserControl.ScaleWidth - 6 'border width - corners width bh = UserControl.ScaleHeight - 6 'border height - corners height 'Draws button 'Goes clockwise first for corners(first four) 'followed by borders(next four) and center(last step). UserControl.PaintPicture pc.GraphicCell(z), 0, 0, 3, 3, 0, 0, 3, 3 UserControl.PaintPicture pc.GraphicCell(z), brx, 0, 3, 3, 15, 0, 3, 3 UserControl.PaintPicture pc.GraphicCell(z), brx, bry, 3, 3, 15, 18, 3, 3 UserControl.PaintPicture pc.GraphicCell(z), 0, bry, 3, 3, 0, 18, 3, 3 UserControl.PaintPicture pc.GraphicCell(z), 3, 0, bw, 3, 3, 0, 12, 3 UserControl.PaintPicture pc.GraphicCell(z), brx, 3, 3, bh, 15, 3, 3, 15 UserControl.PaintPicture pc.GraphicCell(z), 0, 3, 3, bh, 0, 3, 3, 15 UserControl.PaintPicture pc.GraphicCell(z), 3, bry, bw, 3, 3, 18, 12, 3 UserControl.PaintPicture pc.GraphicCell(z), 3, 3, bw, bh, 3, 3, 12, 15 End Sub Public Property Get Caption() As String Caption = lbl.Caption End Property Public Property Let Caption(ByVal vNewCaption As String) lbl.Caption() = vNewCaption PropertyChanged "Caption" End Property Public Property Get Font() As Font Set Font = m_Font End Property Public Property Set Font(ByVal vNewFont As Font) Set m_Font = vNewFont Set UserControl.Font = vNewFont Set lbl.Font = m_Font Call UserControl_Resize PropertyChanged "Font" End Property


金刀客博客 , 版权所有丨如未注明 , 均为原创丨本网站采用BY-NC-SA协议进行授权 , 转载请注明一个不错的VB按钮控件xpcmdbutton
喜欢 (12)
发表我的评论
取消评论

表情 贴图 加粗 删除线 居中 斜体 签到