PowerPoint VBA 中非 CPU 密集型的睡眠/等待计时器

Question

我目前有一个 PowerPoint 演示文稿，它在计算机上用作某种信息亭或信息屏幕。 它从磁盘上的文本文件中读取它的文本。此文本文件中的文本显示在 PowerPoint 的文本框中，并且每 5 秒刷新一次。这样，我们可以在 PowerPoint 中编辑文本，而无需编辑 PowerPoint 演示文稿本身，因此它将继续运行。 到目前为止工作得很好，只有 PowerPoint VBA 不包含 Application.Wait 函数。在这里查看完整的子：

Sub Update_textBox_Inhoud()

Dim FileName As String
TextFileName = "C:\paht\to\textfile.txt"
If Dir$(FileName) <> "" Then

Application.Presentations(1).SlideShowSettings.Run
Application.WindowState = ppWindowMinimized


While True


    Dim strFilename As String: strFilename = TextFileName
    Dim strFileContent As String
    Dim iFile As Integer: iFile = FreeFile
    Open strFilename For Input As #iFile
    strFileContent = Input(LOF(iFile), iFile)
    Application.Presentations(1).Slides(1).Shapes.Range(Array("textBox_Inhoud")).TextFrame.TextRange = strFileContent
    Close #iFile


    waitTime = 5
    Start = Timer
    While Timer < Start + waitTime
        DoEvents
    Wend

Wend

Else

End If
End Sub

如您所见，我在循环中有一个循环来创建 5 秒睡眠/等待功能，因为 PowerPoint 没有 Application.Wait 功能。

在运行此宏时，我的第 7 代 i5 上的 CPU 负载高达 36%。 kiosk 计算机的硬件稍差，因此 CPU 负载会很高，而且这台 PC 的风扇会发出很大的噪音。

我认为睡眠/等待功能并没有真正“睡眠”，它只是继续循环直到 5 秒过去。

问题 1：我的假设是函数并没有真正休眠吗？ 问题 2：如果问题 1 的答案是正确的，是否有更好、更少 CPU 密集型的方法来创建睡眠功能？

Answer 1

Sleep 不需要 CPU 周期。

Sleep 是 windows 函数而不是 VBA 函数，但您仍然可以通过调用 windows Sleep API 在 VBA 代码中使用此函数。实际上sleep 是存在于 Windows DLL 文件中的一个函数。因此，在使用它们之前，您必须在模块中的代码上方声明 API 的名称。

Sleep语句的语法如下：

Sleep (delay)

示例：

#If VBA7 Then  
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems  
#Else  
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds as Long) 'For 32 Bit Systems  
#End If  
Sub SleepTest()  
MsgBox "Execution is started"  
Sleep 10000 'delay in milliseconds  
MsgBox "Execution Resumed"  
End Sub  

所以基本上你的代码如下：

#If VBA7 Then

    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

#Else

    Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

#End If

    Sub Update_textBox_Inhoud()

    Dim FileName As String
    TextFileName = "C:\paht\to\textfile.txt"
    If Dir$(FileName) <> "" Then
        Application.Presentations(1).SlideShowSettings.Run
        Application.WindowState = ppWindowMinimized

        While True
            Dim strFilename As String: strFilename = TextFileName
            Dim strFileContent As String
            Dim iFile As Integer: iFile = FreeFile
            Open strFilename For Input As #iFile
            strFileContent = Input(LOF(iFile), iFile)
            Application.Presentations(1).Slides(1).Shapes.Range(Array("textBox_Inhoud")).TextFrame.TextRange = strFileContent
            Close #iFile

           Sleep 5000
        Wend
    Else

    End If
    End Sub

结论：你没有使用真正的sleep函数。你正在做的是使用 CPU Cycle..

请注意，在此网站上找到了此答案中的一些信息：--> source

Answer 2

试试下面的

#If VBA7 Then

    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

#Else

    Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

#End If

Sub Update_textBox_Inhoud()

Dim FileName As String
TextFileName = "C:\paht\to\textfile.txt"
If Dir$(FileName) <> "" Then
    Application.Presentations(1).SlideShowSettings.Run
    Application.WindowState = ppWindowMinimized

    While True
        Dim strFilename As String: strFilename = TextFileName
        Dim strFileContent As String
        Dim iFile As Integer: iFile = FreeFile
        Open strFilename For Input As #iFile
        strFileContent = Input(LOF(iFile), iFile)
        Application.Presentations(1).Slides(1).Shapes.Range(Array("textBox_Inhoud")).TextFrame.TextRange = strFileContent
        Close #iFile

       Sleep 5000
    Wend
Else
    'Is there no code here?
End If
End Sub

它使用Sleep API 函数，该函数基于 Windows，因此不限于 Excel。

睡眠使用以毫秒为单位的值，因此在这种情况下您需要5000

编辑

#If VBA7 Then
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal _
    lpTimerFunc As Long) As Long

    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long 
#Else
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal _
    lpTimerFunc As Long) As Long

    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If


Dim lngTimerID As Long
Dim blnTimer As Boolean

Sub StartOnTime()
    If blnTimer Then
        lngTimerID = KillTimer(0, lngTimerID)
        If lngTimerID = 0 Then
            MsgBox "Error : Timer Not Stopped"
            Exit Sub
        End If
        blnTimer = False

    Else
        lngTimerID = SetTimer(0, 0, 5000, AddressOf Update_textBox_Inhoud)
        If lngTimerID = 0 Then
            MsgBox "Error : Timer Not Generated "
            Exit Sub
        End If
        blnTimer = True
    End If
End Sub

Sub KillOnTime()
    lngTimerID = KillTimer(0, lngTimerID)
    blnTimer = False
End Sub

Sub Update_textBox_Inhoud()

Dim FileName As String
TextFileName = "C:\paht\to\textfile.txt"
If Dir$(FileName) <> "" Then
    Application.Presentations(1).SlideShowSettings.Run
    Application.WindowState = ppWindowMinimized

    Dim strFilename As String: strFilename = TextFileName
    Dim strFileContent As String
    Dim iFile As Integer: iFile = FreeFile
    Open strFilename For Input As #iFile
    strFileContent = Input(LOF(iFile), iFile)
    Application.Presentations(1).Slides(1).Shapes.Range(Array("textBox_Inhoud")).TextFrame.TextRange = strFileContent
    Close #iFile
Else
    'Is there no code here?
End If
End Sub

根据this thread

Answer 3

要等待特定的时间，请在循环中调用WaitMessage，然后调用DoEvents。它不是 CPU 密集型的，并且 UI 将保持响应：

Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long


Public Sub Wait(Seconds As Double)
    Dim endtime As Double
    endtime = DateTime.Timer + Seconds
    Do
        WaitMessage
        DoEvents
    Loop While DateTime.Timer < endtime
End Sub