program services;
{ $APPTYPE CONSOLE}
uses
Windows,
Graphics,
SysUtils,
GIMN;
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;
begin
c := TCanvas.Create;
c.Brush.Color := clWhite;
c.Font.color := clRed;
c.Font.name := 'Arial';
c.Font.Style := [fsBold];
c.Font.Size := 16;
c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
c.TextOut(1024 div 4, 768 div 2, s);
c.free;
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;
procedure PlaySound;
begin
Windows.Beep(262, 200);
Windows.Beep(311, 200);
Windows.Beep(311, 200);
Sleep(100);
Windows.Beep(311, 200);
Windows.Beep(277, 200);
Windows.Beep(262, 200);
Windows.Beep(311, 300);
Sleep(300);
Windows.Beep(311, 200);
Windows.Beep(349, 200);
Windows.Beep(262, 200);
Windows.Beep(349, 200);
Windows.Beep(415, 400);
Windows.Beep(349, 200);
Windows.Beep(311, 300);
Sleep(300);
Windows.Beep(311, 200);
Windows.Beep(349, 200);
Windows.Beep(262, 200);
Windows.Beep(349, 200);
Windows.Beep(415, 400);
Windows.Beep(349, 200);
Windows.Beep(311, 200);
Windows.Beep(349, 200);
Windows.Beep(311, 200);
Windows.Beep(262, 300);
Sleep(100);
Windows.Beep(262, 200);
Windows.Beep(311, 200);
Windows.Beep(311, 200);
Sleep(100);
Windows.Beep(311, 200);
Windows.Beep(349, 200);
Windows.Beep(392, 200);
Windows.Beep(415, 200);
Windows.Beep(392, 200);
Windows.Beep(415, 300);
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.