PowerPoint VBA 中的睡眠/等待计时器不占用 CPU 资源

问题描述 投票：0回答：4

我目前正在制作一个 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 密集程度较低的方法来创建睡眠函数？

vba powerpoint wait sleep
4个回答
9
投票

要等待特定时间，请循环调用 

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
0
投票

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..

请注意，此答案中的一些信息是在本网站上找到的：-->来源

0
投票

尝试以下方法

#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

根据此线程

0
投票

这是我的终极睡眠程序，具有所有好处：

  • <0.0% CPU
  • 做活动
  • 精度±<10ms
Public Declare PtrSafe Sub SleepWinAPI Lib "kernel32" Alias "Sleep" (ByVal milliseconds As Long)
Public Declare PtrSafe Function GetFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (ByRef Frequency As Currency) As Long
Public Declare PtrSafe Function GetTime Lib "kernel32" Alias "QueryPerformanceCounter" (ByRef counter As Currency) As Long

Public Sub sleep(ByVal ms As Currency)
    'Enhanced sleep proc. featuring <0.0% CPU usage, DoEvents, precision +-<10ms
    'Better Sleep proc. featuring <0.0% CPU usage, DoEvents, precision +-<10ms
    'Uses "Currency" as a good-enough workaround to avoid the complexity of a LARGE_INTEGER (see https://stackoverflow.com/a/31387007)
    'Note: VBA.Timer ( + VBA.Date for midnight adjustment) and VBA.Now avoided for accuracy issues (10-15ms and occasionally even worse? see https://stackoverflow.com/questions/68767198/is-this-unstable-vba-timer-behavior-real-or-am-i-doing-something-wrong)
    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 (SleepWinAPI alone costs 2-15ms and DoEvents 2-8ms)
        Do
            GetTime cTimeEnd
        Loop Until cTimeEnd - cTimeStart >= cTimeTarget
        Exit Sub
    Else 'fully featured loop
        SleepWinAPI 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
            SleepWinAPI 1
            DoEvents
            GetTime cTimeEnd
        Loop
    End If
End Sub
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.