Отцы. Может быть я не прав, но вроде работает. Возможно это поможет другим.
В теме - "популярные вопросы", господин hCORe
рассмотрел ОФИГЕННЫЙ
пример слежения за программой. ( Мне очень помог !!!)
hCORe пишет
Надо сказать, что такой подход имеет и ряд собственных недостатков. Один из них - полная нагрузка на систему во время слежения. Проблему можно устранить при помощи многопоточности, однако это уже совсем другая история...
Я решил попробывать немного изменить код. Мне нужно было следить за выполнением моей программы из модуля, так что весь код сразу перетащил именно в него.
Как я понял, вся проблема в циклах Do Loop
Дальше вспомнил, что Tyomitch ( Респект ему огромный ) писал, что удобно для торможения цикла (чтобы не грузить процессор на 100%)поставить WaitMessage
Что я и сделал...
Вот что получилось
- Код: Выделить всё
'переменные
Dim sinfo As STARTUPINFO
Dim pinfo As PROCESS_INFORMATION
'константы API
Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = &HFFFF
Private Const DEBUG_PROCESS = &H1
Private Const DEBUG_ONLY_THIS_PROCESS = &H2
Private Const CREATE_SUSPENDED = &H4
Private Const DETACHED_PROCESS = &H8
Private Const CREATE_NEW_CONSOLE = &H10
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const IDLE_PRIORITY_CLASS = &H40
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const REALTIME_PRIORITY_CLASS = &H100
Private Const CREATE_NEW_PROCESS_GROUP = &H200
Private Const CREATE_NO_WINDOW = &H8000000
Private Const WAIT_FAILED = -1&
Private Const WAIT_OBJECT_0 = 0
Private Const WAIT_ABANDONED = &H80&
Private Const WAIT_ABANDONED_0 = &H80&
Private Const WAIT_TIMEOUT = &H102&
Private Const SW_SHOW = 5
'структуры API
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
'функции API
'открытие процесса
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
'закрытие объекта по модификатору
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'ожидание объекта
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
'создание процесса
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
'ожидание инициализации процесса
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
'уничтожение процесса по модификатору
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
' Эта процедура позволяет выполнять эффективное
' ожидание завершения приложения
' pinfo - структура типа PROCESS_INFORMATION,
' заполняемая при вызове CreateProcess
Private Sub WaitForTerm2(pinfo As PROCESS_INFORMATION)
Dim res&
' Произвести инициализацию процесса
Call WaitForInputIdle(pinfo.hProcess, INFINITE)
' Уничтожить модификатор нити
If hThread <> 0 Then
Call CloseHandle(pinfo.hThread)
End If
Do
res = WaitForSingleObject(pinfo.hProcess, 0)
If res <> WAIT_TIMEOUT Then
' Приложение завершается!
MsgBox "PROGRAM CLOSED"
Exit Do
End If
WaitMessage
DoEvents
Loop While True
' Уничтожить последний модификатор процесса
Call CloseHandle(pinfo.hProcess)
End Sub
Sub main()
Dim rc As Long, rRc As Long
sinfo.cb = Len(sinfo) 'длина
sinfo.lpReserved = vbNullString
sinfo.lpDesktop = vbNullString
sinfo.lpTitle = "OUR PROGRAM" 'vbNullString 'заголовок
sinfo.dwFlags = 0 'флаги
za = HIGH_PRIORITY_CLASS 'NORMAL_PRIORITY_CLASS 'установим приоритет задачи
'запустим WinRar
rc = CreateProcess("C:\windows\system32\cmd.exe", "", 0, 0, True, za, ByVal 0&, vbNullString, sinfo, pinfo)
'запустим ожидание
WaitForTerm2 pinfo
End Sub
А вот теперь собственно вопросы.
1) Хотел узнать - не повлияет ли WaitMessage на перехват ивентов ?
2) Что делают параметры
sinfo.lpReserved = vbNullString
sinfo.lpDesktop = vbNullString
. А то расстроится чел. 
