代码之家  ›  专栏  ›  技术社区  ›  PowerUser

用于关闭除自身以外的所有Excel实例的VBA脚本

  •  3
  • PowerUser  · 技术社区  · 15 年前

    我的错误处理函数中有一个子例程,它试图关闭每个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
    

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

    我怎么重写这个来结束 全部的 不保存任何更改的Excel?

    额外贷款:

    如何在不关闭承载此脚本的访问文件的情况下为Access执行此操作?

    6 回复  |  直到 11 年前
        1
  •  3
  •   Edward Leno    15 年前

    我刚刚用Excel和Access尝试了以下操作:

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

    如果将msaccess.exe更改为excel.exe,Excel将被终止。

    如果您希望对流程有更多的控制,请查看:

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

        2
  •  4
  •   HansUp    15 年前

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

    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
    

    在我看来,getobject返回“最旧”的访问实例。这样,Sub会关闭在运行Sub之前启动的所有访问实例。一旦找到它自己,它就会停止。也许这对你的情况没什么影响。但是,如果您还需要关闭运行代码之后启动的访问实例,请查看WindowsAPI窗口句柄函数。

    我没有在Excel中尝试这种方法。但我确实看到Excel提供了application.hwnd和application.hinstance…所以我怀疑你也可以做类似的事情。

    还有,注意我已经摆脱了 On Error Resume Next . GetObject将始终返回此子中的应用程序对象,因此它不起任何作用。另外,我尽量避免 出错时继续下一个 一般来说。

    更新 :由于GetObject不会为您执行该作业,请使用其他方法获取所有访问实例的窗口句柄。关闭窗口句柄与要退出运行的窗口句柄不匹配的每个窗口(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
    
        3
  •  2
  •   Jay    15 年前

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

    这些年来,我一直在努力解决这个问题,但从未像以前那样取得过巨大的成功。

    我认为它的长处和短处在于,您永远不知道您所引用的应用程序实例是否是正在执行代码的实例(因此终止它可能会使其他实例处于打开状态)。

        4
  •  2
  •   John    12 年前

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

    模块…………

    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
    

    代码…

    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
    

    我希望这能帮助别人:)

        5
  •  1
  •   NorthCat    11 年前

    这是对一篇旧文章的回应,但和2012年的海报一样,希望它能帮助那些基于普通网络搜索来这里的人。

    背景 我的公司使用XLSX“模型”自动将我们的数据转换为“漂亮”。数据从SAS导出为XLS;我们没有要导出为XLSX的许可证或附加组件。通常的过程是将14个SAS输出中的每一个都复制/粘贴到XLSX中。下面的代码迭代前两个导出,其中数据从XLS复制,粘贴到XLSX,XLS关闭。

    请注意: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
    

    你需要明确地限定你的陈述。即代替 Workbooks("Book_Name") 一定要确定你所指的应用程序,是吗? Application.Workbooks("Book_Name") xlApp1.Workbooks("Book_Name")

        6
  •  0
  •   Beth    15 年前

    试着把它放在一个循环里

    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