VBA 脚本关闭除自身之外的每个 Excel 实例

VBA script to close every instance of Excel except itself

提问by PowerUser

I have a subroutine in my errorhandling function that attempts to close every workbook open in every instance of Excel. Otherwise, it might stay in memory and break my next vbscript. It should also close every workbook withoutsaving any changes.

我的错误处理函数中有一个子例程，它尝试关闭在 Excel 的每个实例中打开的每个工作簿。否则，它可能会留在内存中并破坏我的下一个 vbscript。它还应该关闭每个工作簿而不保存任何更改。

Sub CloseAllExcel()
On Error Resume Next
    Dim ObjXL As Excel.Application
    Set ObjXL = GetObject(, "Excel.Application")
    If Not (ObjXL Is Nothing) Then
        Debug.Print "Closing XL"
        ObjXL.Application.DisplayAlerts = False
        ObjXL.Workbooks.Close
        ObjXL.Quit
        Set ObjXL = Nothing
    Else
        Debug.Print "XL not open"
    End If
End Sub

This code isn't optimal, however. For example, it can close 2 workbooks in one instance of Excel, but if you open 2 instances of excel, it will only close out 1.

但是，此代码不是最佳的。例如，它可以在一个 Excel 实例中关闭 2 个工作簿，但是如果打开 2 个 Excel 实例，它只会关闭 1 个。

How can I rewrite this to close allExcel without saving any changes?

如何重写它以关闭所有Excel 而不保存任何更改？

Extra Credit:

额外学分：

How to do this for Access as well without closing the Access file that is hosting this script?

如何在不关闭托管此脚本的 Access 文件的情况下为 Access 执行此操作？

采纳答案by Edward Leno

I just tried the following with both Excel and Access :

我只是在 Excel 和 Access 中尝试了以下操作：

Dim sKill As String

sKill = "TASKKILL /F /IM msaccess.exe"
Shell sKill, vbHide

If you change the msaccess.exe to excel.exe, excel will be killed.

如果把msaccess.exe改成excel.exe，excel就会被杀掉。

If you want a bit more control over the process, check out:

如果您想对流程进行更多控制，请查看：

http://www.vbaexpress.com/kb/getarticle.php?kb_id=811

http://www.vbaexpress.com/kb/getarticle.php?kb_id=811

回答by HansUp

You should be able to use window handles for this.

您应该能够为此使用窗口句柄。

Public Sub CloseAllOtherAccess()
    Dim objAccess As Object
    Dim lngMyHandle As Long
    Dim strMsg As String

On Error GoTo ErrorHandler
    lngMyHandle = Application.hWndAccessApp

    Set objAccess = GetObject(, "Access.Application")
    Do While TypeName(objAccess) = "Application"
        If objAccess.hWndAccessApp <> lngMyHandle Then
            Debug.Print "found another Access instance: " & _
                objAccess.hWndAccessApp
            objAccess.Quit acQuitSaveNone
        Else
            Debug.Print "found myself"
            Exit Do
        End If
        Set objAccess = GetObject(, "Access.Application")
    Loop

ExitHere:
    Set objAccess = Nothing
    On Error GoTo 0
    Exit Sub

ErrorHandler:
    strMsg = "Error " & Err.Number & " (" & Err.Description _
        & ") in procedure CloseAllOtherAccess"
    MsgBox strMsg
    GoTo ExitHere
End Sub

It appears to me GetObject returns the "oldest" Access instance. So that sub closes all Access instances started before the one which is running the sub. Once it finds itself, it stops. Maybe that's fine for your situation. But if you need to also close Access instances started after the one which is running the code, look to Windows API window handle functions.

在我看来 GetObject 返回“最旧的”Access 实例。这样子会关闭在运行子之前启动的所有 Access 实例。一旦它发现自己，它就会停止。也许这适合你的情况。但是，如果您还需要关闭在运行代码之后启动的 Access 实例，请查看 Windows API 窗口句柄函数。

I didn't try this approach for Excel. But I did see Excel provides Application.Hwnd and Application.Hinstance ... so I suspect you can do something similar there.

我没有为 Excel 尝试这种方法。但我确实看到 Excel 提供了 Application.Hwnd 和 Application.Hinstance ......所以我怀疑你可以在那里做类似的事情。

Also, notice I got rid of On Error Resume Next. GetObject will always return an Application object in this sub, so it didn't serve any purpose. Additionally, I try to avoid On Error Resume Nextin general.

另外，请注意我摆脱了On Error Resume Next. GetObject 将始终在此子程序中返回一个 Application 对象，因此它没有任何用途。此外，我尽量避免On Error Resume Next一般。

Update: Since GetObject won't do the job for you, use a different method to get the window handles of all the Access instances. Close each of them whose window handle doesn't match the one you want to leave running (Application.hWndAccessApp).

更新：由于 GetObject 不会为您完成这项工作，因此请使用不同的方法来获取所有 Access 实例的窗口句柄。关闭每个窗口句柄与您要保持运行的窗口句柄不匹配的程序 (Application.hWndAccessApp)。

Public Sub CloseAllAccessExceptMe()
'FindWindowLike from: '
'How To Get a Window Handle Without Specifying an Exact Title '
'http://support.microsoft.com/kb/147659 '

'ProcessTerminate from: '
'Kill a Process through VB by its PID '
'http://en.allexperts.com/q/Visual-Basic-1048/Kill-Process-VB-its-1.htm '

    Dim lngMyHandle As Long
    Dim i As Long
    Dim hWnds() As Long

    lngMyHandle = Application.hWndAccessApp

    ' get array of window handles for all Access top level windows '
    FindWindowLike hWnds(), 0, "*", "OMain", Null

    For i = 1 To UBound(hWnds())
        If hWnds(i) = lngMyHandle Then
            Debug.Print hWnds(i) & " -> leave myself running"
        Else
            Debug.Print hWnds(i) & " -> close this one"
            ProcessTerminate , hWnds(i)
        End If
    Next i
End Sub

回答by Jay

Differentiating open instances of an application is a very old problem, and it is not unique to VBA.

区分应用程序的开放实例是一个非常古老的问题，它不是 VBA 独有的。

I've tried to figure this out myself over the years, never with greater success than the time before.

多年来，我一直试图自己解决这个问题，但从未取得比以前更大的成功。

I think the long and short of it is that you can never know if the application instance you're referencing is the one in which the code is executing (so terminating it might leave other instances open).

我认为总而言之，您永远无法知道您引用的应用程序实例是否是正在执行代码的应用程序实例（因此终止它可能会使其他实例保持打开状态）。

回答by John

I know this is an old post but for those who visit here from searches may find it helpful. This code was found and modified. It will give you every SHEET in every WORKBOOK in every INSTANCE. From there you can determine the active instance.

我知道这是一个旧帖子，但对于那些通过搜索访问这里的人可能会发现它有帮助。找到并修改了此代码。它将为您提供每个实例中每个工作簿中的每个工作表。从那里您可以确定活动实例。

Module..............

模块..............

Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

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

Code…………………...

代码…………………...

Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0

Sub ListAll()
    Dim I As Integer
    Dim hWndMain As Long
    On Error GoTo MyErrorHandler
        hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
        I = 1
        Do While hWndMain <> 0
            Debug.Print "Excel Instance " & I
            GetWbkWindows hWndMain
            hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
            I = I + 1
        Loop
        Exit Sub
    MyErrorHandler:
    MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Sub GetWbkWindows(ByVal hWndMain As Long)
    Dim hWndDesk As Long
    Dim hWnd As Long
    Dim strText As String
    Dim lngRet As Long
    On Error GoTo MyErrorHandler     
        hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
        If hWndDesk <> 0 Then
            hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString) 
            Do While hWnd <> 0
                strText = String$(100, Chr$(0))
                lngRet = GetClassName(hWnd, strText, 100)
                If Left$(strText, lngRet) = "EXCEL7" Then
                    GetExcelObjectFromHwnd hWnd
                    Exit Sub
                End If
                hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
            Loop
            On Error Resume Next
        End If
            Exit Sub
    MyErrorHandler:
        MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
    Dim fOk As Boolean
    Dim I As Integer
    Dim obj As Object
    Dim iid As UUID
    Dim objApp As Excel.Application
    Dim myWorksheet As Worksheet
    On Error GoTo MyErrorHandler        
        fOk = False
        Call IIDFromString(StrPtr(IID_IDispatch), iid)
        If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
            Set objApp = obj.Application
            For I = 1 To objApp.Workbooks.Count
                Debug.Print "     " & objApp.Workbooks(I).Name
                For Each myWorksheet In objApp.Workbooks(I).Worksheets
                    Debug.Print "          " & myWorksheet.Name
                    DoEvents
                Next
                fOk = True
            Next I
        End If
        GetExcelObjectFromHwnd = fOk
        Exit Function
    MyErrorHandler:
        MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

I hope this helps someone :)

我希望这可以帮助别人 ：）

回答by user3756574

This is a response to an old post, but same as the poster in 2012, hopefully it helps someone who may come here based on a generic web search.

这是对旧帖子的回应，但与 2012 年的海报相同，希望它可以帮助那些基于通用网络搜索来到这里的人。

Background My company uses XLSX "models" to turn our data into "pretty" automatically. The data exports from SAS as XLS; we do not have the licensing or add-ons to export as XLSX. The normal process is to copy/paste each of the 14 SAS outputs into the XLSX. The code below iterates through the first two exports where data is copied from the XLS, pasted into the XLSX, and the XLS closed.

背景我公司使用XLSX“模型”自动将我们的数据变成“漂亮”。从SAS导出的数据为XLS；我们没有许可证或附加组件以导出为 XLSX。正常过程是将 14 个 SAS 输出中的每一个复制/粘贴到 XLSX。下面的代码遍历前两个导出，其中数据从 XLS 复制，粘贴到 XLSX，然后关闭 XLS。

Please note: The XLSX file is saved to the hard drive. The XLS files are NOT SAVED, i.e. the path goes to "My Documents/"but there is no file name or file visible there.

请注意：XLSX 文件保存在硬盘上。XLS 文件未保存，即路径转到"My Documents/"但那里没有文件名或文件可见。

Sub Get_data_from_XLS_to_XLSX ()
    Dim xlApp1 As Excel.Application
    Dim xlApp2 As Excel.Application

'Speed up processing by turning off Automatic Calculations and Screen Updating
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False


'Copies data from Book1 (xls) and pastes into ThisWorkbook (xlsx), then closes xls file
    Set xlApp1 = GetObject("Book1").Application

    xlApp1.Workbooks("Book1").Sheets("Sheet1").Range("A2:E2").Copy
    Application.ThisWorkbook.Worksheets("Data1").Cells(5, 2).PasteSpecialPaste:=xlPasteValues

'Clears the clipboard, turns off the "do you want to save" alert, closes xls file
    xlApp1.CutCopyMode = False
    xlApp1.DisplayAlerts = False
    xlApp1.Quit
    xlApp1.DisplayAlerts = True



'Same as the first one above, but now it's a second/different xls file, i.e. Book2
    Set xlApp2 = GetObject("Book2").Application

    xlApp2.Workbooks("Book2").Sheets("Sheet1").Range("A2:E2").Copy
    Application.ThisWorkbook.Sheets("Data2").Cells(10, 2).PasteSpecial Paste:=xlPasteValues

'Clears the clipboard, turns off the "do you want to save" alert, closes xls file
    xlApp2.CutCopyMode = False
    xlApp2.DisplayAlerts = False
    xlApp2.Quit
    xlApp2.DisplayAlerts = True


'Sub continues for 12 more iterations of similar code
End Sub

You need to be explicit in qualifying your statements. i.e. instead of Workbooks("Book_Name")make sure you identify the application you are referring to, be it Application.Workbooks("Book_Name")or xlApp1.Workbooks("Book_Name")

您需要明确限定您的陈述。即而不是Workbooks("Book_Name")确保您确定您所指的应用程序，无论是它Application.Workbooks("Book_Name")还是xlApp1.Workbooks("Book_Name")

回答by Beth

try putting it in a loop

试着把它放在一个循环中

Set ObjXL = GetObject(, "Excel.Application")
do until ObjXL Is Nothing
        Debug.Print "Closing XL"
        ObjXL.Application.DisplayAlerts = False
        ObjXL.Workbooks.Close
        ObjXL.Quit
        Set ObjXL = Nothing
        Set ObjXL = GetObject(, "Excel.Application")  ' important!
loop