VB图片动态按钮控件

'新建一个ActiveX控件工程，粘贴以下代码：
Option Explicit
Private Declare Function GetCursorPos Lib “user32” (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib “user32” (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim Zt As String, Dx As Integer, Ct As Boolean, Xt As Boolean, Scx As Boolean, Xhx As Boolean
Dim Pic As stdole.IPictureDisp '定义图片
Dim WithEvents Tim As Timer '计时器
Dim W As Long, H As Long '图片大小（分割后单张）
Dim txt As String '标题
Dim But As Integer
Dim Sw As OLE_TRISTATE
Dim Butss As Boolean
Public Event Click()
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Private Sub UserControl_Initialize()
UserControl.AutoRedraw = True
Set Tim = Controls.Add(“vb.Timer”, “Tim”)
W = 250
H = 250
UserControl.BackColor = RGB(60, 60, 60)
Sw = Checked
End Sub

Private Sub UserControl_Resize()
If Enabled = True Then
Call JiexuanPic(0)
Else
Call JiexuanPic(2)
End If
UserControl.Width = W: UserControl.Height = H
End Sub

'颜色
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property

Public Property Let ForeColor(ByVal vNewValue As OLE_COLOR)
UserControl.ForeColor = vNewValue
Call txtStr(txt)
PropertyChanged “ForeColor”
End Property

'图片
Public Property Get Picture() As StdPicture
Set Picture = Pic
End Property

Public Property Set Picture(ByVal vNewValue As StdPicture)
Set Pic = vNewValue
Call JiexuanPic(0)
UserControl.Width = W: UserControl.Height = H
PropertyChanged “Picture”
End Property

Private Function JiexuanPic(N As Integer) '分割图片
On Error GoTo er
UserControl.Cls
If N = 0 Then
UserControl.PaintPicture Pic, 0, 0, Int(ScaleX(Pic.Width)) / 3, Pic.Height, 0, 0, Int(ScaleX(Pic.Width)) / 3, Pic.Height
ElseIf N = 1 Then
UserControl.PaintPicture Pic, 0, 0, Int(ScaleX(Pic.Width)) / 3, Pic.Height, Int(ScaleX(Pic.Width)) / 3, 0, Int(ScaleX(Pic.Width)) / 3, Pic.Height
ElseIf N = 2 Then
UserControl.PaintPicture Pic, 0, 0, Int(ScaleX(Pic.Width)) / 3, Pic.Height, Int(ScaleX(Pic.Width)) / 3 * 2, 0, Int(ScaleX(Pic.Width)) / 3, Pic.Height
End If
W = Int(ScaleX(Pic.Width)) / 3: H = Int(ScaleY(Pic.Height))
er:
Call txtStr(txt)
End Function

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
But = Button: Butss = True
If But = 1 Then Call JiexuanPic(2)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
If But = 1 Then Exit Sub
If (X > 0 And X < UserControl.Width) And (Y > 0 And Y < UserControl.Height) Then
Tim.Interval = 1
Call JiexuanPic(1)
End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button > 1 Then Exit Sub
Call JiexuanPic(0)
But = 0
If Button = 1 And Butss = True And (X > 0 And X < UserControl.Width) And (Y > 0 And Y < UserControl.Height) Then
RaiseEvent Click
End If
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag) '读
UserControl.ForeColor = PropBag.ReadProperty(“ForeColor”, RGB(255, 255, 255))
Set Pic = PropBag.ReadProperty(“Picture”, Nothing)
txt = PropBag.ReadProperty(“txt”, “”)
UserControl.Enabled = PropBag.ReadProperty(“Enabled”, “True”)
UserControl.MousePointer = PropBag.ReadProperty(“MousePointer”, 0)
Sw = PropBag.ReadProperty(“SiteWord”, 0)

Zt = PropBag.ReadProperty(“Zt”, “”)
Dx = PropBag.ReadProperty(“Dx”, 9)
Ct = PropBag.ReadProperty(“Ct”, “False”)
Xt = PropBag.ReadProperty(“Xt”, “False”)
Scx = PropBag.ReadProperty(“Scx”, “False”)
Xhx = PropBag.ReadProperty(“Xhx”, “False”)

UserControl.Font.Name = Zt
If Dx > 0 Then
UserControl.Font.Size = Val(Dx)
Else
UserControl.Font.Size = UserControl.FontSize
End If
UserControl.Font.Bold = Ct
UserControl.Font.Italic = Xt
UserControl.Font.Strikethrough = Scx
UserControl.Font.Underline = Xhx

Call JiexuanPic(0)
Call txtStr(txt)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag) '存
Call PropBag.WriteProperty(“ForeColor”, UserControl.ForeColor, RGB(255, 255, 255))
Call PropBag.WriteProperty(“Picture”, Pic, Nothing)
Call PropBag.WriteProperty(“txt”, txt, “”)
Call PropBag.WriteProperty(“Enabled”, UserControl.Enabled, “True”)

Call PropBag.WriteProperty(“Zt”, Zt, “”)
Call PropBag.WriteProperty(“Dx”, Dx, 9)
Call PropBag.WriteProperty(“Ct”, Ct, “False”)
Call PropBag.WriteProperty(“Xt”, Xt, “False”)
Call PropBag.WriteProperty(“Scx”, Scx, “False”)
Call PropBag.WriteProperty(“Xhx”, Xhx, “False”)

Call PropBag.WriteProperty(“MousePointer”, UserControl.MousePointer, 0)
Call PropBag.WriteProperty(“SiteWord”, Sw, 0)
End Sub

Private Sub Tim_Timer()
Dim R As RECT, P As POINTAPI
Call GetWindowRect(UserControl.hwnd, R)
Call GetCursorPos§
If P.X < R.Left Or P.X > R.Right Or P.Y < R.Top Or P.Y > R.Bottom Then
Call JiexuanPic(0)
But = 0: Butss = False
Tim.Interval = 0
End If
End Sub

Public Property Get Caption() As String
Caption = txt
End Property

Public Property Let Caption(ByVal vNewValue As String)
txt = vNewValue
UserControl.Cls
Call JiexuanPic(0)
Call txtStr(vNewValue)
PropertyChanged “Caption”
End Property

Private Sub txtStr(t As String) '标题
If Sw = 0 Then
UserControl.CurrentX = 0
ElseIf Sw = 1 Then
UserControl.CurrentX = (UserControl.Width - UserControl.TextWidth(t)) / 2
ElseIf Sw = 2 Then
UserControl.CurrentX = UserControl.Width - UserControl.TextWidth(t)
End If
UserControl.CurrentY = (UserControl.Height - UserControl.TextHeight(t)) / 2
UserControl.Print t
End Sub

Public Property Get Enabled() As OLE_CANCELBOOL
Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal vNewValue As OLE_CANCELBOOL)
UserControl.Enabled = vNewValue
If Enabled = True Then
Call JiexuanPic(0)
Else
Call JiexuanPic(2)
End If
PropertyChanged “Enabled”
End Property

'------------------------------------------------------------------------

Public Property Get Font() As StdFont
Set Font = UserControl.Font
End Property

Public Property Set Font(mnewFont As StdFont)
Zt = mnewFont.Name
Dx = mnewFont.Size
Ct = mnewFont.Bold
Xt = mnewFont.Italic
Scx = mnewFont.Strikethrough
Xhx = mnewFont.Underline

UserControl.FontName = Zt
UserControl.FontSize = Dx
UserControl.FontBold = Ct
UserControl.FontItalic = Xt
UserControl.FontStrikethru = Scx
UserControl.FontUnderline = Xhx

Call JiexuanPic(0)
Call txtStr(txt)
PropertyChanged “Font”
End Property
'---------------------------------------------------------------//

Public Property Get MousePointer() As MousePointerConstants
MousePointer = UserControl.MousePointer
End Property

Public Property Let MousePointer(ByVal vNewValue As MousePointerConstants)
UserControl.MousePointer = vNewValue
End Property

Public Property Get SiteWord() As OLE_TRISTATE
SiteWord = Sw
End Property

Public Property Let SiteWord(ByVal vNewValue As OLE_TRISTATE)
UserControl.Cls
Sw = vNewValue
Call JiexuanPic(0)
Call txtStr(txt)
PropertyChanged “SiteWord”
End Property

'将控件拉到Form窗体上，在属性Picture导入提前做好的图片(用PS做一张三格的图片)即可。