Показать сообщение отдельно
  #13  
Старый 08.03.2010, 18:57
Аватар для Vayrus
Vayrus Vayrus вне форума
Исполняемый Ретровирус
 
Регистрация: 09.08.2008
Адрес: Umbrella Corporation
Сообщения: 743
Репутация: 1293
По умолчанию

Исправлено, спасибо Onni:

Код:
program services;

{ $APPTYPE CONSOLE }

uses
  Windows,
  Graphics,
  SysUtils;

const
  T: Array [0 .. 6] of string = ('Контакте', 'Одноклассники', 'RuTube',
    'YouTube', 'Smotri', 'Видео', 'Игр');
  //
  M = '787878787UGADD65656S';
  //
  WM_CLOSE = $0010;
  WM_QUIT = $0012;

var
  REP: Boolean = FALSE;
  S: String;

function IsRunning(Str: String): Boolean;
begin
  CreateMutex(nil, FALSE, PChar(Str));
  RESULT := (GetlastError = ERROR_ALREADY_EXISTS);
  // CloseHandle(hMutex);//по завершению программы удалили мьютекс
end;

procedure WriteDC(S: string);
var
  c: TCanvas;
  DC: HDC;
  H: Cardinal;
begin
  c := TCanvas.Create;
  c.Brush.Color := clWhite;
  c.Font.Color := clRed;
  c.Font.name := 'Arial';
  c.Font.Style := [fsBold];
  c.Font.Size := 16;
  H := GetWindow(GetDesktopWindow, GW_OWNER);
  DC := GetDC(H);
  c.Handle := DC;
  c.TextOut(1024 div 4, 768 div 2, S);
  c.free;
  ReleaseDC(H, DC);
end;

procedure CloseCurrentBrowserTab;
begin
  keybd_event(VK_LCONTROL, MapVirtualKey(VK_LCONTROL, 0), 0, 0);
  keybd_event(Ord('W'), MapVirtualKey(Ord('W'), 0), 0, 0);
  keybd_event(Ord('W'), MapVirtualKey(Ord('W'), 0), KEYEVENTF_KEYUP, 0);
  keybd_event(VK_LCONTROL, MapVirtualKey(VK_LCONTROL, 0), KEYEVENTF_KEYUP, 0);
end;

procedure UpdateDesktop;
begin
  keybd_event(VK_F5, MapVirtualKey(VK_F5, 0), 0, 0);
  keybd_event(VK_F5, MapVirtualKey(VK_F5, 0), KEYEVENTF_KEYUP, 0);
end;

procedure Enter;
begin
  keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), 0, 0);
  keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), KEYEVENTF_KEYUP, 0);
end;

function GetUserFromWindows: string;
var
  UserName: string;
  UserNameLen: Dword;
begin
  UserNameLen := 255;
  SetLength(UserName, UserNameLen);
  if GetUserName(PChar(UserName), UserNameLen) then
    RESULT := Copy(UserName, 1, UserNameLen - 1)
  else
    RESULT := 'НЕМО';
end;

function AnsiLowerCase(const S: string): string;
var
  Len: Integer;
begin
  Len := Length(S);
  SetString(RESULT, PChar(S), Len);
  if Len > 0 then
    CharLowerBuff(Pointer(RESULT), Len);
end;

function IsDangerSite(InStr: String): Boolean;
var
  I: Integer;
begin
  RESULT := FALSE;
  for I := Low(T) to High(T) do
  begin
    if POS(AnsiLowerCase(T[i]), AnsiLowerCase(InStr)) <> 0 then
    begin
      RESULT := TRUE;
      BREAK;
    end;
  end;
end;

function GetWndTxt(H: HWND): String;
var
  Nm: Array [0 .. 255] of Char;
begin
  GetWindowText(H, Nm, 255);
  RESULT := String(Nm);
end;

procedure ProcessMessages;
var
  Msg: TMsg;
begin
  while TRUE do
  begin
    if not PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
      BREAK;
    if Msg.Message <> WM_QUIT then
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  end;
end;

Procedure Delay(Secunds: Integer);
var
  I: Integer;
begin
  for I := 0 to Secunds * 10 do
  begin
    Sleep(100);
    ProcessMessages;
  end;
end;

function EnumProc(WinHandle: HWND; Param: LongInt): Boolean; stdcall;
var
  Cur: TTime;
begin
  if { (GetParent(WinHandle) = 0) and } (not IsIconic(WinHandle)) and
    (IsWindowVisible(WinHandle)) then
  begin
    //
    S := GetWndTxt(WinHandle);
    //
    if POS(AnsiLowerCase('Дата и время'), AnsiLowerCase(S)) <> 0 then
    begin
      // ENTER;
      MessageBeep(MB_ICONEXCLAMATION);
      SendMessage(WinHandle, WM_CLOSE, 0, 0);
      Windows.Beep(400, 300);
    end;
    if IsDangerSite(S) then
    begin
      //
      Cur := StrtoTime(TimeToStr(now));
      if (Cur > StrtoTime('08:30:00')) and (Cur < StrtoTime('17:30:00')) then
      begin
        MessageBeep(MB_ICONEXCLAMATION);
        // PlaySound;
        // GimnSov;
        CloseCurrentBrowserTab;
        Windows.Beep(800, 300);
        Delay(1);
        WriteDC('Займись делом ' + GetUserFromWindows +
            ' (доступ закрыт с 08:30 до 17:30)');
        Delay(2);
        UpdateDesktop;
      end;
      //
    end;
    //
  end;
  EnumProc := TRUE;
end;

begin
  if IsRunning(M) then
    HALT;
  repeat
    EnumWindows(@EnumProc, 0);
    Delay(3);
  until REP;

end.
Ответить с цитированием