Отключить проверку экрана для Powerpoint

Question

Я пишу скрипт, который проходит через папку и создает графики из некоторых критериев, а затем экспортирует их в powerpoint. На данный момент создание 130 графиков занимает 290 секунд, из которых 286 используются powerpoint. Я подозреваю, что основной причиной этого является невозможность отключить экранирование для PowerPoint. Я попытался использовать код отсюда http://skp.mvps.org/ppt00033.htm, чтобы решить эту проблему. Однако я не замечаю никакого эффекта. Хотя я могу использовать alt-tab и удерживать powerpoint в фоновом режиме, при переключении на Powerpoint все изменения отображаются, и вы можете в основном увидеть, как это замедляет работу программы. Кто-нибудь знает, как я должен использовать этот код? Должно ли это быть в модуле класса, я должен делать что-нибудь еще или что я делаю неправильно? Ниже приведен код, сниппет я позаимствовал и пример того, как я пытаюсь вызвать его:

Option Explicit 
' UserDefined Error codes 
Const ERR_NO_WINDOW_HANDLE As Long = 1000 
Const ERR_WINDOW_LOCK_FAIL As Long = 1001 
Const ERR_VERSION_NOT_SUPPORTED As Long = 1002 

' API declarations for FindWindow() & LockWindowUpdate() 
' Use FindWindow API to locate the PowerPoint handle. 
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Long) As Long 

' Use LockWindowUpdate to prevent/enable window refresh 
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long 

' Use UpdateWindow to force a refresh of the PowerPoint window 
Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long 

Property Let ScreenUpdating(State As Boolean) 

Static hwnd As Long 
Dim VersionNo As String 
' Get Version Number 
    If State = False Then 
     VersionNo = Left(Application.Version, InStr(1, Application.Version, ".") - 1) 
     'Get handle to the main application window using ClassName 
     Select Case VersionNo 
     Case "8" 
     ' For PPT97: 
      hwnd = FindWindow("PP97FrameClass", 0&) 
     Case "9" 
     ' For PPT2K: 
      hwnd = FindWindow("PP9FrameClass", 0&) 
     Case "10" 
     ' For XP: 
     hwnd = FindWindow("PP10FrameClass", 0&) 
     Case "11" 
     ' For 2003: 
     hwnd = FindWindow("PP11FrameClass", 0&) 
     Case "12" 
     ' For 2007: 
     hwnd = FindWindow("PP12FrameClass", 0&) 
     Case "14" 
     ' For 2010: 
     hwnd = FindWindow("PPTFrameClass", 0&) 
     Case Else 
     Err.Raise Number:=vbObjectError + ERR_VERSION_NOT_SUPPORTED, _ 
     Description:="Newer version." 
     Exit Property 
     End Select 

     If hwnd = 0 Then 
     Err.Raise Number:=vbObjectError + ERR_NO_WINDOW_HANDLE, _ 
     Description:="Unable to get the PowerPoint Window handle" 
     Exit Property 
     End If 

     If LockWindowUpdate(hwnd) = 0 Then 
       Err.Raise Number:=vbObjectError + ERR_WINDOW_LOCK_FAIL, _ 
     Description:="Unable to set a PowerPoint window lock" 
     Exit Property 
     Else 
     LockWindowUpdate (hwnd) 
     End If 

    Else 
    'Unlock the Window to refresh 
    LockWindowUpdate (0&) 
    UpdateWindow (hwnd) 
    hwnd = 0 
    End If 
End Property 


Sub TestSub() 
' Lock screen redraw 
If ScreenUpdatingOff = True Then ScreenUpdating = False 

' --- Loop through charts in Excel and export them to Powerpoint 
' Redraw screen again 
ScreenUpdating = True 

End Sub 

Большое спасибо заранее. Очень странно, что эта функциональность недоступна, теперь мне нужна ваша помощь!

Answer 1

Предполагая, что вы кладете код в модуле класса под названием Class1, вы создаете экземпляр в основном коде, как это ...

Dim myClass1 as Class1 

Set myClass1 = New Class1 

Class1.ScreenUpdating = False 

EDIT: Просто используйте код, как это было первоначально написано: нет необходимости добавить что-нибудь. Плохая новость заключается в том, что при тестировании в PPT 2013 не имеет никакого значения скорость. Вы можете проверить, работает ли она, оставив ее равной False.

модуль класса cScreenUpdating ...

Option Explicit 
' UserDefined Error codes 
Const ERR_NO_WINDOW_HANDLE As Long = 1000 
Const ERR_WINDOW_LOCK_FAIL As Long = 1001 
Const ERR_VERSION_NOT_SUPPORTED As Long = 1002 

' API declarations for FindWindow() & LockWindowUpdate() 
' Use FindWindow API to locate the PowerPoint handle. 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ 
       (ByVal lpClassName As String, _ 
       ByVal lpWindowName As Long) As Long 

' Use LockWindowUpdate to prevent/enable window refresh 
Private Declare Function LockWindowUpdate Lib "user32" _ 
       (ByVal hwndLock As Long) As Long 

' Use UpdateWindow to force a refresh of the PowerPoint window 

Private Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long 

Property Let ScreenUpdating(State As Boolean) 

Static hWnd As Long 
Dim VersionNo As String 

' Get Version Number 

    If State = False Then 
    VersionNo = Left(Application.Version, _ 
     InStr(1, Application.Version, ".") - 1) 

    'Get handle to the main application window using ClassName 

    Select Case VersionNo 

     Case "8" 
     ' For PPT97: 
      hWnd = FindWindow("PP97FrameClass", 0&) 
     Case "9" 
     ' For PPT2K: 
      hWnd = FindWindow("PP9FrameClass", 0&) 
     Case "10" 
     ' For XP: 
     hWnd = FindWindow("PP10FrameClass", 0&) 
     Case "11" 
     ' For 2003: 
     hWnd = FindWindow("PP11FrameClass", 0&) 
     Case "12" 
     ' For 2007: 
       hWnd = FindWindow("PP12FrameClass", 0&) 
     Case "14", "15" 
     ' For 2010: 
       hWnd = FindWindow("PPTFrameClass", 0&) 
     Case Else 
     Err.Raise Number:=vbObjectError + ERR_VERSION_NOT_SUPPORTED, _ 
     Description:="Newer version." 
     Exit Property 

    End Select 

    If hWnd = 0 Then 
    ' window was not found... 
     Err.Raise Number:=vbObjectError + ERR_NO_WINDOW_HANDLE, _ 
     Description:="Unable to get the PowerPoint Window handle" 
     Exit Property 
    End If 

    'Attempt to lock the window 
    If LockWindowUpdate(hWnd) = 0 Then 
    ' attempt failed... 
     Err.Raise Number:=vbObjectError + ERR_WINDOW_LOCK_FAIL, _ 
     Description:="Unable to set a PowerPoint window lock" 
     Exit Property 

    End If 

    Else 'State = True 
    'Unlock the Window to refresh 
    LockWindowUpdate (0&) 
    UpdateWindow (hWnd) 
    hWnd = 0 
    End If 

End Property 

Пример использования ...

Set appObject = New cScreenUpdating 
    appObject.ScreenUpdating = False 
    ' code here 
    appObject.ScreenUpdating = True