圆形按钮播放器代码
圆形按钮播放器 — VBA 自定义圆形按钮与字幕滚动演示
圆形按钮播放器是一个基于 Excel/WPS VBA 的 UserForm 演示项目，利用 Label 控件配合 Image 图片切换，实现了三态圆形按钮效果（正常/悬停/按下），并结合 Windows API 定时器驱动字幕滚动动画。
项目展示了如何在 VBA 环境下制作具有专业交互体验的自定义控件，包括精确的圆形热区判断、类模块事件封装、图片状态切换等技巧。
原始代码作者：ldhyob，经优化后兼容 Microsoft Excel / WPS 表格（32位和64位），可直接运行体验。
📌 核心功能一览
| 功能 | 说明 |
|---|---|
| 圆形按钮三态切换 | 正常态、鼠标悬停态、鼠标按下态，通过图片切换实现 |
| 精确圆形热区判断 | 利用勾股定理计算鼠标与圆心距离，只在圆形区域内触发 |
| 播放按钮 | 启动字幕滚动定时器 |
| 暂停按钮 | 停止字幕滚动 |
| 关闭按钮 | 卸载窗体退出 |
| 字幕滚动动画 | Windows API 定时器驱动，逐字显示文本内容 |
| 类模块事件封装 | 用类模块统一管理多个按钮的鼠标事件 |
| 64位Office兼容 | 条件编译支持 32位和 64位环境 |
⚙️ 项目结构说明
模块组成
| 模块 | 类型 | 作用 |
|---|---|---|
| Class1 | 类模块 | 封装 Label 控件鼠标事件，实现按钮三态切换与圆形热区判断 |
| Module1 | 标准模块 | Windows API 声明、定时器回调、公共变量、程序入口 |
| myplayer | 窗体模块 | 承载控件、初始化按钮绑定、字幕文本设置、窗体事件处理 |
窗体控件布局
| 控件 | 用途 |
|---|---|
| Label1 | 播放按钮（圆形） |
| Label2 | 暂停按钮（圆形） |
| Label3 | 关闭按钮（圆形） |
| Label4 | 字幕显示区域 |
| Image1~Image3 | 播放按钮三态图片（正常/悬停/按下） |
| Image4~Image6 | 暂停按钮三态图片（正常/悬停/按下） |
| Image7~Image9 | 关闭按钮三态图片（正常/悬停/按下） |
| CommandButton1 | 备用关闭按钮 |
🚀 运行方式
第一步：创建项目结构
在 VBA 编辑器中创建以下模块：
- 插入 → 用户窗体，命名为
myplayer - 插入 → 类模块，命名为
Class1 - 插入 → 模块，命名为
Module1
第二步：准备窗体控件
在 myplayer 窗体上放置：
- 3 个 Label 控件（Label1、Label2、Label3）作为圆形按钮
- 1 个 Label 控件（Label4）作为字幕显示区
- 9 个 Image 控件（Image1~Image9）加载按钮图片
- 1 个 CommandButton（CommandButton1）
第三步：加载按钮图片
每个按钮需要 3 张圆形图片：
| 图片 | 状态 | 对应控件 |
|---|---|---|
| 播放-正常 | 正常态 | Image1 |
| 播放-悬停 | 鼠标移入 | Image2 |
| 播放-按下 | 鼠标按下 | Image3 |
| 暂停-正常 | 正常态 | Image4 |
| 暂停-悬停 | 鼠标移入 | Image5 |
| 暂停-按下 | 鼠标按下 | Image6 |
| 关闭-正常 | 正常态 | Image7 |
| 关闭-悬停 | 鼠标移入 | Image8 |
| 关闭-按下 | 鼠标按下 | Image9 |
将 Image 控件的 Visible 属性设为 False（仅作图片容器，不需显示）。
第四步：粘贴代码
将三段代码分别粘贴到对应模块中。
第五步：运行
在 ThisWorkbook 模块中添加自动运行入口：
Private Sub Workbook_Open()
Workbook_Open
End Sub或直接运行标准模块中的 Workbook_Open 宏。
📋 完整代码
类模块（Class1）
Option Explicit
Private WithEvents Lbl As MSForms.Label
Private BZ As Boolean
Private m_NormalPic As StdPicture
Private m_HoverPic As StdPicture
Private m_DownPic As StdPicture
Public Sub Attach(ByVal IsLabel As MSForms.Label)
Set Lbl = IsLabel
Select Case Lbl.Name
Case "Label1"
Set m_NormalPic = myplayer.Image1.Picture
Set m_HoverPic = myplayer.Image2.Picture
Set m_DownPic = myplayer.Image3.Picture
Case "Label2"
Set m_NormalPic = myplayer.Image4.Picture
Set m_HoverPic = myplayer.Image5.Picture
Set m_DownPic = myplayer.Image6.Picture
Case "Label3"
Set m_NormalPic = myplayer.Image7.Picture
Set m_HoverPic = myplayer.Image8.Picture
Set m_DownPic = myplayer.Image9.Picture
End Select
With Lbl
.Picture = m_NormalPic
.PicturePosition = fmPicturePositionCenter
End With
End Sub
Private Function IsInCircle(ByVal X As Single, ByVal Y As Single) As Boolean
Dim r As Single, cx As Single, cy As Single
r = Lbl.Width / 2
cx = r
cy = r
IsInCircle = (Sqr((X - cx) * (X - cx) + (Y - cy) * (Y - cy)) <= r)
End Function
Private Sub SetPicture(ByVal State As Integer)
Select Case State
Case 0: Lbl.Picture = m_NormalPic
Case 1: Lbl.Picture = m_HoverPic
Case 2: Lbl.Picture = m_DownPic
End Select
End Sub
Private Sub Lbl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 And IsInCircle(X, Y) Then
BZ = True
SetPicture 2
End If
End Sub
Private Sub Lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ActLabel = Lbl.Name
If IsInCircle(X, Y) Then
If BZ Then
SetPicture 2
Else
SetPicture 1
End If
Else
SetPicture 0
End If
End Sub
Private Sub Lbl_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Not BZ Then Exit Sub
BZ = False
If Not IsInCircle(X, Y) Then
SetPicture 0
Exit Sub
End If
SetPicture 1
Select Case Lbl.Name
Case "Label1"
If Not flag Then
flag = True
TID = SetTimer(0, 0, 200, AddressOf checktime)
myplayer.Caption = "我的圆形钮(ldhyob)...字幕播放中"
End If
Case "Label2"
If flag Then
flag = False
KillTimer 0, TID
TID = 0
myplayer.Caption = "我的圆形钮(ldhyob)...字幕暂停"
End If
Case "Label3"
Unload myplayer
End Select
End Sub
Private Sub Lbl_Click()
End Sub标准模块（Module1）
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal nIDEvent As LongPtr) As LongPtr
Public TID As LongPtr
#Else
Public Declare Function SetTimer Lib "user32" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Public TID As Long
#End If
Public ActLabel As String
Public flag As Boolean
#If VBA7 Then
Sub checktime(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idevent As LongPtr, ByVal dwTime As Long)
#Else
Sub checktime(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal dwTime As Long)
#End If
On Error Resume Next
With myplayer
.Label4.Caption = Left(.tt, .i)
.i = IIf((.i + 1) > Len(.tt), 1, .i + 1)
End With
On Error GoTo 0
End Sub
Sub Workbook_Open()
myplayer.Show
End Sub窗体模块（myplayer）
Option Explicit
Public tt As String
Public i As Integer
Private Mylbl(1 To 3) As New Class1
Private Sub UserForm_Initialize()
Dim n As Integer
tt = " IMAGE控件真是个好控件，它能在开发个性化界面方面发挥中坚作用。" & vbCrLf & _
" 本示例演示了利用该控件制作圆形钮的效果。每个按钮对应三幅图片，" & _
"分别和正常状态、鼠标移进、鼠标按下相对应。主要用到了控件的MouseMove事件。" & vbCrLf & _
" 此外，本例还有一细节处理即真正圆形热区的捕捉。用IMAGE控件只能检测到" & _
"矩形区域，这不符合完美的圆形按钮的效果，故代码中借助鼠标坐标与计算圆半径的方法加以处理。"
i = 1
For n = 1 To 3
Mylbl(n).Attach Me.Controls("Label" & n)
Next n
End Sub
Private Sub UserForm_Activate()
flag = True
TID = SetTimer(0, 0, 200, AddressOf checktime)
Me.Caption = "我的圆形钮(ldhyob)...字幕播放中"
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If ActLabel <> "" Then
With Me.Controls(ActLabel)
Select Case ActLabel
Case "Label1": .Picture = Me.Image1.Picture
Case "Label2": .Picture = Me.Image4.Picture
Case "Label3": .Picture = Me.Image7.Picture
End Select
End With
ActLabel = ""
End If
End Sub
Private Sub UserForm_Terminate()
If flag Then
KillTimer 0, TID
TID = 0
flag = False
End If
Windows(ThisWorkbook.Name).Visible = True
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub🔍 技术要点详解
1. 圆形热区精确判断
VBA 的 Label 控件本身只能检测矩形区域的鼠标事件，无法自动识别圆形边界。本项目通过勾股定理计算鼠标坐标与圆心的距离：
r = Lbl.Width / 2
cx = r
cy = r
IsInCircle = (Sqr((X - cx) * (X - cx) + (Y - cy) * (Y - cy)) <= r)当鼠标到圆心的距离小于等于半径时，判定为在圆形区域内，否则视为在按钮外部。
这使得即使鼠标在 Label 矩形范围内，但处于圆角之外的区域时，按钮不会响应，实现了真正的圆形按钮效果。
2. 类模块事件封装
VBA 中 Label 控件不支持控件数组，无法直接用一套代码管理多个按钮。本项目通过类模块 + WithEvents 实现事件封装：
Private WithEvents Lbl As MSForms.Label每个按钮实例化一个类对象，在初始化时绑定：
Dim Mylbl(1 To 3) As New Class1
For n = 1 To 3
Mylbl(n).Attach Me.Controls("Label" & n)
Next n这样一套事件代码即可管理任意数量的按钮，扩展时只需增加数组大小和对应图片。
3. 图片缓存与三态切换
每个按钮在初始化时缓存三种状态的图片引用：
Private m_NormalPic As StdPicture ' 正常态
Private m_HoverPic As StdPicture ' 悬停态
Private m_DownPic As StdPicture ' 按下态切换时直接赋值，避免每次都通过控件名查找图片，提升性能并简化代码。
4. Windows API 定时器
VBA 没有内置的高精度定时器，本项目使用 Windows API 的 SetTimer 和 KillTimer 实现 200 毫秒间隔的字幕滚动：
TID = SetTimer(0, 0, 200, AddressOf checktime)定时器回调函数 checktime 每次截取文本的前 N 个字符显示，形成逐字展开的动画效果。
5. 64位兼容处理
通过条件编译指令区分 32位和 64位环境：
#If VBA7 Then
Public Declare PtrSafe Function SetTimer Lib "user32" (...)
Public TID As LongPtr
#Else
Public Declare Function SetTimer Lib "user32" (...)
Public TID As Long
#End If确保在 Office 2010 及以上 64位版本中不会出现编译错误。
📊 相比原始代码的优化改进
| 优化项 | 原代码 | 优化后 |
|---|---|---|
| 圆形判断 | 固定半径 8.25，Y坐标反转 | 动态计算半径，以控件中心为圆心 |
| 语法错误 | 乘号写成连接符 _ |
修正为 * |
| 代码重复 | 每个事件中重复 Select Case | 提取 SetPicture/IsInCircle 方法 |
| 图片引用 | 每次切换重新查找 | 初始化时缓存到私有变量 |
| 64位兼容 | 仅支持 32位 | 条件编译支持双平台 |
| 鼠标交互 | 移出后按钮保持悬停态 | 移出圆形区域自动恢复正常态 |
| 误触防护 | 圆外释放也会触发按钮 | 只有圆内释放才执行动作 |
| 重复操作 | 多次点击播放创建多个定时器 | 状态判断防止重复启动/停止 |
| 错误处理 | 无 | 定时器回调加 On Error 保护 |
| 资源释放 | 关闭时可能遗漏定时器 | Terminate 中确保释放 |
| 代码规范 | 无 Option Explicit | 所有模块强制变量声明 |
| 字符串拼接 | Chr(13) | vbCrLf 标准常量 |
💡 扩展方向
| 方向 | 说明 |
|---|---|
| 增加音频播放 | 通过 mciSendString API 实现真正的音乐播放功能 |
| 字幕速度可调 | 增加快进/慢放按钮，动态修改定时器间隔 |
| 进度条显示 | 增加进度条控件显示字幕播放进度 |
| 无边框窗体 | 隐藏标题栏配合可拖动，实现自定义皮肤播放器 |
| 更多按钮 | 扩展数组大小即可增加新按钮，如上一曲/下一曲 |
| 字幕多行显示 | 支持多行文本框自动换行滚动 |
⚠️ 注意事项
- Image1~Image9 控件用作图片容器，Visible 可设为 False，不需要在窗体上显示。
- 按钮图片应为圆形透明底 PNG 或 BMP，三种状态视觉上有明显区分。
- Label 控件的 Width 和 Height 应相等（正方形），以确保圆形判断准确。
- 定时器回调中避免执行耗时操作，否则可能导致 Excel 无响应。
- 关闭窗体前务必释放定时器，否则 Excel 可能崩溃。
- WPS 中 API 定时器行为与 Excel 基本一致，但建议测试验证。
- 如果在 ThisWorkbook 中调用 Workbook_Open，注意不要与标准模块的同名 Sub 冲突，建议 ThisWorkbook 中写为
Call Module1.Workbook_Open或改用不同名称。
圆形按钮播放器代码 - 下载地址
选择任意一个下载地址并点击，输入通行密钥 Access password，打开下载页面后在右上角点击下载按钮（如未出现按钮请刷新页面）
📞 技术支持
官网：
求助建议： http://xlcs.de/
邮件联系： admin@fdc.sd
📷 效果展示
XLCS — 让全成本测算更智能
本博客所有文章除特别声明外，均采用 CC BY-NC-SA 4.0 许可协议。转载请注明来自 XLCS房产项目全成本测算模版 v9！
