--------------注：本文转载于Office精英俱乐部 ，作者Coming-----------------
写在前面：这个编写过程只是用几幅图片画出按钮，不是用填充渐变色的 API 函数来绘制按钮的。因为这样比较简单，如果有兴趣的朋友可以自己研究一下渐变填充颜色的 API 函数进行自定义按钮的绘制，这样可以编出不同样式的按钮。
由于本人所学不精，难免有遗漏或不合理的地方。希望大家多多斧正。废话少说，转入正题。
这里写了十个步聚，分别为：
一、选择工程
二、添加用户控件
三、为用户控件添加不同状态下的图片
四、定义模块级别变量用于储存属性值等数据
五、编写重画按钮的过程：ReDraw
六、为按钮定义属性
七、为按钮定义事件并响应控件事件
八、为按钮的各个属性添加描述
九、添加类似普通按钮“Command1 = True”执行其“Click”事件。
十、为按钮添加工具栏小图标。
详细情况：
一、选择工程
决定一个程序使用的自定义控件是在内部使用还是使用“ActiveX 控件”。
1、内部使用自定义控件：请打开要使用该控件的工程，如“工程1.VBP”。
2、打开VB6，文件新建工程选择“ActiveX 控件”。确定。
二、添加用户控件
（一）添加用户控件
如果新建“AcitveX 控件”工程，则默认会新建一个用户控件“UserControl1”。
如果要在程序内部使用控件，请在菜单中的“工程”“添加用户控件”。或者在工程资源管理器中点右键，“添加”“添加用户控件”。
我们把控件改名为“CMCommandButton”，以下叫它为“按钮”
（二）设置控件属性
1、CanGetFocus：决定是否接收焦点。这里设为“TRUE”。
2、ClipControls：重画整个对象还是重画新显示的区域。这里设为“False”。
3、ControlContainer：决定是否能像“Frame”控件一样放置别的控件。这里设为“False”。
4、DefaultCancel：决定能否作为标准命令按钮使用。这里设为“True”。
5、ScaleMode：对象坐标度量单位。这里设为“3 – Pixel”（像素）。
6、其它属性默认。
三、为用户控件添加不同状态下的图片
用PhotoShop的“渐变填充、描边、内发光”等效果做了四张图片，分别为“正常、指向、按下、无效”状态下的图片。
分别放在Iamge控件组“img(0)”至“img(3)”中。
四、定义模块级别变量用于储存属性值等数据
复制内容到剪贴板
五、编写重画按钮的过程：ReDraw
代码:
'定义一个私有枚举，用于标识按钮的当前状态
Private Enum ButtonState
BS_Normal = 0
BS_Point = 1
BS_Press = 2
BS_Disabled = 3
End Enum
'定义一个变量，用于存放按钮的当前状态
Private mState As ButtonState
'定义一个变量，用于存放按钮是否获得焦点
Private mblnFocus As Boolean
'定义一个变量，用于存放按钮的 Caption 属性
Private mstrCaption As String
'定义一个变量，用于存放按钮的 ForeColor 属性
Private mForeColor As OLE_COLOR
'定义一个变量，用于存放在按钮中按下空格后是否再按了 Esc 键
Private mblnCancel As Boolean
Private Enum ButtonState
BS_Normal = 0
BS_Point = 1
BS_Press = 2
BS_Disabled = 3
End Enum
'定义一个变量，用于存放按钮的当前状态
Private mState As ButtonState
'定义一个变量，用于存放按钮是否获得焦点
Private mblnFocus As Boolean
'定义一个变量，用于存放按钮的 Caption 属性
Private mstrCaption As String
'定义一个变量，用于存放按钮的 ForeColor 属性
Private mForeColor As OLE_COLOR
'定义一个变量，用于存放在按钮中按下空格后是否再按了 Esc 键
Private mblnCancel As Boolean
复制内容到剪贴板
六、为按钮定义属性
代码:
'*****************************************五、编写重画控件的过程：ReDraw
'重画控件
Private Sub ReDraw()
Dim lngWidth As Long '按钮长度
Dim lngHeight As Long '按钮高度
Dim lngCantWidth As Long '按钮四个角的长度
Dim lngCantHeight As Long '按钮四个角的高度
With UserControl 'UserControl 代表当前按钮，不能用 Me 来代替。
.Cls '清除控件背景图片和文本
lngWidth = .ScaleWidth '按钮内部长度
lngHeight = .ScaleHeight '按钮内部高度
'**********************************************************************************
'根据按钮状态，选用不同图片绘制到按钮中。
'因为按钮图片的边框是不同于中部的。
'如果直接全部 PaintPicture 上去而且按钮大于或小于图片的大小时，
'边框的线条将会被放大或缩小，而且可能上下边框和左右边框的线条不同粗细，
'影响了按钮的美观。所以要先把按钮的左上角、右上角、左下角、右下角画上去，
'然后再画上下边框和左右边框。因为左上角、右上角、左下角、右下角是按1:1画到按钮；
'上下边框以高度1:1，宽度拉伸到左右两个角；左右边框以宽度1：1，高度拉伸到上下两个角。
'所以边框线看起来就跟原图片一致大小。
'再把图片中部画上去，按钮的主体就出来了。
'**********************************************************************************
'--------------------------------------
'因为这里的图片边框（包括内部发光，即图
'片有内外两条边框）为 2 像素，有时候按
'钮的高度或长度会小于 4 像素，所以这里
'用了一个条件判断：当按钮的宽度大小 4 像
'素的时候，左右边框的宽度就等于 2 ，否则
'左右边框宽度等于按钮宽度的一半。上下边框
'也然。
'-------------------------------------
lngCantWidth = IIf(lngWidth > 4, 2, lngWidth / 2) '按钮四个角、左右边框的长度
lngCantHeight = IIf(lngHeight > 4, 2, lngHeight / 2) '按钮四个角、上下边框的高度
'-------------------------------------
'开始绘制按钮了。img(mState)：图片是用
'Image 控件组存放的，根据 mState 的值
'调用相应的图片进行绘制。
'-------------------------------------
'+++++++++++++++++++++++++++++++++++++
'PaintPicture picture,x1, y1, width1, height1, x2, y2, width2, height2, opcode
'Picture:图片
'X1:按钮中要绘图的 X 坐标值。
'Y1:按钮中要绘图的 Y 坐标值。
'Width1:按钮中要绘图的宽度。
'Height1:按钮中要绘图的高度。
'X2:从图片中取出的区域的 X 坐标值。
'Y2:从图片中取出的区域的 Y 坐标值。
'Width2:从图片中取出的区域的宽度。
'Height2:从图片中取出的区域的高度。
'+++++++++++++++++++++++++++++++++++++
'绘制左上角
.PaintPicture img(mState), 0, 0, lngCantWidth, lngCantHeight, 0, 0, 2, 2
'绘制右上角
.PaintPicture img(mState), lngWidth - lngCantWidth, 0, lngCantWidth, lngCantHeight, 72, 0, 2, 2
'绘制左下角
.PaintPicture img(mState), 0, lngHeight - lngCantHeight, lngCantWidth, lngCantHeight, 0, 20, 2, 2
'绘制右下角
.PaintPicture img(mState), lngWidth - lngCantWidth, lngHeight - lngCantHeight, lngCantWidth, lngCantHeight, 72, 20, 2, 2
If lngWidth > 4 Then
'绘制上部
.PaintPicture img(mState), lngCantWidth, 0, lngWidth - lngCantWidth * 2, lngCantHeight, 2, 0, 70, 2
'绘制下部
.PaintPicture img(mState), lngCantWidth, lngHeight - lngCantHeight, lngWidth - lngCantWidth * 2, lngCantHeight, 2, 20, 70, 2
End If
If lngHeight > 4 Then
'绘制左边
.PaintPicture img(mState), 0, lngCantHeight, lngCantWidth, lngHeight - lngCantHeight * 2, 0, 2, 2, 18
'绘制右边
.PaintPicture img(mState), lngWidth - lngCantWidth, lngCantHeight, lngCantWidth, lngHeight - lngCantHeight * 2, 72, 2, 2, 18
End If
If lngWidth > 4 And lngHeight > 4 Then
'绘制中部
.PaintPicture img(mState), lngCantWidth, lngCantHeight, lngWidth - lngCantWidth * 2, lngHeight - lngCantHeight * 2, 2, 2, 70, 18
End If
'**********************************************************************************
'按钮的图片已经绘制好了，现在要写上按钮的 Caption 了。这里用了 API 函数 DrawText 。
'先声明一下。然后根据按钮的 Enabled 属性判断文字的颜色。再写上文字就 OK 了。
'**********************************************************************************
If Len(mstrCaption) > 0 Then '当 Caption 不为空时绘制文本。
'如果按钮的 Enabled 属性为 True 时用原来的文字颜色，
'为 False 时，使用“无效文本”的颜色作为按钮文本的颜色。
If .Enabled Then
.ForeColor = mForeColor
Else
.ForeColor = vbGrayText
End If
Dim lpRect As RECT '为方便大家阅读，把定义变量的代码放在这里。
With lpRect
If mState <> BS_Press Then
'因为按钮的边框为 2 像素，焦点框离按钮边框 3 像素。
'所以绘制文字的区域要离按钮边框 5 像素，才不会搞在一起：）
.Top = 5
.Bottom = lngHeight - 5
.Left = 5
.Right = lngWidth - 5
Else
'当按钮为按下状态时，文字向右、向下各移 2 像素，动感一点。
.Top = 7
.Bottom = lngHeight - 3
.Left = 7
.Right = lngWidth - 3
End If
End With
'---------------DrawText---------------
'hDC:要绘制文本的场景
'lpStr:要绘制的文本
'nCount:绘制的文本的长度，如果为 -1 ，则绘制 lpStr 全部内部
'lpRect:绘制文本的位置
'wFormat:绘制文本的样式（DT_CENTER 水平居中，DT_VCENTER 垂直居中，DT_SINGLELINE 单行）
DrawText .hDC, mstrCaption, -1, lpRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
End If
'**********************************************************************************
'按钮的图片和文本已经绘制好了，现在要画焦点框了。这里用了 API 函数 DrawFocusRect
'先声明一下。
'**********************************************************************************
If mblnFocus Then
Dim lpFocus As GIVEFOCUS
With lpFocus
.Bottom = lngHeight - 3
.Left = 3
.Right = lngWidth - 3
.Top = 3
End With
DrawFocusRect .hDC, lpFocus
End If
End With
End Sub
'重画控件
Private Sub ReDraw()
Dim lngWidth As Long '按钮长度
Dim lngHeight As Long '按钮高度
Dim lngCantWidth As Long '按钮四个角的长度
Dim lngCantHeight As Long '按钮四个角的高度
With UserControl 'UserControl 代表当前按钮，不能用 Me 来代替。
.Cls '清除控件背景图片和文本
lngWidth = .ScaleWidth '按钮内部长度
lngHeight = .ScaleHeight '按钮内部高度
'**********************************************************************************
'根据按钮状态，选用不同图片绘制到按钮中。
'因为按钮图片的边框是不同于中部的。
'如果直接全部 PaintPicture 上去而且按钮大于或小于图片的大小时，
'边框的线条将会被放大或缩小，而且可能上下边框和左右边框的线条不同粗细，
'影响了按钮的美观。所以要先把按钮的左上角、右上角、左下角、右下角画上去，
'然后再画上下边框和左右边框。因为左上角、右上角、左下角、右下角是按1:1画到按钮；
'上下边框以高度1:1，宽度拉伸到左右两个角；左右边框以宽度1：1，高度拉伸到上下两个角。
'所以边框线看起来就跟原图片一致大小。
'再把图片中部画上去，按钮的主体就出来了。
'**********************************************************************************
'--------------------------------------
'因为这里的图片边框（包括内部发光，即图
'片有内外两条边框）为 2 像素，有时候按
'钮的高度或长度会小于 4 像素，所以这里
'用了一个条件判断：当按钮的宽度大小 4 像
'素的时候，左右边框的宽度就等于 2 ，否则
'左右边框宽度等于按钮宽度的一半。上下边框
'也然。
'-------------------------------------
lngCantWidth = IIf(lngWidth > 4, 2, lngWidth / 2) '按钮四个角、左右边框的长度
lngCantHeight = IIf(lngHeight > 4, 2, lngHeight / 2) '按钮四个角、上下边框的高度
'-------------------------------------
'开始绘制按钮了。img(mState)：图片是用
'Image 控件组存放的，根据 mState 的值
'调用相应的图片进行绘制。
'-------------------------------------
'+++++++++++++++++++++++++++++++++++++
'PaintPicture picture,x1, y1, width1, height1, x2, y2, width2, height2, opcode
'Picture:图片
'X1:按钮中要绘图的 X 坐标值。
'Y1:按钮中要绘图的 Y 坐标值。
'Width1:按钮中要绘图的宽度。
'Height1:按钮中要绘图的高度。
'X2:从图片中取出的区域的 X 坐标值。
'Y2:从图片中取出的区域的 Y 坐标值。
'Width2:从图片中取出的区域的宽度。
'Height2:从图片中取出的区域的高度。
'+++++++++++++++++++++++++++++++++++++
'绘制左上角
.PaintPicture img(mState), 0, 0, lngCantWidth, lngCantHeight, 0, 0, 2, 2
'绘制右上角
.PaintPicture img(mState), lngWidth - lngCantWidth, 0, lngCantWidth, lngCantHeight, 72, 0, 2, 2
'绘制左下角
.PaintPicture img(mState), 0, lngHeight - lngCantHeight, lngCantWidth, lngCantHeight, 0, 20, 2, 2
'绘制右下角
.PaintPicture img(mState), lngWidth - lngCantWidth, lngHeight - lngCantHeight, lngCantWidth, lngCantHeight, 72, 20, 2, 2
If lngWidth > 4 Then
'绘制上部
.PaintPicture img(mState), lngCantWidth, 0, lngWidth - lngCantWidth * 2, lngCantHeight, 2, 0, 70, 2
'绘制下部
.PaintPicture img(mState), lngCantWidth, lngHeight - lngCantHeight, lngWidth - lngCantWidth * 2, lngCantHeight, 2, 20, 70, 2
End If
If lngHeight > 4 Then
'绘制左边
.PaintPicture img(mState), 0, lngCantHeight, lngCantWidth, lngHeight - lngCantHeight * 2, 0, 2, 2, 18
'绘制右边
.PaintPicture img(mState), lngWidth - lngCantWidth, lngCantHeight, lngCantWidth, lngHeight - lngCantHeight * 2, 72, 2, 2, 18
End If
If lngWidth > 4 And lngHeight > 4 Then
'绘制中部
.PaintPicture img(mState), lngCantWidth, lngCantHeight, lngWidth - lngCantWidth * 2, lngHeight - lngCantHeight * 2, 2, 2, 70, 18
End If
'**********************************************************************************
'按钮的图片已经绘制好了，现在要写上按钮的 Caption 了。这里用了 API 函数 DrawText 。
'先声明一下。然后根据按钮的 Enabled 属性判断文字的颜色。再写上文字就 OK 了。
'**********************************************************************************
If Len(mstrCaption) > 0 Then '当 Caption 不为空时绘制文本。
'如果按钮的 Enabled 属性为 True 时用原来的文字颜色，
'为 False 时，使用“无效文本”的颜色作为按钮文本的颜色。
If .Enabled Then
.ForeColor = mForeColor
Else
.ForeColor = vbGrayText
End If
Dim lpRect As RECT '为方便大家阅读，把定义变量的代码放在这里。
With lpRect
If mState <> BS_Press Then
'因为按钮的边框为 2 像素，焦点框离按钮边框 3 像素。
'所以绘制文字的区域要离按钮边框 5 像素，才不会搞在一起：）
.Top = 5
.Bottom = lngHeight - 5
.Left = 5
.Right = lngWidth - 5
Else
'当按钮为按下状态时，文字向右、向下各移 2 像素，动感一点。
.Top = 7
.Bottom = lngHeight - 3
.Left = 7
.Right = lngWidth - 3
End If
End With
'---------------DrawText---------------
'hDC:要绘制文本的场景
'lpStr:要绘制的文本
'nCount:绘制的文本的长度，如果为 -1 ，则绘制 lpStr 全部内部
'lpRect:绘制文本的位置
'wFormat:绘制文本的样式（DT_CENTER 水平居中，DT_VCENTER 垂直居中，DT_SINGLELINE 单行）
DrawText .hDC, mstrCaption, -1, lpRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
End If
'**********************************************************************************
'按钮的图片和文本已经绘制好了，现在要画焦点框了。这里用了 API 函数 DrawFocusRect
'先声明一下。
'**********************************************************************************
If mblnFocus Then
Dim lpFocus As GIVEFOCUS
With lpFocus
.Bottom = lngHeight - 3
.Left = 3
.Right = lngWidth - 3
.Top = 3
End With
DrawFocusRect .hDC, lpFocus
End If
End With
End Sub
复制内容到剪贴板
七、为按钮定义事件并响应控件事件代码:
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'设置控件加速键
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub SetAccessKey()
Dim lngPosition As Long
Dim strCaption As String
Dim strKey As String * 1
UserControl.AccessKeys = ""
If Len(mstrCaption) <> 0 Then
strCaption = Replace(mstrCaption, "&&", "")
lngPosition = InStr(1, strCaption, "&", vbTextCompare)
If lngPosition <> 0 Then
If lngPosition < Len(strCaption) Then
strKey = Mid(strCaption, lngPosition + 1, 1)
If (Asc(strKey) >= 65 And Asc(strKey) <= 90) Or (Asc(strKey) >= 97 And Asc(strKey) <= 122) Then
UserControl.AccessKeys = LCase(strKey)
End If
End If
End If
End If
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'标题
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get Caption() As String
Caption = mstrCaption
End Property
Public Property Let Caption(ByVal NewValue As String)
If mstrCaption <> NewValue Then
mstrCaption = NewValue
Call SetAccessKey
Call ReDraw
PropertyChanged "Caption"
End If
End Property
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'可用
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal NewValue As Boolean)
If UserControl.Enabled <> NewValue Then
UserControl.Enabled = NewValue
mState = IIf(NewValue, BS_Normal, BS_Disabled)
If NewValue = False Then
mblnFocus = False
End If
Call ReDraw
PropertyChanged "Enabled"
End If
End Property
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'字体
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get Font() As Font
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal NewValue As Font)
Set UserControl.Font = NewValue
Call ReDraw
PropertyChanged "Font"
End Property
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'字体颜色
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get ForeColor() As OLE_COLOR
ForeColor = mForeColor
End Property
Public Property Let ForeColor(ByVal NewValue As OLE_COLOR)
If mForeColor <> NewValue Then
mForeColor = NewValue
Call ReDraw
PropertyChanged "ForeColor"
End If
End Property
'设置控件加速键
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub SetAccessKey()
Dim lngPosition As Long
Dim strCaption As String
Dim strKey As String * 1
UserControl.AccessKeys = ""
If Len(mstrCaption) <> 0 Then
strCaption = Replace(mstrCaption, "&&", "")
lngPosition = InStr(1, strCaption, "&", vbTextCompare)
If lngPosition <> 0 Then
If lngPosition < Len(strCaption) Then
strKey = Mid(strCaption, lngPosition + 1, 1)
If (Asc(strKey) >= 65 And Asc(strKey) <= 90) Or (Asc(strKey) >= 97 And Asc(strKey) <= 122) Then
UserControl.AccessKeys = LCase(strKey)
End If
End If
End If
End If
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'标题
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get Caption() As String
Caption = mstrCaption
End Property
Public Property Let Caption(ByVal NewValue As String)
If mstrCaption <> NewValue Then
mstrCaption = NewValue
Call SetAccessKey
Call ReDraw
PropertyChanged "Caption"
End If
End Property
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'可用
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal NewValue As Boolean)
If UserControl.Enabled <> NewValue Then
UserControl.Enabled = NewValue
mState = IIf(NewValue, BS_Normal, BS_Disabled)
If NewValue = False Then
mblnFocus = False
End If
Call ReDraw
PropertyChanged "Enabled"
End If
End Property
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'字体
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get Font() As Font
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal NewValue As Font)
Set UserControl.Font = NewValue
Call ReDraw
PropertyChanged "Font"
End Property
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'字体颜色
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get ForeColor() As OLE_COLOR
ForeColor = mForeColor
End Property
Public Property Let ForeColor(ByVal NewValue As OLE_COLOR)
If mForeColor <> NewValue Then
mForeColor = NewValue
Call ReDraw
PropertyChanged "ForeColor"
End If
End Property
定义事件：
复制内容到剪贴板
八、为按钮的各个属性添加描述代码:
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'事件
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Event Click()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseOut()
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
复制内容到剪贴板
代码:
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'按了控件加速键
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
RaiseEvent Click
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'焦点进入控件
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_EnterFocus()
mblnFocus = True
Call ReDraw
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'焦点离开控件
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_ExitFocus()
mblnFocus = False
Call ReDraw
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'控件 Visible 属性为 False 时，好像没有 ExitFocus 事件发生，所以这里把 mblnFocus 设为 False 。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_Hide()
mblnFocus = False
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'新实例初始化
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_InitProperties()
mstrCaption = UserControl.Ambient.DisplayName
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'按下键
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Then
If mState <> BS_Press Then
mState = BS_Press
Call ReDraw
End If
End If
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)
If KeyCode = vbKeyEscape Then
mblnCancel = True
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
End If
If KeyCode = vbKeySpace Then
If mblnCancel Then
mblnCancel = False
Else
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
RaiseEvent Click
End If
End If
RaiseEvent KeyUp(KeyCode, Shift)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'按下鼠标
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Timer1.Enabled = False
If mState <> BS_Press Then
mState = BS_Press
Call ReDraw
End If
End If
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'移动鼠标
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
With UserControl
If Button = vbLeftButton Then
Timer1.Enabled = False
If X >= 0 And X <= .ScaleWidth And Y >= 0 And Y <= .ScaleHeight Then
If mState <> BS_Press Then
mState = BS_Press
Call ReDraw
End If
Else
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
End If
Else
Timer1.Enabled = True
If mState <> BS_Point Then
mState = BS_Point
Call ReDraw
End If
End If
End With
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'释放鼠标
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
With UserControl
If Button = vbLeftButton Then
If X >= 0 And X <= .ScaleWidth And Y >= 0 And Y <= .ScaleHeight Then
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
RaiseEvent Click
Else
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
End If
End If
End With
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'控件重画
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_Paint()
Call ReDraw
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'从存储器中读取属性
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
With PropBag
mstrCaption = .ReadProperty("Caption", UserControl.Ambient.DisplayName)
UserControl.Enabled = .ReadProperty("Enabled", True)
Set UserControl.Font = .ReadProperty("Font", UserControl.Ambient.Font)
mForeColor = .ReadProperty("ForeColor", UserControl.Ambient.ForeColor)
End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'将属性值写入存储器
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
.WriteProperty "Caption", mstrCaption, UserControl.Ambient.DisplayName
.WriteProperty "Enabled", UserControl.Enabled, True
.WriteProperty "Font", UserControl.Font, UserControl.Ambient.Font
.WriteProperty "ForeColor", mForeColor, UserControl.Ambient.ForeColor
End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'在用户控件添加一个 Timer，Enabled 属性为 False，Interval 为 100。用于鼠标离开按钮时恢复按钮原样
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub Timer1_Timer()
Dim lpPoint As POINT_API
GetCursorPos lpPoint
With UserControl
ScreenToClient .hwnd, lpPoint
If lpPoint.X < .ScaleLeft Or lpPoint.X > .ScaleLeft + .ScaleWidth Or _
lpPoint.Y < .ScaleTop Or lpPoint.Y > .ScaleTop + .ScaleHeight Then
Timer1.Enabled = False
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
RaiseEvent MouseOut
End If
End With
End Sub
'事件
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Event Click()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseOut()
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
复制内容到剪贴板
代码:
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'按了控件加速键
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
RaiseEvent Click
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'焦点进入控件
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_EnterFocus()
mblnFocus = True
Call ReDraw
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'焦点离开控件
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_ExitFocus()
mblnFocus = False
Call ReDraw
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'控件 Visible 属性为 False 时，好像没有 ExitFocus 事件发生，所以这里把 mblnFocus 设为 False 。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_Hide()
mblnFocus = False
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'新实例初始化
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_InitProperties()
mstrCaption = UserControl.Ambient.DisplayName
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'按下键
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Then
If mState <> BS_Press Then
mState = BS_Press
Call ReDraw
End If
End If
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)
If KeyCode = vbKeyEscape Then
mblnCancel = True
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
End If
If KeyCode = vbKeySpace Then
If mblnCancel Then
mblnCancel = False
Else
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
RaiseEvent Click
End If
End If
RaiseEvent KeyUp(KeyCode, Shift)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'按下鼠标
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Timer1.Enabled = False
If mState <> BS_Press Then
mState = BS_Press
Call ReDraw
End If
End If
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'移动鼠标
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
With UserControl
If Button = vbLeftButton Then
Timer1.Enabled = False
If X >= 0 And X <= .ScaleWidth And Y >= 0 And Y <= .ScaleHeight Then
If mState <> BS_Press Then
mState = BS_Press
Call ReDraw
End If
Else
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
End If
Else
Timer1.Enabled = True
If mState <> BS_Point Then
mState = BS_Point
Call ReDraw
End If
End If
End With
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'释放鼠标
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
With UserControl
If Button = vbLeftButton Then
If X >= 0 And X <= .ScaleWidth And Y >= 0 And Y <= .ScaleHeight Then
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
RaiseEvent Click
Else
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
End If
End If
End With
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'控件重画
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_Paint()
Call ReDraw
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'从存储器中读取属性
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
With PropBag
mstrCaption = .ReadProperty("Caption", UserControl.Ambient.DisplayName)
UserControl.Enabled = .ReadProperty("Enabled", True)
Set UserControl.Font = .ReadProperty("Font", UserControl.Ambient.Font)
mForeColor = .ReadProperty("ForeColor", UserControl.Ambient.ForeColor)
End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'将属性值写入存储器
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
.WriteProperty "Caption", mstrCaption, UserControl.Ambient.DisplayName
.WriteProperty "Enabled", UserControl.Enabled, True
.WriteProperty "Font", UserControl.Font, UserControl.Ambient.Font
.WriteProperty "ForeColor", mForeColor, UserControl.Ambient.ForeColor
End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'在用户控件添加一个 Timer，Enabled 属性为 False，Interval 为 100。用于鼠标离开按钮时恢复按钮原样
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub Timer1_Timer()
Dim lpPoint As POINT_API
GetCursorPos lpPoint
With UserControl
ScreenToClient .hwnd, lpPoint
If lpPoint.X < .ScaleLeft Or lpPoint.X > .ScaleLeft + .ScaleWidth Or _
lpPoint.Y < .ScaleTop Or lpPoint.Y > .ScaleTop + .ScaleHeight Then
Timer1.Enabled = False
If mState <> BS_Normal Then
mState = BS_Normal
Call ReDraw
End If
RaiseEvent MouseOut
End If
End With
End Sub
选择名称：Caption
添加描述：返回/设置对象的标题栏中或图标下面的文本。
选择名称：Enabled
添加描述：返回/设置一个值，决定一个对象是否响应用户生成事件。
选择名称：Font
添加描述：返回一个 Font 对象。
选择名称：ForeColor
添加描述：返回/设置对象中文本和图形的前景色。
这样，在使用控件时，它的属性浏览器中选中相应的属性就会在下面显示描述。是不是跟专业的一样？：）
九、添加类似普通按钮“Command1 = True”执行其“Click”事件。
添加属性：RaiseClick
复制内容到剪贴板
然后菜单的工具==>过程属性代码:
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'这是一个隐藏属性，RaiseClick 可以命名为别的名称。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get RaiseClick() As Boolean
Click = False
End Property
Public Property Let RaiseClick(ByVal NewValue As Boolean)
If NewValue = True And UserControl.Enabled Then
RaiseEvent Click
End If
End Property
'这是一个隐藏属性，RaiseClick 可以命名为别的名称。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Property Get RaiseClick() As Boolean
Click = False
End Property
Public Property Let RaiseClick(ByVal NewValue As Boolean)
If NewValue = True And UserControl.Enabled Then
RaiseEvent Click
End If
End Property
选择名称：RaiseClick，点高级。
过程标识符：选择“（缺省）”
属性中选择：隐藏该成员。
这样，你可以用“CMCommandButton1 = True”来执行该按钮的 Click 事件。是不是像专业的一样？：）
十、为按钮添加工具栏小图标。
这里，我选择了正常状态的图片，把图片调整大小到16×16。然后打开用户控件的设计窗口，在属性浏览器中选择“ToolBoxBitmap”属性，按右边的“…”，然后选中刚才的图片就可以了。这样，在使用按钮时，在VB的工具栏中会出现这个按钮图片。
最后，调整用户控件的大小：Width = 900，Height = 300。这样，在使用按钮的时候，在VB工具栏中双击该按钮时，默认的按钮大小就是 900 * 300的大小。
到此，自定义控件==>按钮的编写过程就完成了。本来，还可以给按钮加上图标的，但过于复杂，不适合初学者看，这里就不写了。本来想再写详细一点的，但作文不好，怕被人说我罗嗦。有疑问的请跟帖提出，俺尽量解答。
编写自定义控件并不难，难的是细节处的处理。
附件中的源代码，因为我是写成“ActiveX 控件”，所以启动时要启动“组1.vbg”进行调试。
附件中的GIF图片为GIF格式图片。
附件中的PSD图片为 PhotoShop 文件，要用 PhotoShop 打开。注意里面的图层混合选项。
