一个改进了的兼容WPS的状态栏进度条

mythqiu

1. '调用方法:
   
2. for i=1 to ir
   
3. '其他程序
   
4.                         Call YanShi(60, i, ir, 500, ",King WPS")
   
5.                         'Call YanShi(0, i, ir , 100, ",MicroSoft")
   
6. next
   
7. 
   

复制代码

经过测试,office设置100的倍数调用,5000条数据大约影响0.5秒,如果每条都调用100设置为1,时间增加太多
wps 60毫秒暂停一下,500的倍数调用,大概影响1秒多.500调小,时间会增加

1. ''''''''''''''''''''''
   
2. '自定义 状态栏 进度显示    ■□●○★☆▲△▼▽◆◇※∷┇┆╋╬┋┊Θο
   
3. '在状态栏显示 调用方式如下
   
4. 'Application.StatusBar = GetProgress(n, m,msg)
   
5. 'EH 论坛 coby001 改进版本 http://club.excelhome.net/forum.php?mod=viewthread&tid=1286008
   
6. '原版 http://www.cnblogs.com/gxlxzys/archive/2010/10/16/1852967.html
   
7. '''''''''''''''''''''
   
8. Function GetProgress(curValue, maxValue, info) As String
   
9.     Dim sgp$(1 To 8), igp&, jgp&
   
10.     Const Lgp& = 20
    
11.     If curValue > maxValue Then curValue = maxValue
    
12.     igp = maxValue \ Lgp
    
13.     jgp = curValue \ igp
    
14.     sgp(1) = String(jgp, "■")
    
15.     sgp(2) = String(Lgp - jgp, "□")
    
16.     sgp(3) = CInt(curValue * 100 / maxValue)
    
17.     sgp(4) = "% 计算行:"
    
18.     sgp(5) = curValue
    
19.     sgp(6) = "/"
    
20.     sgp(7) = maxValue
    
21.     sgp(8) = info
    
22.     GetProgress = Join(sgp, "")
    
23.     Erase sgp
    
24. End Function
    

复制代码

1. '''''''''''''''''''''''''''''
   
2. '延时程序,用于某些版本Excel不刷新状态栏
   
3. '为了不耽误太多时间,自定义延时时间(毫秒),循环到多少式才延时延时
   
4. 'Call YanShi(100, i,ir, 200,"信息") 含义是延时100毫秒,i每到200的倍数才延时. i,ir为 for....next中的计数变量
   
5. '每NumPer才暂停,这个进度在计算很短的地方没必要使用,只会增加无谓的时间
   
6. ''''''''''''''''''''''''''''
   
7. Sub YanShi(T%, CurForNum&, AllForNum&, NumPer%, Strv$)
   
8.     If CurForNum = 1 Then
   
9.         Application.StatusBar = GetProgress(CurForNum, AllForNum, Strv)
   
10.     ElseIf CurForNum Mod NumPer = 0 Then
    
11.     '下面是为了解决wps不显示状态的问题,T需要设置一个毫秒数量建议50毫秒,Microsoft的设置为0
    
12.         If T > 0 Then
    
13.             Dim Time8 As Long
    
14.             Time8 = timeGetTime
    
15.             Application.SendKeys "{LEFT}"                   '发送一个键值,任何都可,建议←键,不产生输入,移动到左边就不在影响
    
16.             Application.ScreenUpdating = True               '开启屏幕刷新
    
17.             Do
    
18.                 DoEvents
    
19.             Loop While timeGetTime - Time8 < T          '暂停T毫秒,写入状态进度
    
20.         End If
    
21.         Application.StatusBar = GetProgress(CurForNum, AllForNum, Strv)
    
22.         If T > 0 Then Application.ScreenUpdating = False                '关闭
    
23.     End If
    
24. End Sub

复制代码

mythqiu

1. Private Declare Function timeGetTime Lib "winmm.dll" () As Long             'timegettime 在顶部声明API

复制代码

编辑后少了一些代码,奇怪,再次编辑一下,

yf_home

测试了下，还不错，感谢分享！
如果字体颜色能变下就更好了，

mythqiu

yf_home 发表于 2018-7-27 12:56
测试了下，还不错，感谢分享！
如果字体颜色能变下就更好了，

这个，在程序运行大于6秒可以用用，也就给自己或者客户一个提示。其他时候用，真的很影响速度。好像论坛有变色的，哪就更慢了。我测试过，循环每步都改变状态栏，多费一半的时间。