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 函数。

虽然运行使用此宏，但我的 CPU 第七代 i5 的负载上升到 36%。自助服务机的电脑硬件稍差，所以 CPU 负载会很高，这台电脑的风扇会发出很大的噪音。

我认为睡眠/等待功能并不是真的"sleep"，它只是继续循环直到 5 秒过去。

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

Answer 1

Sleep不需要CPU周期。

Sleep 是一个 windows 函数而不是 VBA 函数，但您仍然可以通过调用 windows 在 VBA 代码中使用此函数SleepAPI。实际上 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 循环..

请注意，此答案中的一些信息是在此网站上找到的：--> 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。

Sleep 使用以毫秒为单位的值，因此在这种情况下您需要 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 followed by 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

PowerPoint VBA 中的睡眠/等待计时器并不 CPU 密集

Sleep / wait timer in PowerPoint VBA that's not CPU intensive

powerpoint

vba

sleep

wait