问题
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.
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?
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
- Note the flicker as Excel opens the file in the existing instance, and then hides it... because it's automation
- Note also, however, that there is no application object to work with, until the flickering is done. This is why I'm looking for some larger API method to "freeze" the screen.
回答1:
Try,
Application.VBE.MainWindow.Visible = False
If that doesn't work try
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal ClassName As String, ByVal WindowName As String) As Long
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hWndLock As Long) As Long
Sub EliminateScreenFlicker()
Dim VBEHwnd As Long
On Error GoTo ErrH:
Application.VBE.MainWindow.Visible = False
VBEHwnd = FindWindow("wndclass_desked_gsk", _
Application.VBE.MainWindow.Caption)
If VBEHwnd Then
LockWindowUpdate VBEHwnd
End If
'''''''''''''''''''''''''
' your code here
'''''''''''''''''''''''''
Application.VBE.MainWindow.Visible = False
ErrH:
LockWindowUpdate 0&
End Sub
Both found here Eliminating Screen Flicker During VBProject Code
回答2:
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
Hope someone else finds this useful.
回答3:
Ok you didn't mention multiple instances... [1. Open Excel--make sure you're only running one instance] :)
How about something like this.....
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal lHwnd As Long, _
ByVal lCmdShow As Long) As Boolean
Public Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Sub GetWindowHandle()
Const SW_HIDE As Long = 0
Const SW_SHOW As Long = 5
Const SW_MINIMIZE As Long = 2
Const SW_MAXIMIZE As Long = 3
'Const C_WINDOW_CLASS = "XLMAIN"
Const C_WINDOW_CLASS = vbNullString
Const C_FILE_NAME = "Microsoft Excel - Flickerbook.xlsx"
'Const C_FILE_NAME = vbNullString
Dim xlHwnd As Long
xlHwnd = FindWindow(lpClassName:=C_WINDOW_CLASS, _
lpWindowName:=C_FILE_NAME)
'Debug.Print xlHwnd
if xlHwnd = 0 then
Dim MyObj As Object
Dim objExcel As Excel.Application
Set objExcel = GetObject(, "Excel.Application")
objExcel.ScreenUpdating = False
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
MyObj.Close
objExcel.ScreenUpdating = True
else
'Either HIDE/SHOW or MINIMIZE/MAXIMISE
ShowWindow xlHwnd, SW_HIDE
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'manage MyObj
ShowWindow xlHwnd, SW_SHOW
'Or LockWindowUpdate then Unlock
LockWindowUpdate xlHwnd
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'manage MyObj
LockWindowUpdate 0
end if
' 'Get Window Name
' Dim strWindowTitle As String
' strWindowTitle = Space(260) ' We must allocate a buffer for the GetWindowText function
' Call GetWindowText(xlHwnd, strWindowTitle, 260)
' debug.print (strWindowTitle)
End Sub
来源：https://stackoverflow.com/questions/5680061/how-can-i-stop-excel-workbook-flicker-on-automation-open