• 2010-07-16

    三种不使用API的VBA定时器 - [VBA代码分享]

    版权声明:转载时请以超链接形式标明文章原始出处和作者信息及本声明
    http://www.blogbus.com/pptaddins-logs/69416881.html

    三种不使用API的VBA定时器

    本文并不是为了比较用API和不用API设置定时器的优劣,而是提供了在VBA中另一种设置定时器的方法。

    使用方法:

    (1) 把下面代码拷入
    PowerPoint:当前幻灯片(如Slide1)中
    Excel: ThisWorkBook中
    Word: ThisDocument中

    (2) 执行StartTimer宏开始定时器,将在调试窗口中每秒输出数字n

    (3) 中止定时器EndTimer

     第一种:

    Option Explicit

    Private d As Object
    Private TimerId As Long

    Public Sub StartTimer()
    If TimerId <> 0& Then Exit Sub
    Set d = CreateObject("htmlfile")
    Set d.parentWindow.onhelp = Me
    TimerId = d.parentWindow.setInterval("onhelp.TimerProc", 1000&, "VBScript")
    Debug.Print "定时器开始(" & Hex(TimerId) & ")"
    End Sub

    Public Sub EndTimer()

         If TimerId = 0& Then Exit Sub
         Call d.parentWindow.clearInterval(TimerId)
         TimerId = 0& Set d = Nothing
         Debug.Print "定时器结束"

    End Sub

    '在下面CALLBACK过程中输入你自己的代码
    Public Sub TimerProc()
         Static n As Long
         n = n + 1
         Debug.Print n

    End Sub

    第二种:

    Private m_TimerId As Variant
    Private m_doc As Object
    Const ATTRNAME = "VBATimer"

    Public Sub StartTimer()

         Const Script = "document.documentElement.getAttribute('" & ATTRNAME & "').TimerProc()"
         EndTimer
         Set m_doc = CreateObject("htmlfile")
         m_doc.DocumentElement.setAttribute ATTRNAME, Me
         m_TimerId = m_doc.parentWindow.setInterval(Script, 1000)

    End Sub

    public Sub EndTimer()

         If m_doc Is Nothing Then Exit Sub
         If Not IsEmpty(m_TimerId) Then
             m_doc.parentWindow.clearInterval m_TimerId
             m_TimerId = Empty
         End If
         m_doc.DocumentElement.removeAttribute ATTRNAME
         Set m_doc = Nothing

    End Sub

    '在下面CALLBACK过程中输入你自己的代码
    Public Sub TimerProc()

         Static n As Long
         n = n + 1
         Debug.Print n

    End Sub

    第三种:

    Private m_TimerId As Variant
    Private m_doc As Object
    Private m_sc As Object

    Public Sub StartTimer()

         EndTimer
         Set m_doc = CreateObject("htmlfile")
         Set m_sc = CreateObject("ScriptControl")
         With m_sc
             .Language = "JScript"
             .AddObject "o", Me
             .AddCode "function f(){o.TimerProc()}"
         End With
         m_TimerId = m_doc.parentWindow.setInterval(m_sc.Eval("f"), 1000)

    End Sub

    public Sub EndTimer()

         If m_doc Is Nothing Then Exit Sub
         If Not IsEmpty(m_TimerId) Then
              m_doc.parentWindow.clearInterval m_TimerId
              m_TimerId = Empty
         End If
         Set m_sc = Nothing
         Set m_doc = Nothing

    End Sub

    '在下面CALLBACK过程中输入你自己的代码
    Public Sub TimerProc()

          Static n As Long
          n = n + 1
          Debug.Print n

    End Sub

    分享到:

    评论

  • 不错,可以拿来使用:)
  • 很好啊,第二段代码有些笔误吧

    Pulbic Sub StartTimer()

    Const Script = "document.documentElement.getAttribute('" & _ ATTRNAME & "').TimerProc()" 有两处笔误