Может ли VBA охватить экземпляры Excel?

Question

Может ли макрос VBA Excel, работающий в одном экземпляре Excel, получить доступ к книгам другого запущенного экземпляра Excel? Например, я хотел бы создать список всех рабочих книг, которые открыты в любом работающем экземпляре Excel.

Answer 1

Ответ Корнелиуса частично верен. Его код получает текущий экземпляр, а затем создает новый экземпляр. GetObject получает только первый экземпляр, независимо от того, сколько экземпляров доступно. Я полагаю, что вопрос заключается в том, как вы можете получить конкретный экземпляр из многих.

Для проекта VBA создайте два модуля, один модуль кода, а другой - форму с одной командной кнопкой с именем Command1. Возможно, вам придется добавить ссылку на Microsoft.Excel.

Этот код отображает все имена каждой рабочей книги для каждого запущенного экземпляра Excel в окне Immediate.

'------------- Code Module --------------

Option Explicit

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

'------------- Form Module --------------

Option Explicit

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

'Sub GetAllWorkbookWindowNames()
Sub Command1_Click()
    On Error GoTo MyErrorHandler

    Dim hWndMain As Long
    hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

    Do While hWndMain <> 0
        GetWbkWindows hWndMain
        hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
    Loop

    Exit Sub

MyErrorHandler:
    MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Private Sub GetWbkWindows(ByVal hWndMain As Long)
    On Error GoTo MyErrorHandler

    Dim hWndDesk As Long
    hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)

    If hWndDesk <> 0 Then
        Dim hWnd As Long
        hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)

        Dim strText As String
        Dim lngRet As Long
        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

Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
    On Error GoTo MyErrorHandler

    Dim fOk As Boolean
    fOk = False

    Dim iid As UUID
    Call IIDFromString(StrPtr(IID_IDispatch), iid)

    Dim obj As Object
    If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
        Dim objApp As Excel.Application
        Set objApp = obj.Application
        Debug.Print objApp.Workbooks(1).Name

        Dim myWorksheet As Worksheet
        For Each myWorksheet In objApp.Workbooks(1).Worksheets
            Debug.Print "     " & myWorksheet.Name
            DoEvents
        Next

        fOk = True
    End If

    GetExcelObjectFromHwnd = fOk

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

Answer 2

Я считаю, что VBA мощнее, чем думает Чарльз;)

Если есть только какой-то хитрый способ указать на конкретный экземпляр из GetObject и CreateObject, мы решим вашу проблему!

РЕДАКТИРОВАТЬ:

Если вы являетесь создателем всех экземпляров, не должно быть проблем с такими вещами, как перечисление книг. Посмотрите на этот код:

Sub Excels()
    Dim currentExcel As Excel.Application
    Dim newExcel As Excel.Application

    Set currentExcel = GetObject(, "excel.application")
    Set newExcel = CreateObject("excel.application")

    newExcel.Visible = True
    newExcel.Workbooks.Add
    'and so on...
End Sub

Answer 3

Я думаю, что в VBA вы можете получить доступ к объекту приложения в другом работающем экземпляре. Если вам известно имя книги, открытой в другом экземпляре, вы можете получить ссылку на объект приложения. Посмотреть страницу Аллена Уэйтта

Последняя часть,

Dim xlApp As Excel.Application
Set xlApp = GetObject("c:\mypath\ExampleBook.xlsx").Application

Позволил мне получить указатель на объект приложения экземпляра, который имел ExampleBook.xlsx открыть.

Я считаю, что "ExampleBook" должен быть полный путь, по крайней мере, в Excel 2010. В настоящее время я сам экспериментирую с этим, поэтому я попытаюсь обновить его, когда получу больше деталей.

Предположительно могут возникнуть осложнения, если в отдельных экземплярах открыта одна и та же рабочая книга, но только один может иметь доступ для записи.

Answer 4

Благодаря этому замечательному сообщению у меня появилась рутина для поиска массива всех приложений Excel, которые в данный момент работают на компьютере. Проблема в том, что я только что перешел на 64-битную версию Office 2013, и все пошло не так.

Существует обычная ошибка конвертации ... Declare Function ... в ... Declare PtrSafe Function ..., что хорошо документировано в другом месте. Однако я не смог найти какую-либо документацию по тому факту, что иерархия окон ("XLMAIN" -> "XLDESK" -> "EXCEL7"), ожидаемая исходным кодом, изменилась после этого обновления. Для тех, кто идет по моим стопам, чтобы сэкономить вам время на копании, я решил опубликовать свой обновленный сценарий. Это трудно проверить, но я думаю, что это должно быть обратно совместимо для хорошей меры.

Option Explicit

#If Win64 Then

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

#Else

    Private 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
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

#End If

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 LongPtr = &HFFFFFFF0

' Run as entry point of example
Public Sub Test()

Dim i As Long
Dim xlApps() As Application

    If GetAllExcelInstances(xlApps) Then
        For i = LBound(xlApps) To UBound(xlApps)
            If xlApps(i).Workbooks(1).Name <> ThisWorkbook.Name Then
                MsgBox (xlApps(i).Workbooks(1).Name)
            End If
        Next
    End If

End Sub

' Actual public facing function to be called in other code
Public Function GetAllExcelInstances(xlApps() As Application) As Long

On Error GoTo MyErrorHandler

Dim n As Long
#If Win64 Then
    Dim hWndMain As LongPtr
#Else
    Dim hWndMain As Long
#End If
Dim app As Application

    ' Cater for 100 potential Excel instances, clearly could be better
    ReDim xlApps(1 To 100)

    hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

    Do While hWndMain <> 0
        Set app = GetExcelObjectFromHwnd(hWndMain)
        If Not (app Is Nothing) Then
            If n = 0 Then
                n = n + 1
                Set xlApps(n) = app
            ElseIf checkHwnds(xlApps, app.Hwnd) Then
                n = n + 1
                Set xlApps(n) = app
            End If
        End If
        hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
    Loop

    If n Then
        ReDim Preserve xlApps(1 To n)
        GetAllExcelInstances = n
    Else
        Erase xlApps
    End If

    Exit Function

MyErrorHandler:
    MsgBox "GetAllExcelInstances" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description

End Function

#If Win64 Then
    Private Function checkHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
#Else
    Private Function checkHwnds(xlApps() As Application, Hwnd As Long) As Boolean
#End If

Dim i As Integer

    For i = LBound(xlApps) To UBound(xlApps)
        If xlApps(i).Hwnd = Hwnd Then
            checkHwnds = False
            Exit Function
        End If
    Next i

    checkHwnds = True

End Function

#If Win64 Then
    Private Function GetExcelObjectFromHwnd(ByVal hWndMain As LongPtr) As Application
#Else
    Private Function GetExcelObjectFromHwnd(ByVal hWndMain As Long) As Application
#End If

On Error GoTo MyErrorHandler

#If Win64 Then
    Dim hWndDesk As LongPtr
    Dim Hwnd As LongPtr
#Else
    Dim hWndDesk As Long
    Dim Hwnd As Long
#End If
Dim strText As String
Dim lngRet As Long
Dim iid As UUID
Dim obj As Object

    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 = CLng(GetClassName(Hwnd, strText, 100))

        If Left$(strText, lngRet) = "EXCEL7" Then

            Call IIDFromString(StrPtr(IID_IDispatch), iid)

            If AccessibleObjectFromWindow(Hwnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK

                Set GetExcelObjectFromHwnd = obj.Application
                Exit Function

            End If

        End If

        Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
        Loop

        On Error Resume Next

    End If

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description

End Function

Answer 5

У меня была похожая проблема / цель.

И я получил рабочий ответ ForEachLoops, но есть изменение, которое необходимо сделать. В нижней функции (GetExcelObjectFromHwnd) он использовал индекс рабочей книги 1 в обеих командах debug.print. В результате вы видите только первый WB.

Поэтому я взял его код и поместил цикл for в GetExcelObjectFromHwnd, и изменил 1 на счетчик. В результате я могу получить ВСЕ активные книги Excel и вернуть информацию, необходимую для доступа к экземплярам Excel, и получить доступ к другим WB.

И я создал Type, чтобы упростить получение информации и передать ее вызывающей подпрограмме:

Type TargetWBType
    name As String
    returnObj As Object
    returnApp As Excel.Application
    returnWBIndex As Integer
End Type

Для имени я просто использовал базовое имя файла, например, "example.xls". Этот фрагмент подтверждает функциональность, выпуская значение A6 на каждом WS целевого WB. Вот так:

Dim targetWB As TargetWBType
targetWB.name = "example.xls"

Call GetAllWorkbookWindowNames(targetWB)

If Not targetWB.returnObj Is Nothing Then
    Set targetWB.returnApp = targetWB.returnObj.Application
    Dim ws As Worksheet
    For Each ws In targetWB.returnApp.Workbooks(targetWB.returnWBIndex).Worksheets
        MsgBox ws.Range("A6").Value
    Next
Else
    MsgBox "Target WB Not found"
End If

Теперь модуль ENTIRE, изначально созданный ForEachLoop, выглядит следующим образом, и я указал на сделанные мной изменения. У него есть всплывающее окно msgbox, которое я оставил во фрагменте для целей отладки. Убери это, как только найдешь свою цель. Код:

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

'------------- Form Module --------------

Option Explicit

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

'My code: added targetWB
Sub GetAllWorkbookWindowNames(targetWB As TargetWBType)
    On Error GoTo MyErrorHandler

    Dim hWndMain As Long
    hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

    Do While hWndMain <> 0
        GetWbkWindows hWndMain, targetWB 'My code: added targetWB
        hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
    Loop

    Exit Sub

MyErrorHandler:
    MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

'My code: added targetWB
Private Sub GetWbkWindows(ByVal hWndMain As Long, targetWB As TargetWBType)
    On Error GoTo MyErrorHandler

    Dim hWndDesk As Long
    hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)

    If hWndDesk <> 0 Then
        Dim hWnd As Long
        hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)

        Dim strText As String
        Dim lngRet As Long
        Do While hWnd <> 0
            strText = String$(100, Chr$(0))
            lngRet = GetClassName(hWnd, strText, 100)

            If Left$(strText, lngRet) = "EXCEL7" Then
                GetExcelObjectFromHwnd hWnd, targetWB 'My code: added targetWB
                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

'My code: added targetWB
Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long, targetWB As TargetWBType) As Boolean
    On Error GoTo MyErrorHandler

    Dim fOk As Boolean
    fOk = False

    Dim iid As UUID
    Call IIDFromString(StrPtr(IID_IDispatch), iid)

    Dim obj As Object
    If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
        Dim objApp As Excel.Application
        Set objApp = obj.Application

        'My code
        Dim wbCount As Integer
        For wbCount = 1 To objApp.Workbooks.Count
        'End my code

            'Not my code
            Debug.Print objApp.Workbooks(wbCount).name

            'My code
                If LCase(objApp.Workbooks(wbCount).name) = LCase(targetWB.name) Then
                    MsgBox ("Found target: " & targetWB.name)
                    Set targetWB.returnObj = obj
                    targetWB.returnWBIndex = wbCount
                End If
            'End My code

            'Not my code
            Dim myWorksheet As Worksheet
            For Each myWorksheet In objApp.Workbooks(wbCount).Worksheets
                Debug.Print "     " & myWorksheet.name
                DoEvents
            Next

        'My code
        Next
        'Not my code

        fOk = True
    End If

    GetExcelObjectFromHwnd = fOk

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

Я повторяю, это работает, и используя переменные в типе TargetWB, я надежно получаю доступ к рабочим книгам и рабочим листам во всех экземплярах Excel.

Единственная потенциальная проблема, которую я вижу с моим решением, это если у вас есть несколько ББ с одним и тем же именем. Прямо сейчас, я верю, что это вернет последний экземпляр этого имени. Если мы добавим Exit For в If Then, я верю, что вместо этого он вернет первый экземпляр. Я не тестировал эту часть тщательно, так как в моем приложении всегда был только один экземпляр открытого файла.

Answer 6

Просто чтобы добавить к ответу Джеймса МакАди, я думаю, что вы делаете редим слишком поздно, потому что в функции checkHwnds вы получаете ошибку вне диапазона, поскольку вы пытаетесь проверить значения до 100, даже если вы еще не заполнили массив полностью? Я изменил код, приведенный ниже, и теперь он работает на меня.

' Actual public facing function to be called in other code
Public Function GetAllExcelInstances(xlApps() As Application) As Long

On Error GoTo MyErrorHandler

Dim n As Long
#If Win64 Then
    Dim hWndMain As LongPtr
#Else
    Dim hWndMain As Long
#End If
Dim app As Application

' Cater for 100 potential Excel instances, clearly could be better
ReDim xlApps(1 To 100)

hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

Do While hWndMain <> 0
    Set app = GetExcelObjectFromHwnd(hWndMain)
    If Not (app Is Nothing) Then
        If n = 0 Then
            n = n + 1
            ReDim Preserve xlApps(1 To n)
            Set xlApps(n) = app
        ElseIf checkHwnds(xlApps, app.Hwnd) Then
            n = n + 1
            ReDim Preserve xlApps(1 To n)
            Set xlApps(n) = app
        End If
    End If
    hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop

If n Then
    GetAllExcelInstances = n
Else
    Erase xlApps
End If

Exit Function

MyErrorHandler:
    MsgBox "GetAllExcelInstances" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description

End Function

Answer 7

Я не верю, что это возможно, используя только VBA, потому что объект самого высокого уровня, к которому вы можете добраться, это объект Application, который является текущим экземпляром Excel.