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.