【源码】三种不使用API实现的VBA定时器-摘录

盗梦

想在VBA中实现定时器，当然Access中有窗体的Timer事件，不过在Excel或word ppt则没有这个事件。以下方法可弥补这个缺陷
搜索网上相关的知识点。找到 三种不使用API的VBA定时器
本文并不是为了比较用API和不用API设置定时器的优劣，而是提供了在VBA中另一种设置定时器的方法。
摘录自：http://www.blogbus.com/pptaddins-logs/69416881.html

使用方法：
(1) 把下面代码拷入
PowerPoint:当前幻灯片（如Slide1）中
Excel: ThisWorkBook中
Word: ThisDocument中
(2) 执行StartTimer宏开始定时器，将在调试窗口中每秒输出数字n
(3) 中止定时器EndTimer

第一种：

1. Option Explicit
   
2. Private d As Object
   
3. Private TimerId As Long
   
4. Public Sub StartTimer()
   
5. If TimerId <> 0& Then Exit Sub
   
6. Set d = CreateObject("htmlfile")
   
7. Set d.parentWindow.onhelp = Me
   
8. TimerId = d.parentWindow.setInterval("onhelp.TimerProc", 1000&, "VBScript")
   
9. Debug.Print "定时器开始(" & Hex(TimerId) & ")"
   
10. End Sub
    
11. Public Sub EndTimer()
    
12.      If TimerId = 0& Then Exit Sub
    
13.      Call d.parentWindow.clearInterval(TimerId)
    
14.      TimerId = 0& Set d = Nothing
    
15.      Debug.Print "定时器结束"
    
16. End Sub
    
17. '在下面CALLBACK过程中输入你自己的代码
    
18. Public Sub TimerProc()
    
19.      Static n As Long
    
20.      n = n + 1
    
21.      Debug.Print n
    
22. End Sub

复制代码

第二种：

1. Private m_TimerId As Variant
   
2. Private m_doc As Object
   
3. Const ATTRNAME = "VBATimer"
   
4. Public Sub StartTimer()
   
5.      Const Script = "document.documentElement.getAttribute('" & ATTRNAME & "').TimerProc()"
   
6.      EndTimer
   
7.      Set m_doc = CreateObject("htmlfile")
   
8.      m_doc.DocumentElement.setAttribute ATTRNAME, Me
   
9.      m_TimerId = m_doc.parentWindow.setInterval(Script, 1000)
   
10. End Sub
    
11. public Sub EndTimer()
    
12.      If m_doc Is Nothing Then Exit Sub
    
13.      If Not IsEmpty(m_TimerId) Then
    
14.          m_doc.parentWindow.clearInterval m_TimerId
    
15.          m_TimerId = Empty
    
16.      End If
    
17.      m_doc.DocumentElement.removeAttribute ATTRNAME
    
18.      Set m_doc = Nothing
    
19. End Sub
    
20. '在下面CALLBACK过程中输入你自己的代码
    
21. Public Sub TimerProc()
    
22.      Static n As Long
    
23.      n = n + 1
    
24.      Debug.Print n
    
25. End Sub

复制代码

第三种：

1. Private m_TimerId As Variant
   
2. Private m_doc As Object
   
3. Private m_sc As Object
   
4. Public Sub StartTimer()
   
5.      EndTimer
   
6.      Set m_doc = CreateObject("htmlfile")
   
7.      Set m_sc = CreateObject("ScriptControl")
   
8.      With m_sc
   
9.          .Language = "JScript"
   
10.          .AddObject "o", Me
    
11.          .AddCode "function f(){o.TimerProc()}"
    
12.      End With
    
13.      m_TimerId = m_doc.parentWindow.setInterval(m_sc.Eval("f"), 1000)
    
14. End Sub
    
15. public Sub EndTimer()
    
16.      If m_doc Is Nothing Then Exit Sub
    
17.      If Not IsEmpty(m_TimerId) Then
    
18.           m_doc.parentWindow.clearInterval m_TimerId
    
19.           m_TimerId = Empty
    
20.      End If
    
21.      Set m_sc = Nothing
    
22.      Set m_doc = Nothing
    
23. End Sub
    
24. '在下面CALLBACK过程中输入你自己的代码
    
25. Public Sub TimerProc()
    
26.       Static n As Long
    
27.       n = n + 1
    
28.       Debug.Print n
    
29. End Sub

复制代码

roych

JavaScript，又见JavaScript……就说嘛，没有API，基本逃不掉JS。只是如果客户端（例如IE）禁用了JS，不知道还能不能用？{:soso_e120:}

盗梦

roych 发表于 2015-4-17 08:57
JavaScript，又见JavaScript……就说嘛，没有API，基本逃不掉JS。只是如果客户端（例如IE）禁用了JS，不知 ...

禁用了当然用不了 听说又有一种语言势要代替js-->Dart，正在观望