Найти все открытые приложения Word из макроса VBA EXCEL-Macro

Question

В макросе EXCEL я хочу скопировать выбранный диапазон в таблицу документов WORD.Я знаю, как это сделать, создав новый WORD-документ (цель).Но я хочу проверить, существуют ли уже открытые WORD-документы, из которых я могу выбрать цель.

Я нашел код для циклического прохождения всех открытых EXCEL-приложений из макроса EXCEL.Я изменил код из Флоран Брехере , как указано ниже.

Какие имена классов отсутствуют, обозначенные "???"в коде искать WORD-документы?

Заранее спасибо!Иммануил

Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
    ByVal hwnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long

Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
    ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, _
    ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr

'Test my code
Private Sub GetWordInstances_Test()
    Dim wd As Word.Application
    Dim i, cnt As Integer

    cnt = 0
    For Each wd In GetWordInstances()
        cnt = cnt + 1
        Debug.Print wd.Application.Name, cnt

        For i = 1 To wd.Documents.Count

            Debug.Print wd.Documents(i).FullName, i
        Next i
    Next
End Sub

'Getting open WORD instances from within EXCEL-VBA
Public Function GetWordInstances() As Collection
    Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
    guid(0) = &H20400
    guid(1) = &H0
    guid(2) = &HC0
    guid(3) = &H46000000

    Set GetWordInstances = New Collection
    Do
        hwnd = FindWindowExA(0, hwnd, "OpusApp", vbNullString)
        If hwnd = 0 Then Exit Do

        hwnd2 = FindWindowExA(hwnd, 0, "???", vbNullString)

        hwnd3 = FindWindowExA(hwnd2, 0, "???", vbNullString)

        'hand over found WORD application to collection
        If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
            GetWordInstances.Add acc.Application
        End If
    Loop
End Function

Answer 1

Попробуйте что-то вроде этого ...

Sub CheckForWordApp()
Dim wApp As Object
On Error Resume Next
Set wApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
    'Word application is not running so create it
    Set wApp = New Word.Application
    wApp.Visible = True
    'no documents will exist, so do something
Else
    'A Word application exists, make sure it's visible
    wApp.Visible = True
    If wApp.Document.Count > 0 Then
        'There are open documents so do something
    Else
        'No documents are open so do something else
    End If
End If
End Sub

Answer 2

См. ответ , объясняющий процесс решения вашего вопроса.

Резюмируя:

OpusApp ==> _WwF ==> _WwB ==> _WwG.

Вы должны добавить еще один слой:

    hwnd = FindWindowExA(0, hwnd, "OpusApp", vbNullString)
    If hwnd = 0 Then Exit Do

    hwnd2 = FindWindowExA(hwnd, 0, "_WwF", vbNullString)

    hwnd3 = FindWindowExA(hwnd2, 0, "_WwB", vbNullString)

    hwnd4 = FindWindowExA(hwnd3, 0, "_WwG", vbNullString)
    'hand over found WORD application to collection
    If AccessibleObjectFromWindow(hwnd4, &HFFFFFFF0, guid(0), acc) = 0 Then
        GetWordInstances.Add acc.Application
    End If

Answer 3

Это работает для меня: 1. Добавьте ссылку в Excel: Инструменты-> Ссылки-> Библиотека объектов Microsoft Word XX.X 2. Запустите этот код:

Sub openDocs ()

Dim openDoc     As Word.Document
Dim docCount    As Long

docCount = Documents.Count

For Each openDoc In Documents
    'do whatever, i.e.:
    ' debug.print openDoc.Name
Next openDoc

If docCount = 0 Then
    MsgBox "There are no open documents."
Else
    MsgBox "There are " & docCount & " open documents."
End If

End Sub