纯API自绘窗体的进度条类，废话少说，直接上代码

这个进度条类的调用方式：

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hParent As Long, ByVal hChildAfter As Long, ByVal sClass As String, ByVal sTitle As String) As LongPrivate c As cProgressBarPrivate m_hWnd As LongPrivate Function StatusBarHWnd() As Long '获取Excel2010的状态栏句柄 Dim hWnd& hWnd = Application.hWnd hWnd = FindWindowEx(hWnd, 0&, "Excel2", vbNullString) hWnd = FindWindowEx(hWnd, 0&, "MsoCommandBar", "状态栏") hWnd = FindWindowEx(hWnd, 0&, "MsoWorkPane", "状态栏") StatusBarHWnd = hWndEnd FunctionPublic Sub test() Set c = New cProgressBar '实例化cProgressBar类 m_hWnd = StatusBarHWnd() '获取Excel状态栏句柄 c.CreateProgressBar m_hWnd, 90, 2, 200, 20, False, False '创建进度条 c.BackColor = vbWhite '背景色 c.ForeColor = vbRed '前景色，进度条颜色 c.Min = 1 '最小值 Dim n&, i& n = 100000 c.Max = n '最大值 For i = 1 To n c.Value = i '进度滚动 Next i Set c = Nothing '销毁类实例，释放资源End Sub

状态栏进度条

cProgressBar.cls

'# 自绘窗体进度条 cProgressBar.cls'# 作者：loquat'# 发布日期：2019-4-1'# 版本号：v1.0'# 版权所有，转载请注明版权，如有修改完善，请本着开源精神，广为分享'# 如不嫌弃，也可以单独发我一份Option Explicit#Const VBA = True '如果在VB6下使用，改为FalsePrivate Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( _ ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, _ ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _ ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As LongPrivate Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Declare Function InvalidateRect Lib "user32.dll" (ByVal hWnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As LongPrivate Const PROGRESS_CLASS = "msctls_progress32"'窗口消息和样式Private Const WS_VISIBLE = &H10000000Private Const WS_CHILD = &H40000000'进度条消息和样式Private Const PBS_VERTICAL = &H4&Private Const PBM_SETPOS = &H402&Private Const PBM_SETRANGE32 = &H406&Private Const PBM_GETRANGE = &H407&Private Const PBM_SETBARCOLOR = &H409&Private Const PBS_SMOOTH As Long = &H1& ' 进度条连续，无间隔'通用控件消息Private Const PBM_SETBKCOLOR As Long = &H2001&'类的私有变量Private m_hWnd As Long '进度条窗口句柄Private m_ForeColor As Long '前景色Private m_BackColor As Long '背景色'属性和方法Public Property Let ForeColor(newColor As Long) '进度条颜色 If newColor = -1& Then m_ForeColor = &HFF000000 Else m_ForeColor = newColor And &HFFFFFF SendMessage m_hWnd, PBM_SETBARCOLOR, 0&, ByVal m_ForeColorEnd PropertyPublic Property Let BackColor(newColor As Long) '进度条背景 If newColor = -1& Then m_BackColor = &HFF000000 Else m_BackColor = newColor And &HFFFFFF SendMessage m_hWnd, PBM_SETBKCOLOR, 0&, ByVal m_BackColorEnd PropertyPublic Sub DestroyBar() DestroyWindow m_hWnd '销毁进度条End SubPublic Property Let Min(newValue As Long) SendMessage m_hWnd, PBM_SETRANGE32, newValue, ByVal Me.MaxEnd PropertyPublic Property Let Max(newValue As Long) SendMessage m_hWnd, PBM_SETRANGE32, Me.Min, ByVal newValueEnd PropertyPublic Property Get Min() As Long Min = SendMessage(m_hWnd, PBM_GETRANGE, 1&, ByVal 0&)End PropertyPublic Property Get Max() As Long Max = SendMessage(m_hWnd, PBM_GETRANGE, 0&, ByVal 0&)End PropertyPublic Property Let Value(ByVal setVal As Long) SendMessage m_hWnd, PBM_SETPOS, setVal, 0 '设置进度条值End PropertySub CreateProgressBar(ByVal ContainerHwnd As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Vertical As Boolean, Optional ByVal Smooth As Boolean = False) Dim lStyle As Long If Vertical = True Then lStyle = PBS_VERTICAL '是否垂直 If Smooth Then lStyle = lStyle Or PBS_SMOOTH '是否平滑 Dim hInstance As Long #If VBA Then hInstance = Application.HinstancePtr '用于VBA #Else hInstance = App.hInstance '用于VB6 #End If m_hWnd = CreateWindowEx(0, PROGRESS_CLASS, "", WS_VISIBLE Or WS_CHILD Or lStyle, x, y, Width, Height, ContainerHwnd, 0&, hInstance, 0&) End SubPrivate Sub Class_Terminate() InvalidateRect m_hWnd, 0&, True '干掉进度条 DestroyWindow m_hWnd '干掉进度条End Sub

本代码，核心的API就是CreateWindowEx和SendMessage

当然这个类还远不算封装完成，至少有如下 TODO

1、进度条Caption文字，百分比展示

2、效率提升

当前已经实现基本功能，继续封装希望文章的大牛参与一下，一起封装