All geek questions in one place

VBA script to close every instance of Excel except itself

I have a routine in my error handling function that tries to close every workbook open in every instance of Excel. Otherwise, it may remain in memory and break my next vbscript. He must also close each book without saving any changes.

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 is not optimal. For example, it can close two workbooks in one instance of Excel, but if you open 2 excel instances, it will only close 1.

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

Additional loan:

How to do this for access, as well as without closing the access file in which this script is located?

+3
6

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

+3

.

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 Access, , sub. , . , . Access, , , Windows API.

Excel. , Excel Application.Hwnd Application.Hinstance... , - .

, , On Error Resume Next. GetObject , . , 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
+4

- , VBA.

, , .

, , , , , , ( ).

+2

, , , , . . WORKBOOK INSTANCE. .

..............

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

, -:)

+2

, , 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 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 clearly state your statements. that is, instead, Workbooks("Book_Name")make sure that you identify the application you are accessing, whether Application.Workbooks("Book_Name")orxlApp1.Workbooks("Book_Name")

+1
source

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
0
source

Source: https://habr.com/ru/post/1760637/

More articles:


All Articles