Всем доброго дня. Зачастую при ночном обновлении данных методами запуска различных VBA макросов, происходит сбой-зависание какого либо файла (по 100500 причинам). На утро имеем картину - файл завис, обновление данных не завершено и в процессах висит какой то MS Excel с 0% нагрузки. При этом повторный запуск этого же макроса проходит без ошибок. Вопрос - можно ли сторонними средствами (не через Excel, т.к. он технически уже запущен, а например vbs или на крайний случай Word/Outlook) получить имя открытого файла Excel?
Всем доброго дня. Зачастую при ночном обновлении данных методами запуска различных VBA макросов, происходит сбой-зависание какого либо файла (по 100500 причинам). На утро имеем картину - файл завис, обновление данных не завершено и в процессах висит какой то MS Excel с 0% нагрузки. При этом повторный запуск этого же макроса проходит без ошибок. Вопрос - можно ли сторонними средствами (не через Excel, т.к. он технически уже запущен, а например vbs или на крайний случай Word/Outlook) получить имя открытого файла Excel?Glen
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 IIDFromString Lib "ole32" _ (ByVal lpsz As Long, ByRef lpiid As GUID) As Long Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _ (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _ ByRef ppvObject As Object) As Long
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Const S_OK As Long = &H0 Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0 Sub test() Dim i As Long Dim hWinXL As Long Dim xlApp As Object ' Excel.Application Dim wb As Object ' Excel.Workbook hWinXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString) While hWinXL > 0 i = i + 1 Debug.Print "Процесс № " & i; hWinXL If GetXLapp(hWinXL, xlApp) Then For Each wb In xlApp.Workbooks Debug.Print , wb.Name Next End If hWinXL = FindWindowEx(0, hWinXL, "XLMAIN", vbNullString) Wend
End Sub Function GetXLapp(hWinXL As Long, xlApp As Object) As Boolean Dim hWinDesk As Long, hWin7 As Long Dim obj As Object Dim iid As GUID
Call IIDFromString(StrPtr(IID_IDispatch), iid) hWinDesk = FindWindowEx(hWinXL, 0&, "XLDESK", vbNullString) hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString) If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iid, obj) = S_OK Then Set xlApp = obj.Application GetXLapp = True End If End Function
[/vba]
здравствуйте Для 32 битного офиса
[vba]
Код
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 IIDFromString Lib "ole32" _ (ByVal lpsz As Long, ByRef lpiid As GUID) As Long Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _ (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _ ByRef ppvObject As Object) As Long
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Const S_OK As Long = &H0 Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0 Sub test() Dim i As Long Dim hWinXL As Long Dim xlApp As Object ' Excel.Application Dim wb As Object ' Excel.Workbook hWinXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString) While hWinXL > 0 i = i + 1 Debug.Print "Процесс № " & i; hWinXL If GetXLapp(hWinXL, xlApp) Then For Each wb In xlApp.Workbooks Debug.Print , wb.Name Next End If hWinXL = FindWindowEx(0, hWinXL, "XLMAIN", vbNullString) Wend
End Sub Function GetXLapp(hWinXL As Long, xlApp As Object) As Boolean Dim hWinDesk As Long, hWin7 As Long Dim obj As Object Dim iid As GUID
Call IIDFromString(StrPtr(IID_IDispatch), iid) hWinDesk = FindWindowEx(hWinXL, 0&, "XLDESK", vbNullString) hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString) If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iid, obj) = S_OK Then Set xlApp = obj.Application GetXLapp = True End If End Function
Сергей, а это запустится на 64-х битах? У меня все 5 компов только 64х подкрутил PtrSafe где надо, но выдает ошибку Type mistmach на тексте "StrPtr" в строке Call IIDFromString(StrPtr(IID_IDispatch), iid)
Сергей, а это запустится на 64-х битах? У меня все 5 компов только 64х подкрутил PtrSafe где надо, но выдает ошибку Type mistmach на тексте "StrPtr" в строке Call IIDFromString(StrPtr(IID_IDispatch), iid)Glen
Private Declare PtrSafe 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 PtrSafe Function IIDFromString Lib "ole32" _ (ByVal lpsz As LongLong, ByRef lpiid As GUID) As LongLong Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" _ (ByVal hWnd As LongLong, ByVal dwId As Long, ByRef riid As GUID, _ ByRef ppvObject As Object) As LongLong
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Const S_OK As Long = &H0 Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0 Sub test() Dim i As Long Dim hWinXL As Long Dim xlApp As Object ' Excel.Application Dim wb As Object ' Excel.Workbook hWinXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString) While hWinXL > 0 i = i + 1 Debug.Print "Процесс № " & i; hWinXL If GetXLapp(hWinXL, xlApp) Then For Each wb In xlApp.Workbooks Debug.Print , wb.Name Next End If hWinXL = FindWindowEx(0, hWinXL, "XLMAIN", vbNullString) Wend
End Sub Function GetXLapp(hWinXL As Long, xlApp As Object) As Boolean Dim hWinDesk As Long, hWin7 As Long Dim obj As Object Dim iid As GUID
Call IIDFromString(StrPtr(IID_IDispatch), iid) hWinDesk = FindWindowEx(hWinXL, 0&, "XLDESK", vbNullString) hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString) If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iid, obj) = S_OK Then Set xlApp = obj.Application GetXLapp = True End If End Function
Private Declare PtrSafe 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 PtrSafe Function IIDFromString Lib "ole32" _ (ByVal lpsz As LongLong, ByRef lpiid As GUID) As LongLong Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" _ (ByVal hWnd As LongLong, ByVal dwId As Long, ByRef riid As GUID, _ ByRef ppvObject As Object) As LongLong
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Const S_OK As Long = &H0 Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0 Sub test() Dim i As Long Dim hWinXL As Long Dim xlApp As Object ' Excel.Application Dim wb As Object ' Excel.Workbook hWinXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString) While hWinXL > 0 i = i + 1 Debug.Print "Процесс № " & i; hWinXL If GetXLapp(hWinXL, xlApp) Then For Each wb In xlApp.Workbooks Debug.Print , wb.Name Next End If hWinXL = FindWindowEx(0, hWinXL, "XLMAIN", vbNullString) Wend
End Sub Function GetXLapp(hWinXL As Long, xlApp As Object) As Boolean Dim hWinDesk As Long, hWin7 As Long Dim obj As Object Dim iid As GUID
Call IIDFromString(StrPtr(IID_IDispatch), iid) hWinDesk = FindWindowEx(hWinXL, 0&, "XLDESK", vbNullString) hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString) If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iid, obj) = S_OK Then Set xlApp = obj.Application GetXLapp = True End If End Function
Класс!! Запустил с оутлука, отлично срабатывает, то что нужно. Видимо дело было в типе LongLong, я и не заметил сразу. Сергей, спасибо преогромное! Начать неделю с добрых дел - 7 плюсов в карму
Класс!! Запустил с оутлука, отлично срабатывает, то что нужно. Видимо дело было в типе LongLong, я и не заметил сразу. Сергей, спасибо преогромное! Начать неделю с добрых дел - 7 плюсов в карму Glen