ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 7337|回复: 13

[分享] 纯类模块进度条

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-1-27 23:44 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:类和类模块
分享一个进度条类,纯代码构建,不需要进度条控件或者用窗体模拟进度条
本类兼容Word/Excel/PPT/Access
  1. Private objApp As Object                              '指向当前的文档,如ThisDocument或ThisWorkBook
  2. Private uForm As Object                               '进度条窗体
  3. Private lbl1 As Object                                '显示标签文字 MSForms.Label
  4. Private lbl2 As Object                                '显示进度 MSForms.Label
  5. Private FormName As String

  6. '窗体风格
  7. Private Const GWL_STYLE As Long = (-16)
  8. Private Const WS_CAPTION As Long = &HC00000
  9. Private Const BarLength As Long = 300                 '进度条长度

  10. #If Win64 Then
  11.     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  12.     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  13.     Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  14.     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  15.     Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  16. #Else
  17.     Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  18.     Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  19.     Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  20.     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  21.     Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  22. #End If

  23. Private Sub Class_Initialize()
  24. '在Office会出现窗体名不能重用的BUG,即使用VBA创建窗体后,删除,再创建同名窗体会报错“文件/路径访问错误”
  25. '微软已经确认了该BUG的存在 http://support.microsoft.com/kb/244238/zh-cn
  26. '需要每次启动的时候,创建一个新名称的窗体
  27. t = Timer
  28. ms = t - Int(t)                                       '计算毫秒
  29. FormName = "FORM" & Format(Now, "ddhhmmss") & Replace(ms, ".", "")
  30. End Sub

  31. '创建进度条
  32. Public Sub ShowBar()
  33. CreateProgressBar
  34. End Sub

  35. '销毁进度条
  36. Public Sub DestroyBar()
  37. Unload uForm
  38. RemoveModule FormName
  39. Set uForm = Nothing
  40. Set objApp = Nothing
  41. End Sub

  42. '设置进度条进度
  43. Public Sub ChangeProcessBarValue(Value As Double, Optional Message As String = "")
  44. On Error Resume Next
  45. lbl1.width = Int(Value * BarLength)                   '显示进度条
  46. lbl2.Caption = IIf(Message = "", Format(Value, "已经完成 0.00%"), Message)
  47. DoEvents                                              '转让控制权给操作系统
  48. End Sub

  49. '阻塞进程
  50. Public Sub SleepBar(ms As Long)
  51. Sleep ms
  52. End Sub

  53. '创建进度条对象
  54. Private Sub CreateProgressBar()
  55. Dim UsForm As Object
  56. If InStr(1, Application.Name, "Word") > 0 Then
  57.     Set objApp = ThisDocument
  58. ElseIf InStr(1, Application.Name, "Excel") > 0 Then
  59.     Set objApp = ThisWorkbook
  60. ElseIf InStr(1, Application.Name, "PowerPoint") > 0 Then
  61.     Set objApp = ActivePresentation
  62. ElseIf InStr(1, Application.Name, "Access") > 0 Then
  63.     Set objApp = Application.VBE                      'Access
  64. End If
  65. '创建一个窗体。不能中断运行。
  66. RemoveModule FormName
  67. Set UsForm = objApp.VBProject.VBComponents.Add(3)
  68. With UsForm
  69.     '由于该窗体还未运行,相当于处于设计状态
  70.     '对于该窗体的属性,需要用Properties属性访问
  71.     .Properties("Caption") = "进度"
  72.     .Properties("Name") = FormName
  73.     .Properties("Height") = 30
  74.     .Properties("Width") = BarLength
  75.     .Properties("BackColor") = RGB(240, 240, 240)
  76.     .Properties("SpecialEffect") = fmSpecialEffectFlat
  77.     .Properties("BorderStyle") = fmBorderStyleNone    '要在该窗体上创建控件,则需要访问.Designer设计器对象
  78. End With

  79. '加载并显示该窗体。注意与平时加载显示窗体的不同
  80. Set uForm = VBA.UserForms.Add(FormName)

  81. With uForm                                            '用于显示进度
  82.     Set lbl1 = .Controls.Add("Forms.Label.1", "Label1", True)
  83.     With lbl1
  84.         .Left = 0
  85.         .top = 0
  86.         .height = uForm.width
  87.         .width = 0
  88.         .Caption = ""
  89.         .BackColor = RGB(128, 128, 255)
  90.         .BorderStyle = fmBorderStyleNone
  91.         .BackStyle = fmBackStyleOpaque
  92.         .BorderColor = .BackColor
  93.         .ZOrder 1
  94.     End With

  95.     '用于显示文字
  96.     Set lbl2 = .Controls.Add("Forms.Label.1", "Label1", True)
  97.     With lbl2
  98.         .Left = 0
  99.         .top = 9
  100.         .height = 12
  101.         .width = BarLength
  102.         .Caption = ""
  103.         .TextAlign = fmTextAlignLeft
  104.         .Font.Size = 9
  105.         .Font.Bold = False
  106.         .Font.Italic = False
  107.         .Font.Name = "宋体"
  108.         .ForeColor = RGB(0, 0, 0)
  109.         .BorderStyle = fmBorderStyleNone
  110.         .BackStyle = fmBackStyleTransparent
  111.         .ZOrder 0
  112.     End With
  113.     RemoveFormCaption uForm
  114.     uForm.Show vbModeless
  115. End With
  116. End Sub

  117. Private Sub RemoveModule(n As String)                 '移除具有指定名称的模块
  118. On Error Resume Next
  119. objApp.VBProject.VBComponents.Remove objApp.VBProject.VBComponents(n)
  120. objApp.Save
  121. End Sub

  122. Private Sub RemoveFormCaption(form As Object)
  123. If val(Application.Version) < 9 Then
  124.     hwnd = FindWindow("ThunderXFrame", form.Caption)
  125. Else
  126.     hwnd = FindWindow("ThunderDFrame", form.Caption)
  127. End If
  128. IStyle = GetWindowLong(hwnd, GWL_STYLE)
  129. IStyle = IStyle And Not WS_CAPTION
  130. SetWindowLong hwnd, GWL_STYLE, IStyle
  131. DrawMenuBar hwnd
  132. End Sub
复制代码


评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-1-27 23:44 | 显示全部楼层
调用方法:
'Sub StartProcessBar()
'    Dim c       As Double
'    Dim cnt     As Double
'    Dim msg     As String
'    Dim pbar    As New cProcessBar
'On Error GoTo Err_StartProcessBar
'    pbar.ShowBar '创建进度条
'    cnt = 100
'    For c = 1 To cnt
'        pbar.SleepBar 2
'        pbar.ChangeProcessBarValue c / cnt, Format(c / cnt, " 正在执行 0.0%")
'    Next
'    '销毁进度条
'    pbar.ChangeProcessBarValue 1, Format(c / cnt, " 执行完成,3 秒后程序自动关闭!")
'    pbar.SleepBar 1000
'    pbar.ChangeProcessBarValue 1, Format(c / cnt, " 执行完成,2 秒后程序自动关闭!")
'    pbar.SleepBar 1000
'    pbar.ChangeProcessBarValue 1, Format(c / cnt, " 执行完成,1 秒后程序自动关闭!")
'    pbar.SleepBar 1000
'    pbar.DestroyBar
'    Set pbar = Nothing
'    Exit Sub
'Err_StartProcessBar:
'    Set pbar = Nothing
'    MsgBox Err.Description, vbExclamation
'End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-1-27 23:50 | 显示全部楼层
主贴提到的其他两种进度条,内含调用方法
进度条A:使用label模拟进度条
进度条B:使用ProgressBar控件

进度条.rar

2.3 KB, 下载次数: 630

TA的精华主题

TA的得分主题

发表于 2017-1-28 14:38 | 显示全部楼层
这么久,终于看到eh有人搞些通用类模块了.论坛复制黏贴风气严重,这贴实属难得,值得支持

TA的精华主题

TA的得分主题

发表于 2017-11-5 22:51 | 显示全部楼层
loquat 发表于 2017-1-27 23:50
主贴提到的其他两种进度条,内含调用方法
进度条A:使用label模拟进度条
进度条B:使用ProgressBar控件

这两个进度条A、进度条B,打不开呀。

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-11-10 08:22 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-7-17 16:52 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
你好,请问在执行时,提示“不信任到Visual Basic Project的程序连接”,问题在哪儿?

TA的精华主题

TA的得分主题

发表于 2018-7-17 17:33 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-12-13 14:52 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-1-7 11:48 来自手机 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 17:19 , Processed in 0.069799 second(s), 15 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表