ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 3763|回复: 12

[分享] 纯类模块进度条

[复制链接]

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 "use*****" (ByVal hwnd As Long) As Long
  12.     Private Declare PtrSafe Function GetWindowLong Lib "use*****" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  13.     Private Declare PtrSafe Function SetWindowLong Lib "use*****" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  14.     Private Declare PtrSafe Function FindWindow Lib "use*****" 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 "use*****" (ByVal hwnd As Long) As Long
  18.     Private Declare Function GetWindowLong Lib "use*****" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  19.     Private Declare Function SetWindowLong Lib "use*****" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  20.     Private Declare Function FindWindow Lib "use*****" 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
复制代码


评分

参与人数 1鲜花 +2 收起 理由
lxw6 + 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财富 +50 收起 理由
joforn + 50 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

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

进度条.rar

2.3 KB, 下载次数: 423

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 | 显示全部楼层
你好,请问在执行时,提示“不信任到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, 2019-8-18 20:59 , Processed in 0.097741 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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