圆形按钮播放器 — 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 编辑器中创建以下模块：

  1. 插入 → 用户窗体，命名为 myplayer
  2. 插入 → 类模块，命名为 Class1
  3. 插入 → 模块，命名为 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 模块中添加自动运行入口：

1
2
3
Private Sub Workbook_Open()
    Workbook_Open
End Sub

或直接运行标准模块中的 Workbook_Open 宏。

📋 完整代码

类模块（Class1）

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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）

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
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）

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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 控件本身只能检测矩形区域的鼠标事件，无法自动识别圆形边界。本项目通过勾股定理计算鼠标坐标与圆心的距离：

1
2
3
4
r = Lbl.Width / 2
cx = r
cy = r
IsInCircle = (Sqr((X - cx) * (X - cx) + (Y - cy) * (Y - cy)) <= r)

当鼠标到圆心的距离小于等于半径时，判定为在圆形区域内，否则视为在按钮外部。

这使得即使鼠标在 Label 矩形范围内，但处于圆角之外的区域时，按钮不会响应，实现了真正的圆形按钮效果。

2. 类模块事件封装

VBA 中 Label 控件不支持控件数组，无法直接用一套代码管理多个按钮。本项目通过类模块 + WithEvents 实现事件封装：

1
Private WithEvents Lbl As MSForms.Label

每个按钮实例化一个类对象，在初始化时绑定：

1
2
3
4
5
Dim Mylbl(1 To 3) As New Class1

For n = 1 To 3
    Mylbl(n).Attach Me.Controls("Label" & n)
Next n

这样一套事件代码即可管理任意数量的按钮，扩展时只需增加数组大小和对应图片。

3. 图片缓存与三态切换

每个按钮在初始化时缓存三种状态的图片引用：

1
2
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 毫秒间隔的字幕滚动：

1
TID = SetTimer(0, 0, 200, AddressOf checktime)

定时器回调函数 checktime 每次截取文本的前 N 个字符显示，形成逐字展开的动画效果。

5. 64位兼容处理

通过条件编译指令区分 32位和 64位环境：

1
2
3
4
5
6
7
#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 实现真正的音乐播放功能
字幕速度可调 增加快进/慢放按钮，动态修改定时器间隔
进度条显示 增加进度条控件显示字幕播放进度
无边框窗体 隐藏标题栏配合可拖动，实现自定义皮肤播放器
更多按钮 扩展数组大小即可增加新按钮，如上一曲/下一曲
字幕多行显示 支持多行文本框自动换行滚动

⚠️ 注意事项

  1. Image1~Image9 控件用作图片容器，Visible 可设为 False，不需要在窗体上显示。
  2. 按钮图片应为圆形透明底 PNG 或 BMP，三种状态视觉上有明显区分。
  3. Label 控件的 Width 和 Height 应相等（正方形），以确保圆形判断准确。
  4. 定时器回调中避免执行耗时操作，否则可能导致 Excel 无响应。
  5. 关闭窗体前务必释放定时器，否则 Excel 可能崩溃。
  6. WPS 中 API 定时器行为与 Excel 基本一致，但建议测试验证。
  7. 如果在 ThisWorkbook 中调用 Workbook_Open，注意不要与标准模块的同名 Sub 冲突，建议 ThisWorkbook 中写为 Call Module1.Workbook_Open 或改用不同名称。

圆形按钮播放器代码 - 下载地址

选择任意一个下载地址并点击，输入通行密钥 Access password，打开下载页面后在右上角点击下载按钮（如未出现按钮请刷新页面）

📞 技术支持

官网：

求助建议： http://xlcs.de/
邮件联系： admin@fdc.sd

📷 效果展示

圆形按钮播放器界面

XLCS — 让全成本测算更智能