自定义控件==>按钮 编写过程

--------------注：本文转载于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)”中。
四、定义模块级别变量用于储存属性值等数据

复制内容到剪贴板

代码:

' 定义一个私有枚举，用于标识按钮的当前状态
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

复制内容到剪贴板

代码:

' *****************************************五、编写重画控件的过程：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  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

八、为按钮的各个属性添加描述
选择名称：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，点高级。
过程标识符：选择“（缺省）”
属性中选择：隐藏该成员。
这样，你可以用“CMCommandButton1 = True”来执行该按钮的 Click 事件。是不是像专业的一样？：）
十、为按钮添加工具栏小图标。
这里，我选择了正常状态的图片，把图片调整大小到16×16。然后打开用户控件的设计窗口，在属性浏览器中选择“ToolBoxBitmap”属性，按右边的“…”，然后选中刚才的图片就可以了。这样，在使用按钮时，在VB的工具栏中会出现这个按钮图片。

最后，调整用户控件的大小：Width = 900，Height = 300。这样，在使用按钮的时候，在VB工具栏中双击该按钮时，默认的按钮大小就是 900 * 300的大小。

到此，自定义控件==>按钮的编写过程就完成了。本来，还可以给按钮加上图标的，但过于复杂，不适合初学者看，这里就不写了。本来想再写详细一点的，但作文不好，怕被人说我罗嗦。有疑问的请跟帖提出，俺尽量解答。

编写自定义控件并不难，难的是细节处的处理。

附件中的源代码，因为我是写成“ActiveX 控件”，所以启动时要启动“组1.vbg”进行调试。
附件中的GIF图片为GIF 格式图片。
附件中的PSD图片为 PhotoShop 文件，要用 PhotoShop 打开。注意里面的图层混合选项。

转载于:https://www.cnblogs.com/wangminbai/archive/2008/09/17/1292154.html