我的错误处理函数中有一个子例程，它试图关闭每个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文件的情况下为Access执行此操作？
答案 0 :(得分：4)
您应该可以使用窗口句柄。
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返回“最老的”Access实例。因此，sub关闭在运行sub之前启动的所有Access实例。一旦发现自己，它就会停止。也许那对你的情况很好。但是，如果您还需要关闭在运行代码之后启动的Access实例，请查看Windows API窗口句柄函数。
我没有为Excel尝试这种方法。但我确实看到Excel提供Application.Hwnd和Application.Hinstance ......所以我怀疑你可以在那里做类似的事情。
另外，请注意我摆脱了On Error Resume Next。 GetObject将始终返回此子对象中的Application对象，因此它不会用于任何目的。另外，我总体上试图避免使用On Error Resume Next。
更新：由于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
答案 1 :(得分：3)
我刚用Excel和Access尝试了以下内容：
Dim sKill As String
sKill = "TASKKILL /F /IM msaccess.exe"
Shell sKill, vbHide
如果将msaccess.exe更改为excel.exe，则将终止excel。
如果您想要更多地控制该过程，请查看：
答案 2 :(得分：2)
区分应用程序的开放实例是一个非常古老的问题，它并不是VBA独有的。
多年来，我一直试图弄明白这一点，从未取得比以前更大的成功。我认为它的长短之处在于你永远无法知道你所引用的应用程序实例是否是执行代码的实例（因此终止它可能会使其他实例保持打开状态）。
答案 3 :(得分：2)
我知道这是一篇旧帖子，但对于那些通过搜索访问此处的人来说可能会觉得有用。 找到并修改了此代码。它将在每个实例的每个WORKBOOK中为您提供每个SHEET。从那里，您可以确定活动实例。
模块..............
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
我希望这有助于某人：）
答案 4 :(得分：1)
这是对旧帖子的回复，但与2012年的海报相同，希望它可以帮助那些根据通用网络搜索来到这里的人。
背景 我的公司使用XLSX＆＃34;型号＆＃34;把我们的数据变成＆＃34;漂亮＆＃34;自动。数据从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")
答案 5 :(得分：0)
尝试将其置于循环中
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