用image做成command好了, 用两个image,话成一个是边框显出来的样子, 一个是平常样子,把他们放在一起写。 然后写 Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Image2.Visible = False Image1.Visible = True End SubPrivate Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Image1.Visible = False Image2.Visible = True End Sub
'这是微软提供的一个仿XP的Command控件。可以到微软的网站下载全套的。 VERSION 5.00 Object = "{27395F88-0C0C-101B-A3C9-08002B2F49FB}#1.1#0"; "PICCLP32.OCX" Begin VB.UserControl xpcmdbutton Appearance = 0 'Flat AutoRedraw = -1 'True BackColor = &H80000005& ClientHeight = 1155 ClientLeft = 0 ClientTop = 0 ClientWidth = 1695 DefaultCancel = -1 'True FillStyle = 0 'Solid ScaleHeight = 77 ScaleMode = 3 'Pixel ScaleWidth = 113 ToolboxBitmap = "xpcmdbutton.ctx":0000 Begin VB.Timer Timer1 Enabled = 0 'False Interval = 50 Left = 1200 Top = 480 End Begin PicClip.PictureClip pc Left = 105 Top = 555 _ExtentX = 2381 _ExtentY = 556 _Version = 393216 Cols = 5 Picture = "xpcmdbutton.ctx":0312 End Begin VB.Label lbl Alignment = 2 'Center Appearance = 0 'Flat AutoSize = -1 'True BackColor = &H80000005& BackStyle = 0 'Transparent Caption = "xpcmdbutton" ForeColor = &H80000008& Height = 180 Left = 435 TabIndex = 0 Top = 240 Width = 1005 End End Attribute VB_Name = "xpcmdbutton" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False 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 LongPublic Enum State_b Normal_ = 0 Default_ = 1 End EnumDim m_State As State_b Dim m_Font As FontConst m_Def_State = State_b.Normal_Private Type POINT_API X As Long Y As Long End TypeDim s As Integer Event Click() Attribute Click.VB_UserMemId = -600 Event KeyDown(KeyCode As Integer, Shift As Integer) Attribute KeyDown.VB_UserMemId = -602 Event KeyPress(KeyAscii As Integer) Attribute KeyPress.VB_UserMemId = -603 Event KeyUp(KeyCode As Integer, Shift As Integer) Attribute KeyUp.VB_UserMemId = -604 Event MouseOut() Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Attribute MouseDown.VB_UserMemId = -605 Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Attribute MouseMove.VB_UserMemId = -606 Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Attribute MouseUp.VB_UserMemId = -607Private Sub lbl_Change() UserControl_Resize End SubPrivate Sub lbl_Click() UserControl_Click End SubPrivate Sub lbl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Call UserControl_MouseDown(Button, Shift, X, Y) End SubPrivate Sub lbl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Call UserControl_MouseMove(Button, Shift, lbl.Left, lbl.Top) End SubPrivate Sub lbl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Call UserControl_MouseUp(Button, Shift, X, Y) End SubPrivate 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 SubPrivate Sub UserControl_AccessKeyPress(KeyAscii As Integer) RaiseEvent Click End SubPrivate Sub UserControl_Click() RaiseEvent Click End Sub
Private Sub UserControl_Initialize() statevalue_pic End SubPrivate Sub UserControl_InitProperties() state_value = m_Def_State Enabled = True Caption = Ambient.DisplayName Set Font = UserControl.Ambient.Font End SubPrivate Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer) RaiseEvent KeyDown(KeyCode, Shift) End SubPrivate Sub UserControl_KeyPress(KeyAscii As Integer) RaiseEvent KeyPress(KeyAscii) End SubPrivate Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer) RaiseEvent KeyUp(KeyCode, Shift) End SubPrivate Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseDown(Button, Shift, X, Y) make_xpbutton 1 End SubPrivate 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 SubPrivate Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseUp(Button, Shift, X, Y) statevalue_pic End SubPrivate 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 SubPublic Property Get Enabled() As Boolean Attribute Enabled.VB_ProcData.VB_Invoke_Property = ";Behavior" Attribute Enabled.VB_UserMemId = -514 Enabled = UserControl.Enabled End PropertyPublic 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 PropertyPrivate Sub UserControl_Resize() statevalue_pic lbl.Top = (UserControl.ScaleHeight - lbl.Height) / 2 lbl.Left = (UserControl.ScaleWidth - lbl.Width) / 2 End SubPrivate Sub UserControl_Show() statevalue_pic End SubPrivate Sub UserControl_Terminate() statevalue_pic End SubPrivate 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 SubPublic Property Get State() As State_b Attribute State.VB_Description = "Returns/sets the state of the command button when mouse_out." Attribute State.VB_ProcData.VB_Invoke_Property = ";Misc" State = m_State End PropertyPublic Property Let State(ByVal vNewValue As State_b) m_State = vNewValue PropertyChanged "State" statevalue_pic End PropertyPrivate 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 SubPrivate Sub make_xpbutton(z As Integer) UserControl.ScaleMode = 3 Dim brx, bry, bw, bh As Integer brx = UserControl.ScaleWidth - 3 bry = UserControl.ScaleHeight - 3 bw = UserControl.ScaleWidth - 6 bh = UserControl.ScaleHeight - 6
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, 15End SubPublic Property Get Caption() As String Attribute Caption.VB_ProcData.VB_Invoke_Property = ";Appearance" Attribute Caption.VB_UserMemId = -518 Caption = lbl.Caption End PropertyPublic Property Let Caption(ByVal vNewCaption As String) lbl.Caption() = vNewCaption PropertyChanged "Caption" End PropertyPublic Property Get Font() As Font Attribute Font.VB_UserMemId = -512 Set Font = m_Font End PropertyPublic 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
用两个image,话成一个是边框显出来的样子,
一个是平常样子,把他们放在一起写。
然后写
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image2.Visible = False
Image1.Visible = True
End SubPrivate Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image1.Visible = False
Image2.Visible = True
End Sub
Label 的left和Top边用白色线,right和bottom用黑色线。
在mouse move 时,让这四条线show ,mouse 过去后让它们hide.
VERSION 5.00
Object = "{27395F88-0C0C-101B-A3C9-08002B2F49FB}#1.1#0"; "PICCLP32.OCX"
Begin VB.UserControl xpcmdbutton
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H80000005&
ClientHeight = 1155
ClientLeft = 0
ClientTop = 0
ClientWidth = 1695
DefaultCancel = -1 'True
FillStyle = 0 'Solid
ScaleHeight = 77
ScaleMode = 3 'Pixel
ScaleWidth = 113
ToolboxBitmap = "xpcmdbutton.ctx":0000
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 50
Left = 1200
Top = 480
End
Begin PicClip.PictureClip pc
Left = 105
Top = 555
_ExtentX = 2381
_ExtentY = 556
_Version = 393216
Cols = 5
Picture = "xpcmdbutton.ctx":0312
End
Begin VB.Label lbl
Alignment = 2 'Center
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "xpcmdbutton"
ForeColor = &H80000008&
Height = 180
Left = 435
TabIndex = 0
Top = 240
Width = 1005
End
End
Attribute VB_Name = "xpcmdbutton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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 LongPublic Enum State_b
Normal_ = 0
Default_ = 1
End EnumDim m_State As State_b
Dim m_Font As FontConst m_Def_State = State_b.Normal_Private Type POINT_API
X As Long
Y As Long
End TypeDim s As Integer
Event Click()
Attribute Click.VB_UserMemId = -600
Event KeyDown(KeyCode As Integer, Shift As Integer)
Attribute KeyDown.VB_UserMemId = -602
Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_UserMemId = -603
Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_UserMemId = -604
Event MouseOut()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseDown.VB_UserMemId = -605
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseMove.VB_UserMemId = -606
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseUp.VB_UserMemId = -607Private Sub lbl_Change()
UserControl_Resize
End SubPrivate Sub lbl_Click()
UserControl_Click
End SubPrivate Sub lbl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseDown(Button, Shift, X, Y)
End SubPrivate Sub lbl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseMove(Button, Shift, lbl.Left, lbl.Top)
End SubPrivate Sub lbl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseUp(Button, Shift, X, Y)
End SubPrivate 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 SubPrivate Sub UserControl_AccessKeyPress(KeyAscii As Integer)
RaiseEvent Click
End SubPrivate Sub UserControl_Click()
RaiseEvent Click
End Sub
statevalue_pic
End SubPrivate Sub UserControl_InitProperties()
state_value = m_Def_State
Enabled = True
Caption = Ambient.DisplayName
Set Font = UserControl.Ambient.Font
End SubPrivate Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
End SubPrivate Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End SubPrivate Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
End SubPrivate Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseDown(Button, Shift, X, Y)
make_xpbutton 1
End SubPrivate 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 SubPrivate Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
statevalue_pic
End SubPrivate 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 SubPublic Property Get Enabled() As Boolean
Attribute Enabled.VB_ProcData.VB_Invoke_Property = ";Behavior"
Attribute Enabled.VB_UserMemId = -514
Enabled = UserControl.Enabled
End PropertyPublic 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 PropertyPrivate Sub UserControl_Resize()
statevalue_pic
lbl.Top = (UserControl.ScaleHeight - lbl.Height) / 2
lbl.Left = (UserControl.ScaleWidth - lbl.Width) / 2
End SubPrivate Sub UserControl_Show()
statevalue_pic
End SubPrivate Sub UserControl_Terminate()
statevalue_pic
End SubPrivate 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 SubPublic Property Get State() As State_b
Attribute State.VB_Description = "Returns/sets the state of the command button when mouse_out."
Attribute State.VB_ProcData.VB_Invoke_Property = ";Misc"
State = m_State
End PropertyPublic Property Let State(ByVal vNewValue As State_b)
m_State = vNewValue
PropertyChanged "State"
statevalue_pic
End PropertyPrivate 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 SubPrivate Sub make_xpbutton(z As Integer)
UserControl.ScaleMode = 3
Dim brx, bry, bw, bh As Integer brx = UserControl.ScaleWidth - 3
bry = UserControl.ScaleHeight - 3
bw = UserControl.ScaleWidth - 6
bh = UserControl.ScaleHeight - 6
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, 15End SubPublic Property Get Caption() As String
Attribute Caption.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute Caption.VB_UserMemId = -518
Caption = lbl.Caption
End PropertyPublic Property Let Caption(ByVal vNewCaption As String)
lbl.Caption() = vNewCaption
PropertyChanged "Caption"
End PropertyPublic Property Get Font() As Font
Attribute Font.VB_UserMemId = -512
Set Font = m_Font
End PropertyPublic 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