Мяв. Используя ссылки и бесценные советы Doober'a, поиск, и свою фантазию был сочинен код для обработки и сохранения файлов, открытых в отдельных процессах Excel. По результатам последнего тестирования, получаем следующее Win7/32 Of 2010/32 Не зависимо от числа файлов, открытых в родительском процессе, число вызовов приложения Set xl = ob.Application колеблется от 1 до общего количества процессов Excel.
Win7/64 of 2016/32 При наличии в родительском процессе 1 файла, количество вызовов 1 шт. При наличии в родительском процессе 2 и более файлов, вызов приложения попадает в бесконечный цикл. (в коде установлен счетчик для прерывания, очень тупой, на 500 итераций)
Интересует поведение данного кода в различных версиях Ofis, и различных ОС. А так же очень интересует более адекватный (?) способ прерывания (гусары, молчать! )
В первой части тестирования уже принимали участие голодный котяра, и обкурившийся ведмедь, за что им отдельная благодарность.
Общий инструктаж распаковать архив запустить TEST нажать кнопку 1 - 4 остальных файла откроются в новых процессах (эмуляция работы "сторонней программы") Нажать кнопку 2 - запустится рабочий макрос, который сохранит файлы, открытые в других процессах по заданным местам, и закроет все лишнее.
БМВ написал: Я просто не совсем понимаю зачем плодить процессы, в чем смысл?
Альтернатива - утки? (переписать стороннюю программу, чтобы она выгружала файлы так, как нам желательно?) Сия альтернатива, как бэ.., не совсем альтернатива...
Миш, ты не поверишь, но при выборе пакетной выгрузки 10 смет, будет создано 20 файлов, причем каждый в новом процессе, и каждый никуда не сохранен!
Одно то, что их хоть как-то различить можно, уже 100500+!
Я тут как-то так писал обход дерева окон (вычислил от всего, что не касается поиска окон книг)
Код
Option Explicit
Option Explicit
Option Base 1
Private Declare Function GetClassName& Lib "user32" Alias "GetClassNameA" (ByVal hwnd&, ByVal lpClassName$, ByVal nMaxCount&)
Private Declare Function GetWindowText& Lib "user32" Alias "GetWindowTextA" (ByVal hwnd&, ByVal lpString$, ByVal cch&)
Private Declare Function AccessibleObjectFromWindow& Lib "oleacc" (ByVal hwnd&, ByVal dwId&, riid As GUID, xlWB As Object)
Public Declare Function GetWindow& Lib "user32" (ByVal hwnd&, ByVal wCmd&)
Public Declare Function GetDesktopWindow& Lib "user32" ()
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Private Const OBJID_NATIVEOM = &HFFFFFFF0
Private Type GUID
lData1 As Long
iData2 As Integer
iData3 As Integer
aBData4(0 To 7) As Byte
End Type
Private IDispatch As GUID, oWnd As Window
Public WbArr() As Workbook, arr() As Variant
Public Sub EnumWorkbooks()
Dim i&
With IDispatch
.lData1 = &H20400: .iData2 = &H0: .iData3 = &H0
.aBData4(0) = &HC0: .aBData4(1) = &H0: .aBData4(2) = &H0
.aBData4(3) = &H0: .aBData4(4) = &H0: .aBData4(5) = &H0
.aBData4(6) = &H0: .aBData4(7) = &H46
End With
ReDim WbArr(1), arr(1)
FindWindowHwndLike 0, "EXCEL7", "", 0, 0, 0
Set oWnd = Nothing
End Sub
Private Function FindWindowHwndLike&(hWndStart&, ClassName$, WindowTitle$, level&, lHolder&, lCnt&)
Dim hwnd&, sWindowTitle$, sClassName$, r&
If level = 0 Then
If hWndStart = 0 Then
hWndStart = GetDesktopWindow()
End If
End If
level = level + 1
hwnd = GetWindow(hWndStart, GW_CHILD)
Do While hwnd > 0
lHolder = FindWindowHwndLike(hwnd, ClassName, WindowTitle, level, lHolder, lCnt)
sWindowTitle = Space$(255)
r = GetWindowText(hwnd, sWindowTitle, 255)
sWindowTitle = Left$(sWindowTitle, r)
sClassName = Space$(255)
r = GetClassName(hwnd, sClassName, 255)
sClassName = Left$(sClassName, r)
If (InStr(1, sWindowTitle, WindowTitle, vbBinaryCompare) > 0 Or sWindowTitle = WindowTitle) And (sClassName Like ClassName & "*" Or sClassName = ClassName) Then
FindWindowHwndLike = hwnd
lHolder = hwnd
AccessibleObjectFromWindow hwnd, OBJID_NATIVEOM, IDispatch, oWnd
If Not oWnd Is Nothing Then
If oWnd.Visible Then
lCnt = lCnt + 1
ReDim Preserve WbArr(1 To lCnt), arr(1 To lCnt)
Set WbArr(lCnt) = oWnd.ActiveSheet.Parent
arr(lCnt) = WbArr(lCnt).Name
End If
End If
End If
hwnd = GetWindow(hwnd, GW_HWNDNEXT)
Loop
FindWindowHwndLike = lHolder
End Function
Поверю, но другой процесс в моем понимании, нужен для случаев когда 1. Параллельная и независимая обработка 2. Ресурсы приложения ограничены в пределах одного процесса и этого едва хватает для обработки одного экземплра 3. Приложение обработчик не умеет открывать два более одного файла одновременно 4. При открытии в одном экземпляре приложения могут быть влияния друг на друга. 5. …. Ну еще что-нибудь придумать можно
Я реально не понимаю идеи и выгоды от того будет создано 20 файлов и каждый никуда не сохранен! Например через WScript.Shell можно запустить приложение и сразу получить его ID чтоб не мучатся потом с поиском
Код
Set WshShell = CreateObject("WScript.Shell")
Set WshExec = WshShell.Exec("notepad")
WScript.Sleep 2000
WshShell.AppActivate(WshExec.ProcessID)
Почему временно не сохранить файл с уникальным именем, тем самым идентифицировать все 20? Может путь и верный выбран, но без описания конечной идеи - это пока только создание себе сложностей.
БМВ написал: Я реально не понимаю идеи и выгоды от того будет создано 20 файлов
Я тоже. Но эти файлы создаются не Excel. Есть программа "Не Excel". В ней есть кнопка. Так вот, при нажатии этой кнопки и получаются эти 20 файлов. А далее, по крайней мере сейчас, девочка заходит в каждый из этих файлов, жмакает "сохранить", слегка переименовывает, и жмакает "закрыть".
Я не сомневаюсь, что задачу можно решить и не макросом Excel, а другой программой, но макросы мне ближе.
Андрей, с точки зрения системы - пока информация не сохранена - это не файл, и уж тем более не открытый. Да,придирка от системщика :-) Заходят ( запускают) приложение, в приложении открывают файл. ну то что некоторый файлы (exe) самостоятельные приложения , это побочный эффект :-) Ведь например VBS можно открыть редактором, а можно запустить ( хотя это открыть обработчиком)
RAN написал: Интересует поведение данного кода в различных версиях Ofis, и различных ОС.
Люблю мучать старичков)). WinXP SP3, OfficeXP SP3 - результат 2. Причем, когда сначала открылось не 4 файла, а порядка 10, причем очень знакомых, дошло, что xlsx файлы преобразуются в xls и отрываются из папки Temp (повод почистить)), тестовая программа и пооткрывала все такие файлы (тогда результат был - 1). После переноса в нужную папку, все отработало (создались папки и пересохранились файлы).
Excel 2013 Pro+ с одним открытым файлом k = 1 c двумя 10-секундный паркинсон, k = 494
повторил то же самое в 2010 portable, 2007, 2003 portable с любым количеством файлов k=1
до кучи, написал вариант c EnumWindows и EnumChildWindows (для x86)
Скрытый текст
Код
Option Explicit
Private Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd&, ByVal lpClassName$, ByVal nMaxCount&) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd&, ByVal dwId&, riid As GUID, xlWB As Object) As Long
Private Declare Function EnumWindows Lib "User32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumChildWindows Lib "User32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetMemVar Lib "msvbvm60" (ByVal pSrc As Long, ByRef MyVar As Variant) As Long
Private Declare Function GetWindowThreadProcessId Lib "User32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Dim i
Private G As GUID
Sub main()
Dim Dic As Object: Set Dic = CreateObject("scripting.dictionary")
SetGUID G
EnumWindows AddressOf WndProc, VarPtr(Array("XLMAIN", Dic, GetCurrentProcessId))
Set Dic = Nothing
End Sub
Private Sub SetGUID(ByRef ID As GUID, Optional VerRus As Boolean = True)
If VerRus Then
With ID
.Data1 = &H20400
.Data2 = &H0
.Data3 = &H0
.Data4(0) = &HC0
.Data4(1) = &H0
.Data4(2) = &H0
.Data4(3) = &H0
.Data4(4) = &H0
.Data4(5) = &H0
.Data4(6) = &H0
.Data4(7) = &H46
End With
Else
With ID
.Data1 = &H90140000
.Data2 = &H16
.Data3 = &H409
.Data4(0) = &H0
.Data4(1) = &H0
.Data4(2) = &H0
.Data4(3) = &H0
.Data4(4) = &H0
.Data4(5) = &HF
.Data4(6) = &HF1
.Data4(7) = &HCE
End With
End If
End Sub
Function WndProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim param As Variant
GetMemVar lParam, param
Select Case param(0)
Case "XLMAIN"
Dim pid As Long
GetWindowThreadProcessId hWnd, pid
If pid <> param(2) And ClassName(hWnd) = param(0) Then
If IsEmpty(param(1)(pid)) Then
EnumChildWindows hWnd, AddressOf Module1.WndProc, VarPtr(Array("EXCEL7", pid))
End If
End If
WndProc = True
Case "EXCEL7"
Dim w As Window, oWb As Workbook, n%
If ClassName(hWnd) = param(0) Then
AccessibleObjectFromWindow hWnd, &HFFFFFFF0, G, w
With w.Application
n = 0
For Each oWb In .Workbooks
Select Case False
Case oWb.Windows(1).Visible, oWb.Windows.Count
n = n + 1
Case Else
SaveWorkbook .Parent, oWb
End Select
Next
If .Workbooks.Count - n = 0 Then
Shell Environ("comspec") & " /c ""taskkill -f /pid " & param(1) & """"
End If
End With
Else
WndProc = True
End If
End Select
DoEvents
End Function
Sub SaveWorkbook(xl As Application, wb As Workbook)
Dim fName$, tmpName$, sSavePath$, sSuf$
fName = wb.Name
If wb.Path = "" Then
If InStr(fName, "+ -") > 0 Then
tmpName = Trim$(Left$(fName, InStr(fName, "+") - 1))
' sSavePath = ThisWorkbook.Path & "\Выгрузка\" & tmpName
sSavePath = ThisWorkbook.Path & "\" & tmpName
On Error Resume Next
MkDir (sSavePath)
If Err Then Err.Clear
On Error GoTo 0
If InStr(1, Mid$(fName, InStr(fName, "+")), " акт ", 1) > 0 Then
sSuf = " Акт"
ElseIf InStr(1, Mid$(fName, InStr(fName, "+")), " сметный ", 1) > 0 Then
sSuf = " Смета"
End If
xl.DisplayAlerts = False
wb.SaveAs sSavePath & "\" & tmpName & sSuf & ".xlsx", 51
xl.DisplayAlerts = True
wb.Close False
End If
End If
End Sub
Function ClassName$(ByVal hWnd&)
Dim windowClass As String
Dim retVal As Long
windowClass = Space(255)
retVal = GetClassName(hWnd, windowClass, 255)
ClassName = Left$(windowClass, retVal)
End Function
Здравствуйте, коллеги! Проблемы "зацикливания" в версиях 2013+ вызваны переходом Excel на интерфейс SDI. Метод обхода экземпляров Excel от Peter Thornton циклить не должен (взять второй, уточненный вариант).