Блог

Главная - Вопросы по программированию - Захват открытой книги в новом экземпляре Excel

Захват открытой книги в новом экземпляре Excel

#vba #excel

#vba #excel

Вопрос:

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

Текущий рабочий процесс (код внизу):

  1. Вызовите центральный модуль ‘Capture’ с именем экспорта (некоторые программы экспортируют ‘Book [x]’, некоторые делают ‘workbook [x]’ и т. Д.) И процедуру, которую вы хотите запустить, как только экспорт будет найден.

  2. Модуль захвата получает список всех существующих имен книг из всех экземпляров Excel и сохраняет в виде строки на уровне модуля.

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

  4. Если он находит книгу, которой нет в ранее сохраненном списке всех существующих имен книг, и которая содержит имя экспорта, он сохраняет эту книгу как общедоступную переменную уровня модуля и запускает сохраненную процедуру с шага 1, которая может ссылаться на книгу хранилища.

Это работает очень хорошо во всех обстоятельствах, КРОМЕ одного. Если у меня уже есть Book1.xlsx откройте в моем текущем экземпляре Excel, и сторонняя программа экспортирует Book1.xlsx в НОВЫЙ экземпляр Excel программа не распознает это как экспорт, поскольку Book1.xlsx уже есть в существующем строковом массиве имен рабочих книг.

Мое решение состоит в том, чтобы найти какой-то способ уникальной идентификации каждой книги, который лучше, чем «Имя» или «Путь». Я попытался сохранить каждое имя книги в существующей строке имен книг как [application.hwnd]![имя рабочей книги] но это было нестабильное исправление и часто ломалось (я не совсем понимаю, как работает hwnd, поэтому не могу сказать, почему).

Есть идеи? Спасибо!

Примеры процедур, использующих MCaptureExport

 Public Sub GrabFXAllExport()

    Const sSOURCE As String = "GrabFXAllExport"

    On Error GoTo ErrorHandler

    If Not TAAA.MCaptureExport.bCaptureExport("FXALL", "TAAA.FXAllEmail.ProcessFXAllExport") Then Err.Raise glHANDLED_ERROR

ErrorExit:

    Exit Sub

ErrorHandler:
    If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub
Public Sub ProcessFXAllExport()

    Const sSOURCE As String = "ProcessFXAllExport"

    On Error GoTo ErrorHandler

    If MCaptureExport.mwbCaptured Is Nothing Then
        MsgBox "Exported Workbook Not Found. Please try again.", vbCritical, gsAPP_NAME
        GoTo ErrorExit
    End If

    Dim wsSourceSheet As Worksheet
    Set wsSourceSheet = MCaptureExport.mwbCaptured.Worksheets(1)
    Set MCaptureExport.mwbCaptured = Nothing

    [I now have the export and can work with it as a I please]

ErrorExit:

    Exit Sub

ErrorHandler:
    If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub

Модуль MCaptureExport

 Option Explicit
Option Base 1

' Description:  This module contains the central error
'               handler and related constant declarations.
Private Const msMODULE As String = "MCaptureExport"

Private sExistingWorkbookList() As String
Public mwbCaptured As Workbook
Public msCaptureType As String
Private sReturnProcedure As String
Private bListening As Boolean
Public Function bCaptureExport(sCaptureType As String, sRunAfterCapture As String) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bCaptureExport()"

    On Error GoTo ErrorHandler
    bReturn = True

    If Not bWorkbookNamesAsArray(sExistingWorkbookList, True, False) Then Err.Raise glHANDLED_ERROR

    sReturnProcedure = sRunAfterCapture
    bListening = True
    msCaptureType = sCaptureType
    TAAA.MCaptureExport.WaitForCapture sCaptureTypeToNameContains(msCaptureType)
    MsgBox "Waiting for " amp; msCaptureType amp; " Export", vbInformation, gsAPP_NAME

ErrorExit:

    bCaptureExport = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function

Private Sub WaitForCapture(sNameContains As String)

    Const sSOURCE As String = "WaitForCapture"

    On Error GoTo ErrorHandler

    Dim wbCaptureCheck As Workbook
    If Not bCaptureCheck(sNameContains, wbCaptureCheck) Then Err.Raise glHANDLED_ERROR

    If wbCaptureCheck Is Nothing Then
        If bListening Then _
            Application.OnTime Now   TimeSerial(0, 0, 3), "'TAAA.MCaptureExport.WaitForCapture " amp; Chr(34) amp; sNameContains amp; Chr(34) amp; "'"
    Else
        Dim bSameApp As Boolean
        If Not bWorkbooksInSameApp(ThisWorkbook, wbCaptureCheck, bSameApp) Then Err.Raise glHANDLED_ERROR

        If Not bSameApp Then
            Dim sTempFilePath As String
            sTempFilePath = ThisWorkbook.Path amp; "temp_" amp; Format(Now, "mmddyyhhmmss") amp; ".xls"
            wbCaptureCheck.SaveCopyAs sTempFilePath
            wbCaptureCheck.Close SaveChanges:=False
            Set wbCaptureCheck = Application.Workbooks.Open(sTempFilePath)
        End If

        Set mwbCaptured = wbCaptureCheck
        bListening = False
        Application.Run sReturnProcedure
    End If

ErrorExit:

    Exit Sub

ErrorHandler:
    If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub
Private Function sCaptureTypeToNameContains(sCaptureType As String) As String

    sCaptureTypeToNameContains = "*"

    On Error Resume Next

    Select Case UCase(sCaptureType)
        Case "SOTER": sCaptureTypeToNameContains = "workbook"
        Case "THOR": sCaptureTypeToNameContains = "Book"
        Case "FXALL": sCaptureTypeToNameContains = "search_results_export"
    End Select

End Function
Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bCaptureCheck()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim i As Long, wb As Workbook
    Dim xlApps() As Application
    If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks

            If wb.Name Like "*" amp; sNameContains amp; "*" _
                And Not bIsInArray(wb.Name, sExistingWorkbookList) Then

                Set wbResult = wb
                GoTo ErrorExit

            End If
        Next
    Next

ErrorExit:

    bCaptureCheck = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function

Служебные функции, используемые MCaptureExport

 Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bWorkbookNamesAsArray()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim i As Long, wb As Workbook
    Dim xlApps() As Application

    Dim ResultArray() As String
    Dim Ndx As Integer, wbCount As Integer

    If bAllInstances Then
        If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
    Else
        ReDim xlApps(0)
        Set xlApps(0) = Application
    End If

    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks
            wbCount = wbCount   1
        Next
    Next

    ReDim ResultArray(1 To wbCount)

    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks
            Ndx = Ndx   1
            ResultArray(Ndx) = wb.Name
        Next
    Next

    sResult = ResultArray()

ErrorExit:

    bWorkbookNamesAsArray = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Public Function bGetAllExcelInstances(xlApps() As Application) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bGetAllExcelInstances()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim n As Long

    Dim hWndMain As LongPtr

    Dim app As Application

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

    hWndMain = FindWindowEx(0amp;, 0amp;, "XLMAIN", vbNullString)

    Do While hWndMain <> 0
        If Not bGetExcelObjectFromHwnd(hWndMain, app) Then Err.Raise glHANDLED_ERROR

        If Not (app Is Nothing) Then
            If n = 0 Then
                n = n   1
                Set xlApps(n) = app
            ElseIf bCheckHwnds(xlApps, app.Hwnd) Then
                n = n   1
                Set xlApps(n) = app
            End If
        End If
        hWndMain = FindWindowEx(0amp;, hWndMain, "XLMAIN", vbNullString)

    Loop

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

ErrorExit:

    bGetAllExcelInstances = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function


Private Function bCheckHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean

    On Error Resume Next

    Dim i As Integer

    For i = LBound(xlApps) To UBound(xlApps)
        If Not xlApps(i) Is Nothing Then
            If xlApps(i).Hwnd = Hwnd Then
                bCheckHwnds = False
                Exit Function
            End If
        End If
    Next i

    bCheckHwnds = True

End Function
Public Function bWorkbooksInSameApp(wb1 As Workbook, wb2 As Workbook, bSameApp As Boolean) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bWorkbooksInSameApp()"

    On Error GoTo ErrorHandler
    bReturn = True

    bSameApp = wb1.Application.Hwnd = wb2.Application.Hwnd

ErrorExit:

    bWorkbooksInSameApp = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Private Function bGetExcelObjectFromHwnd(ByVal hWndMain As LongPtr, aAppResult As Application) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bGetExcelObjectFromHwnd()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim hWndDesk As LongPtr
    Dim Hwnd As LongPtr
    Dim strText As String
    Dim lngRet As Long
    Dim iid As UUID
    Dim obj As Object

    hWndDesk = FindWindowEx(hWndMain, 0amp;, "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 aAppResult = obj.Application
                GoTo ErrorExit

            End If

        End If

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

    End If

ErrorExit:

    bGetExcelObjectFromHwnd = bReturn
    Exit Function

ErrorHandler:
    MsgBox Err.Number
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function

Комментарии:

1. Сложно обрабатывать подобные вещи, не связанные с процессом, есть ли способ вместо этого предложить пользователю экспортировать / сохранить в качестве выходного файла Excel? Затем вам просто нужен файловый каталог и предложить пользователю выбрать (экспортированный) файл из другого приложения.

2. Одна из идей, которая должна сработать, заключается в том, что вместо кэширования списка имен открытых книг назначьте каждой книге имя, CustomDocumentProperty которое вы можете разумно гарантировать, не будет существовать в экспортированных файлах XLSX. Затем вы можете просто сканировать приложения / книги на наличие файла (по имени), который не обладает этим свойством .

3. @DavidZemens Это интересная идея! Если мое решение, приведенное ниже с помощью hWnd, не работает, я собираюсь попробовать ваше следующим. Большое спасибо за помощь!

4. Похоже, это должно сработать…

5. @DavidZemens Я столкнулся с некоторыми проблемами с hWnd и в итоге использовал ваш метод CustomDocumentProperty. Работает как шарм. Спасибо!

Ответ №1:

У меня есть потенциальное решение. Однако я хочу оставить вопрос открытым. Это довольно сложная проблема, и я уверен, что есть более элегантные решения, чем то, что я предлагаю.

Поэтому я обновил формат sExistingWorkbookList на [Приложение.hWnd]![Workbook.name ]. Я пробовал это раньше, но я думаю, что на этот раз это работает.

Мысли?

Обновленная версия bWorkbookNamesAsArray

Добавлено wb.Application.Hwnd amp; "!" amp; в ResultArray(Ndx) = wb.name 

 Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bWorkbookNamesAsArray()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim i As Long, wb As Workbook
    Dim xlApps() As Application

    Dim ResultArray() As String
    Dim Ndx As Integer, wbCount As Integer

    If bAllInstances Then
        If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
    Else
        ReDim xlApps(0)
        Set xlApps(0) = Application
    End If

    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks
            wbCount = wbCount   1
        Next
    Next

    ReDim ResultArray(1 To wbCount)

    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks
            Ndx = Ndx   1
            ResultArray(Ndx) = wb.Application.Hwnd amp; "!" amp; wb.Name
        Next
    Next

    sResult = ResultArray()

ErrorExit:

    bWorkbookNamesAsArray = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function

Новая служебная функция

 Public Function bGetWorkbookFromHwndAndName(ByVal sWorkbookReference As String, ByRef wbResult As Workbook)

    Dim bReturn As Boolean
    Const sSOURCE As String = "bGetWorkbookFromHwndAndName()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim xlApp As Application

    If Not bGetExcelObjectFromHwnd(CLng(Split(sWorkbookReference, "!")(0)), xlApp) Then Err.Raise glHANDLED_ERROR

    Set wbResult = xlApp.Workbooks(Split(sWorkbookReference, "!")(1))

ErrorExit:

    bGetWorkbookFromHwndAndName = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function

Обновлен MCaptureExport.bCaptureCheck()

     Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bCaptureCheck()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim i As Long, wb As Workbook, sFullWorkbookReference As String
    Dim xlApps() As Application
    If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks

            sFullWorkbookReference = wb.Application.Hwnd amp; "!" amp; wb.Name

            If wb.Name Like "*" amp; sNameContains amp; "*" _
                And Not bIsInArray(sFullWorkbookReference, sExistingWorkbookList) Then

                If Not bGetWorkbookFromHwndAndName(sFullWorkbookReference, wbResult) Then Err.Raise glHANDLED_ERROR
                GoTo ErrorExit

            End If
        Next
    Next

ErrorExit:

    bCaptureCheck = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function