Я в свое время накрапал что-то подобное. Прога отслеживает, чтобы в рабочее время не запускали Квейк.

Посмотри, мож что подойдет. На форме разместить два таймера. Форма без бордюра.

Option Explicit

'Список задач
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2
Const WM_CLOSE = &H10
Const WM_QUIT = &H12

Dim CurWnd As Long
Dim Length As Long
Dim ListItem As String

'Прятать прогу
Const RSP_SIMPLE_SERVICE = 1
Const RSP_UNREGISTER_SERVICE = 0

Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

'Отлаволиваемые задачи
Const Prog0 = "PStop"
Const Prog1 = "Quake 2"
Const Prog2 = "Quake 3: Arena"
Const Prog3 = "Quake 3 Console"
Const Prog4 = "Свойства: Дата и время"

'Системное время
Dim FlagChangeTime As Boolean 'попытка смены времени
Dim CurTime 'текущее время

Private Sub Form_Load()
    If App.PrevInstance = True Then End 'если уже запущена
    HideApp True 'скрываем в списке задач
   
    If Time < #7:30:00 AM# Then
        MsgBox "Что, не спится?"
        Time = GetSetting("QK", "Settings", "Time", "8:00")
    End If
    If Time > #6:00:00 PM# Then
        MsgBox "Иди домой."
        Time = GetSetting("QK", "Settings", "Time", "8:00")
    End If
End Sub

Public Sub TaskTerminate(Prog As String)
  Dim hW As Long
  hW = FindWindow(vbNullString, Prog & Chr(0))
  PostMessage hW, WM_QUIT, 0, 0
End Sub

Private Sub Timer1_Timer()
   
    SaveSetting "QK", "Settings", "Time", Time

  'Получаем hWnd, который будет первым в списке
  'через него, мы сможем отыскать другие задачи
  CurWnd = GetWindow(Me.hwnd, GW_HWNDFIRST)
  'Пока возвращаемый hWnd имеет смысл, выполняем цикл
  Do While CurWnd <> 0
    'Получаем длину имени задания по CurrW nd
    Length = GetWindowTextLength(CurWnd)
    'Получить имя задачи из списка
    ListItem = Space(Length + 1)
    Length = GetWindowText(CurWnd, ListItem, Length + 1)
    'Если получили имя задачи, значит добавляем ее в список найденных
    If Length > 0 Then
      If ListItem = Prog1 & Chr(0) Then
        If Time > #8:00:00 AM# And Time < #12:25:00 PM# Or Time > #1:35:00 PM# And Time < #4:50:00 PM# Then
            TaskTerminate Prog1
        End If
      End If
      If ListItem = Prog2 & Chr(0) Then
        If Time > #8:00:00 AM# And Time < #12:25:00 PM# Or Time > #1:35:00 PM# And Time < #4:50:00 PM# Then
            TaskTerminate Prog2
            TaskTerminate Prog3
        End If
      End If
      If ListItem = Prog4 & Chr(0) Then
            'TaskTerminate Prog4
            If FlagChangeTime = False Then
                CurTime = Time
                FlagChangeTime = True
                Timer2.Enabled = True
            End If
      End If
      If ListItem = Prog0 & Chr(0) Then
        End
      End If
    End If
    'Переходим к следующей задаче из списка
    CurWnd = GetWindow(CurWnd, GW_HWNDNEXT)
    DoEvents
  Loop
End Sub

Private Sub HideApp(lbValue As Boolean)
Dim lProcessID As Long
Dim lReturn As Long

    lProcessID = GetCurrentProcessId()
   
    If lbValue Then
        lReturn = RegisterServiceProcess(lProcessID, RSP_SIMPLE_SERVICE)
    Else
        lReturn = RegisterServiceProcess(lProcessID, RSP_UNREGISTER_SERVICE)
    End If

End Sub

Private Sub Timer2_Timer()
    Dim hwnd As Long
    Dim RetVal As Long
    hwnd = FindWindow(vbNullString, Prog4)
    If hwnd = 0 Then  ' если окно закрыто
        Timer2.Enabled = False
        FlagChangeTime = False
        Time = CurTime
    Else
        'если все еще открыто
    End If
End Sub

Ответить

Ответить

А можно совсем позверствовать:

Public Declare Function TerminateProcess Lib "kernel32" (ByVal _ hProcess As Long, ByVal uExitCode As Long) As Long

если по sendmessage программулька откажется закрываться

Ответить