如何在自动化打开时停止Excel工作簿闪烁？ [英] How can I stop Excel workbook flicker on automation open?

问题描述

我正在使用GetObject与工作簿路径来创建一个新的或抓住现有的Excel实例。如果它正在抓住现有的用户创建的实例，应用程序窗口是可见的;如果相关工作簿路径关闭，它将打开和隐藏，但不会在屏幕上闪烁。 Application.ScreenUpdating 对此没有帮助。

I'm using GetObject with a workbook path to either create a new or grab an existing Excel instance. If it's grabbing an existing user-created instance, the application window is visible; if the workbook path in question is closed, it will open and hide, but not before it flickers on the screen. Application.ScreenUpdating does not help with this.

我不认为我可以使用Win32Api调用LockWindowUpdate，因为我不知道在文件打开之前是否获取或创建。有没有一些其他VBA友好的方式（即WinAPI）冻结屏幕足够长以获取对象？

I don't think I can use the Win32Api call LockWindowUpdate, because I don't know whether I'm getting or creating before the file is open. Is there some other VBA-friendly way (i.e. WinAPI) to freeze the screen long enough to get the object?

编辑：只是为了澄清，因为第一个答案建议使用Application对象...这些是重现此行为的步骤。
1.打开Excel - 确保您只运行一个实例 - 保存并关闭默认工作簿。 Excel窗口现在可见但空
2.打开Powerpoint或Word，插入模块，添加以下代码

EDIT: Just to clarify, because the first answer suggests using the Application object... These are the steps to reproduce this behavior. 1. Open Excel--make sure you're only running one instance--save and close the default workbook. Excel window now visible but "empty" 2. Open Powerpoint or Word, insert a module, add the following code

Public Sub Open_SomeWorkbook()
    Dim MyObj   As Object
    Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
    'uncomment the next line to see the workbook again'
    'MyObj.Parent.Windows(MyObj.Name).Visible = True'

    'here's how you work with the application object... after the fact'
    Debug.Print MyObj.Parent.Version
End Sub

1. 注意闪烁，因为Excel在现有实例中打开文件，然后隐藏它...因为它是自动化


2. 但是，请注意，没有应用程序对象可以使用，直到闪烁完成。这就是为什么我正在寻找一些更大的API方法来冻结屏幕。

推荐答案

p>我最终基本上放弃了GetObject，因为它不够细腻，并且写了我自己的flickerless开启者，有一些来自osknows的灵感和来自这里和 here 。以为我会分享它，以防其他人觉得有用。首先完整的模块

I ended up basically ditching GetObject, because it wasn't granular enough, and wrote my own flickerless opener, with some inspiration from osknows and great code samples from here and here. Thought I would share it in case others found it useful. First the complete module

'looping through, parent and child (see also callbacks for lpEnumFunc)
Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, _
                                                       ByVal lParam As Long) As Long

Private Declare Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As Long, _
                                                            ByVal lpEnumFunc As Long, _
                                                            ByVal lParam As Long) As Long

'title of window
Private Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long

Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, _
                                                                                ByVal lpString As String, _
                                                                                ByVal cch As Long) As Long


'class of window object
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, _
                                                                          ByVal lpClassName As String, _
                                                                          ByVal nMaxCount As Long) As Long

'control window display
Private Declare Function ShowWindow Lib "user32" (ByVal lHwnd As Long, _
                                                  ByVal lCmdShow As Long) As Boolean
Private Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long

Public Enum swcShowWindowCmd
    swcHide = 0
    swcNormal = 1
    swcMinimized = 2 'but activated
    swcMaximized = 3
    swcNormalNoActivate = 4
    swcShow = 5
    swcMinimize = 6 'activates next
    swcMinimizeNoActivate = 7
    swcShowNoActive = 8
    swcRestore = 9
    swcShowDefault = 10
    swcForceMinimized = 11
End Enum


'get application object using accessibility
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, _
                                                                  ByVal dwId As Long, _
                                                                  ByRef riid As GUID, _
                                                                  ByRef ppvObject As Object) _
                                                                  As Long

Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, _
                                                    ByRef lpiid As GUID) As Long

'Const defined in winuser.h
Private Const OBJID_NATIVEOM    As Long = &HFFFFFFF0
'IDispath pointer to native object model
Private Const Guid_Excel     As String = "{00020400-0000-0000-C000-000000000046}"

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

'class names to search by (Excel, in this example, is XLMAIN)
Private mstrAppClass            As String
'title (a.k.a. pathless filename) to search for
Private mstrFindTitle           As String
'resulting handle outputs - "default" app instance and child with object
Private mlngFirstHwnd           As Long
Private mlngChildHwnd           As Long

'------
'replacement GetObject
'------
Public Function GetExcelWbk(pstrFullName As String, _
                   Optional pbleShow As Boolean = False, _
                   Optional pbleWasOpenOutput As Boolean) As Object

    Dim XLApp           As Object
    Dim xlWbk           As Object
    Dim strWbkNameOnly  As String

    Set XLApp = GetExcelAppForWbkPath(pstrFullName, pbleWasOpenOutput)

    'other stuff can be done here if the app needs to be prepared for the load

    If pbleWasOpenOutput = False Then
        'load it, without flicker, if you plan to show it
        If pbleShow = False Then
            XLApp.ScreenUpdating = False
        End If
        Set xlWbk = XLApp.Workbooks.Open(pstrFullName)
    Else
        'get it by its (pathless, if saved) name
        strWbkNameOnly = PathOrFileNm("FileNm", pstrFullName)
        Set xlWbk = XLApp.Workbooks(strWbkNameOnly)
    End If

    Set GetExcelWbk = xlWbk

    Set xlWbk = Nothing
    Set XLApp = Nothing
End Function

Private Function GetExcelAppForWbkPath(pstrFullName As String, _
                                       pbleWbkWasOpenOutput As Boolean, _
                              Optional pbleLoadAddIns As Boolean = True) As Object

    Dim XLApp           As Object
    Dim bleAppRunning   As Boolean
    Dim lngHwnd         As Long

    'get a handle, and determine whether it's for a workbook or an app instance
    lngHwnd = WbkOrFirstAppHandle(pstrFullName, pbleWbkWasOpenOutput)

    'if a handle came back, at least one instance of Excel is running
    '(this isnt' particularly useful; just check XLApp.Visible when you're done getting/opening;
    'if it's a hidden instance, it wasn't running)
    bleAppRunning = (lngHwnd > 0)

    'get an app instance.
    Set XLApp = GetAppForHwnd(lngHwnd, pbleWbkWasOpenOutput, pbleLoadAddIns)

    Set GetExcelAppForWbkPath = XLApp

    Set XLApp = Nothing
    Exit Function
End Function

Private Function WbkOrFirstAppHandle(pstrFullName As String, _
                                     pbleIsChildWindowOutput As Boolean) As Long

    Dim retval  As Long

    'defaults
    mstrAppClass = "XLMAIN"
    mstrFindTitle = PathOrFileNm("FileNm", pstrFullName)
    mlngFirstHwnd = 0
    mlngChildHwnd = 0

    'find
    retval = EnumWindows(AddressOf EnumWindowsProc, 0)

    If mlngChildHwnd > 0 Then
        pbleIsChildWindowOutput = True
        WbkOrFirstAppHandle = mlngChildHwnd
    Else
        WbkOrFirstAppHandle = mlngFirstHwnd
    End If

    'clear
    mstrAppClass = ""
    mstrFindTitle = ""
    mlngFirstHwnd = 0
    mlngChildHwnd = 0
End Function

Private Function GetAppForHwnd(plngHWnd As Long, _
                               pbleIsChild As Boolean, _
                               pbleLoadAddIns As Boolean) As Object
On Error GoTo HandleError

    Dim XLApp   As Object
    Dim AI      As Object

    If plngHWnd > 0 Then
        If pbleIsChild = True Then
            'get the parent instance using accessibility
            Set XLApp = GetExcelAppForHwnd(plngHWnd)
        Else
            'get the "default" instance
            Set XLApp = GetObject(, "Excel.Application")
        End If
    Else
        'no Excel running
        Set XLApp = CreateObject("Excel.Application")
        If pbleLoadAddIns = True Then
            'explicitly reload add-ins (automation doesn't)
            For Each AI In XLApp.AddIns
                If AI.Installed Then
                    AI.Installed = False
                    AI.Installed = True
                End If
            Next AI
        End If
    End If

    Set GetAppForHwnd = XLApp

    Set AI = Nothing
    Set XLApp = Nothing
    Exit Function
End Function

'------
'API wrappers and utilities
'------
Public Function uWindowClass(ByVal hWnd As Long) As String
    Dim strBuffer   As String
    Dim retval      As Long
    strBuffer = Space(256)
    retval = GetClassName(hWnd, strBuffer, 255)
    uWindowClass = Left(strBuffer, retval)
End Function

Public Function uWindowTitle(ByVal hWnd As Long) As String
    Dim lngLen      As Long
    Dim strBuffer   As String
    Dim retval      As Long

    lngLen = GetWindowTextLength(hWnd) + 1
    If lngLen > 1 Then
        'title found - pad buffer
        strBuffer = Space(lngLen)
        '...get titlebar text
        retval = GetWindowText(hWnd, strBuffer, lngLen)
        uWindowTitle = Left(strBuffer, lngLen - 1)
    End If
End Function

Public Sub uShowWindow(ByVal hWnd As Long, _
              Optional pShowType As swcShowWindowCmd = swcRestore)
    Dim retval  As Long
    retval = ShowWindow(hWnd, pShowType)

    Select Case pShowType
        Case swcMaximized, swcNormal, swcRestore, swcShow
            BringWindowToTop hWnd
            SetFocus hWnd
    End Select

End Sub

Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
    Dim strThisClass    As String
    Dim strThisTitle    As String
    Dim retval          As Long
    Dim bleMatch        As Boolean

    'mlngWinCounter = mlngWinCounter + 1
    'type of window is all you need for parent
    strThisClass = uWindowClass(hWnd)
    bleMatch = (strThisClass = mstrAppClass)

    If bleMatch = True Then
        strThisTitle = uWindowTitle(hWnd)
        'Debug.Print "Window #"; mlngWinCounter; " : ";
        'Debug.Print strThisTitle; "(" & strThisClass & ") " & hWnd
        If mlngFirstHwnd = 0 Then mlngFirstHwnd = hWnd

        'mlngChildWinCounter  0
        retval = EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)

        If mlngChildHwnd > 0 Then
        'If mbleFindAll = False And mlngChildHwnd > 0 Then
            'stop EnumWindows by setting result to 0
            EnumWindowsProc = 0
        Else
            EnumWindowsProc = 1
        End If
    Else
        EnumWindowsProc = 1
    End If
End Function

Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
    Dim strThisClass    As String
    Dim strThisTitle    As String
    Dim retval          As Long
    Dim bleMatch        As Boolean

    strThisClass = uWindowClass(hWnd)
    strThisTitle = uWindowTitle(hWnd)

    If Len(mstrFindTitle) > 0 Then
        bleMatch = (strThisTitle = mstrFindTitle)
    Else
        bleMatch = True
    End If

    If bleMatch = True Then
        mlngChildHwnd = hWnd
        EnumChildProc = 0
    Else
        EnumChildProc = 1
    End If

End Function

Public Function GetExcelAppForHwnd(pChildHwnd As Long) As Object
    Dim o       As Object
    Dim g       As GUID
    Dim retval  As Long

    'for child objects only, e.g. must use a loaded workbook to get its parent Excel.Application

    'make a valid GUID type
    retval = IIDFromString(StrPtr(Guid_Excel), g)
    'get
    retval = AccessibleObjectFromWindow(pChildHwnd, OBJID_NATIVEOM, g, o)
    If retval >= 0 Then
        Set GetExcelAppForHwnd = o.Application
    End If
End Function

Public Function PathOrFileNm(pstrPathOrFileNm As String, _
                             pstrFileNmWithPath As String)
On Error GoTo HandleError

    Dim i       As Integer
    Dim j       As Integer
    Dim strChar As String

    If Len(pstrFileNmWithPath) > 0 Then
        i = InStrRev(pstrFileNmWithPath, "\")
        If i = 0 Then
            i = InStrRev(pstrFileNmWithPath, "/")
        End If

        If i > 0 Then
            Select Case pstrPathOrFileNm
                Case "Path"
                    PathOrFileNm = Left(pstrFileNmWithPath, i - 1)
                Case "FileNm"
                    PathOrFileNm = Mid(pstrFileNmWithPath, i + 1)
            End Select
        ElseIf pstrPathOrFileNm = "FileNm" Then
            PathOrFileNm = pstrFileNmWithPath
        End If
    End If

End Function

然后一些样本/测试代码。

And then some sample/test code.

Public Sub Test_GetExcelWbk()
    Dim MyXLApp         As Object
    Dim MyXLWbk         As Object
    Dim bleXLWasRunning As Boolean
    Dim bleWasOpen      As Boolean

    Const TESTPATH      As String = "C:\temp\MyFlickerbook.xlsx"
    Const SHOWONLOAD    As Boolean = False

    Set MyXLWbk = GetExcelWbk(TESTPATH, SHOWONLOAD, bleWasOpen)

    If Not (MyXLWbk Is Nothing) Then
        Set MyXLApp = MyXLWbk.Parent
        bleXLWasRunning = MyXLApp.Visible

        If SHOWONLOAD = False Then
            If MsgBox("Show " & TESTPATH & "?", vbOKCancel) = vbOK Then
                MyXLApp.Visible = True
                MyXLApp.Windows(MyXLWbk.Name).Visible = True
            End If
        End If
        If bleWasOpen = False Then
            If MsgBox("Close " & TESTPATH & "?", vbOKCancel) = vbOK Then
                MyXLWbk.Close SaveChanges:=False

                If bleXLWasRunning = False Then
                    MyXLApp.Quit
                End If
            End If
        End If
    End If

    Set MyXLWbk = Nothing
    Set MyXLApp = Nothing
End Sub

希望有人发现这有用。

这篇关于如何在自动化打开时停止Excel工作簿闪烁？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！