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

Question

我目前正在使用PowerPoint演示文稿，该演示文稿正在计算机上用作某种信息亭或信息屏幕。它从磁盘上的文本文件中读取文本。此文本文件中的文本显示在PowerPoint的文本框中，每5秒钟进行一次刷新。这样，我们可以在PowerPoint中编辑文本而无需编辑PowerPoint演示文稿本身，以便它继续运行。到目前为止，工作得很好，只有PowerPoint VBA不包含应用程序。等待功能。请参阅此处的完整子：

Sub Update_textBox_Inhoud()
Dim FileName As String
TextFileName = "C:pahttotextfile.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没有应用程序。等待功能。

在运行此宏时，我的第7代i5上的CPU负载可达36％。售货亭计算机的硬件稍差，因此CPU负载将很高，并且该PC的粉丝会发出很多噪音。

我认为睡眠/等待功能并不是真正"睡眠"，它一直持续到5秒之前。

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

Answer 1

等待特定的时间，请致电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

Answer 2

这是我的终极睡眠过程，共同包含所有好处：

• ＆lt; 0.0％CPU
• doevents
• 准确性 - ＆lt; 10ms

---

Public Sub Sleep(ms As Currency)
    Dim cTimeStart As Currency, cTimeEnd As Currency
    Dim dTimeElapsed As Currency, cTimeTarget As Currency
    Dim cApproxDelay As Currency
    
    getTime cTimeStart
    
    Static cPerSecond As Currency
    If cPerSecond = 0 Then getFrequency cPerSecond
    
    cTimeTarget = ms * (cPerSecond / 1000)
    
    If ms <= 25 Then
        'empty loop for improved accuracy (SleepAPI alone costs 2-15ms and DoEvents 2-8ms)
        Do
            getTime cTimeEnd
        Loop Until cTimeEnd - cTimeStart >= cTimeTarget
        Exit Sub
    Else 'fully featured loop
        SleepAPI 5 '"WaitMessage" avoided because it costs 0.0* to 2**(!) ms
        DoEvents
        getTime cTimeEnd
        cApproxDelay = (cTimeEnd - cTimeStart) / 2
        
        cTimeTarget = cTimeTarget - cApproxDelay
        Do While (cTimeEnd - cTimeStart) < cTimeTarget
            SleepAPI 1
            DoEvents
            getTime cTimeEnd
        Loop
    End If
End Sub

Answer 3

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:pahttotextfile.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 4

尝试以下

#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:pahttotextfile.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:pahttotextfile.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

根据此线程