none
咨询一下VBA当中如何使用Timer控件 RRS feed

  • 问题

  • 咨询一下VBA当中如何使用Timer控件,比如说每隔5分钟发一个Msgbox
    最好是期间Excel能够进行其他的操作,有的代码实现了每隔5分钟发一个Msgbox的功能,但在等待的这5分钟里面,Excel是被独占住的,无法进行其他的操作,只能等待,这就不大有用了
    2009年5月25日 14:05

答案

  • 咨询一下VBA当中如何使用Timer控件,比如说每隔5分钟发一个Msgbox
    最好是期间Excel能够进行其他的操作,有的代码实现了每隔5分钟发一个Msgbox的功能,但在等待的这5分钟里面,Excel是被独占住的,无法进行其他的操作,只能等待,这就不大有用了


    VBA不支持Timer控件,需要自己写一个与Timer控件功能相同的类模块。
    代码如下:

    CTimer.cls模块

    Option Explicit
    Private iInterval As Long
    Private id As Long
    Public Item As Variant
    Public Event ThatTime()
    Public Enum EErrorTimer
        eeBaseTimer = 13650
        eeTooManyTimers
        eeCantCreateTimer
    End Enum

    Friend Sub ErrRaise(e As Long)
        Dim sText As String, sSource As String
        If e > 1000 Then
            sSource = "实例过程"
            Select Case e
            Case eeTooManyTimers
                sText = "不允许超过100个定时器"
            Case eeCantCreateTimer
                sText = "不能建立系统定时器"
            End Select
            Err.Raise e Or vbObjectError, sSource, sText
        Else
            Err.Raise e, sSource
        End If
    End Sub
    Property Get Interval() As Long
        Interval = iInterval
    End Property

    Property Let Interval(iIntervalA As Long)
        Dim f As Boolean
        If iInterval = iIntervalA Then Exit Property
        If iIntervalA Then
            If iInterval Then
                f = TimerDestroy(Me)
            End If
            iInterval = iIntervalA
            If TimerCreate(Me) = False Then ErrRaise eeCantCreateTimer
        Else
            If iInterval Then
                iInterval = iIntervalA
                f = TimerDestroy(Me)
            End If
        End If
    End Property
    Public Sub PulseTimer()
        RaiseEvent ThatTime
    End Sub
    Friend Property Get TimerID() As Long
        TimerID = id
    End Property
    Friend Property Let TimerID(idA As Long)
        id = idA
    End Property
    Private Sub Class_Initialize()
        'Debug.Print "定时器初始化"
    End Sub

    Private Sub Class_Terminate()
        If Interval Then Interval = 0
        'Debug.Print "终止定时器"
    End Sub

    MTimer.bas模块:

    Option Explicit
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
         Any, source As Any, ByVal bytes As Long)
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal _
    lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Const cTimerMax = 100
    Private Type TTimerData
        idTimer  As Long
        pTimer As Long
    End Type
    Public atdata(1 To cTimerMax) As TTimerData
    Private cTimers As Long

    Function TimerCreate(timer As CTimer) As Boolean
        If cTimers + 1 = cTimerMax Then timer.ErrRaise eeTooManyTimers
        timer.TimerID = SetTimer(0&, 0&, timer.Interval, AddressOf TimerProc)
        If timer.TimerID Then
            TimerCreate = True
            cTimers = cTimers + 1
            atdata(cTimers).idTimer = timer.TimerID
            atdata(cTimers).pTimer = ObjPtr(timer)
        Else
            TimerCreate = False
            timer.TimerID = 0
            timer.Interval = 0
        End If
       
    End Function
    Public Function TimerDestroy(timer As CTimer) As Long
        Dim i As Long, iDead As Long, tdata As TTimerData ' = zeros
        For i = 1 To cTimers
            If timer.TimerID = atdata(i).idTimer Then
                Call KillTimer(0, timer.TimerID)
                cTimers = cTimers - 1
                For iDead = i To cTimers
                    atdata(iDead) = atdata(iDead + 1)
                Next
                atdata(cTimers + 1) = tdata
                TimerDestroy = True
                Exit Function
            End If
        Next
    End Function
    Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
                  ByVal idEvent As Long, ByVal dwTime As Long)
        Dim i As Integer, timer As CTimer
        For i = 1 To cTimers
            If idEvent = atdata(i).idTimer Then
                CopyMemory timer, atdata(i).pTimer, 4
                timer.PulseTimer
                CopyMemory timer, 0&, 4
                Exit Sub
            End If
        Next
    End Sub

    然后你就可以在VBA中声明这个类对象,访问它的公共属性和事件。

    2009年9月16日 3:14