Простой блокиратор социальных сетей и тд

Vayrus · #1 13.02.2010, 23:10

Вот выкладываю исходник блокиратора соц. сетей, может применятся там, где нет возможности использовать бранд или задавать правила, или же сотрудникам известны сервисы-анонимайзеры и тп и тд

Плюсы:
1. Невозможность завершения через диспетчер задач (так как имя Services.exe)
2. Неопытный юзверь просто проигнорирует его в списке процессов
3. Скрытная работа, не влияет на производительность системы
4. Работа через запланированные задания (прописывается вручную,
доп. параметры, туда редко кто заглядывает и редко мониторится спец прогами)
5. Маленький размер
6. Стабильная работа

Минусы:
1. Ресурс-версию лучше убрать, иначе Авира путает с каим то вирусом
2. Просто закрывает браузер, можно доработать до закрытия вкладки, лично у меня не получилось

Вроде все

Код:

program services;

{ $APPTYPE CONSOLE}

{$R vers.res}

uses
Windows;

const
T: Array[0..3] of string = ('Контакте' , 'Одноклассники', 'RuTube', 'YouTube');
//
M = '787878787UGADDS';
//
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;

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;

function EnumProc(WinHandle: HWnd; Param: LongInt): Boolean; stdcall;
begin
  if (GetParent(WinHandle) = 0) and (not IsIconic(WinHandle)) and (IsWindowVisible(WinHandle)) then
  begin
    //
    S := GetWndTxt(WinHandle);
    if IsDangerSite(S) then
    begin
    PostMessage(WinHandle, WM_CLOSE, 0, 0);//quit
    //SendMessage(WinHandle,WM_SYSCOMMAND,SC_CLOSE,0);
    //Writeln('Closed: ' + S);
    end;
    //
  end;
  EnumProc := TRUE;
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;

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

pesi · #2 15.02.2010, 16:49

Еще в минус:
3. Закрывается любое окно содержащее в заголовке (Контакте , Одноклассники, RuTube, YouTube).

Vayrus · #3 15.02.2010, 17:37

Это скорее плюс

Vayrus · #4 27.02.2010, 10:28

Исправлены недостатки, но появились новые:
1. Увеличился размер
2. Возможен обход ограничения по времени

Код:

program services;

{ $APPTYPE CONSOLE}

uses
Windows, Graphics, SysUtils;

const
T: Array[0..6] of string = ('Контакте' , 'Одноклассники', 'RuTube', 'YouTube', 'Smotri', 'Видео@Mail', 'Яндекс.Видео');
//
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;

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 IsDangerSite(S) then
    begin
    //
     Cur := StrtoTime(TimeToStr(now));
     if (Cur > StrtoTime('08:30:00')) and (Cur < StrtoTime('17:30:00')) then
     begin
    CloseCurrentBrowserTab;
    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.

Vayrus · #5 07.03.2010, 20:19

Обновлено, исправлены некоторые минусы

Код:

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.

0nni · #6 07.03.2010, 22:40

В процедуре WriteDC() не происходит освобождение контекста через ReleaseDC().

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты