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

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().

Vayrus · #7 07.03.2010, 23:23

Очень смешно))))

0nni · #8 08.03.2010, 00:12

Ну, если ты привык не убирать за собой...
И я уверен что похожую процедуру рисования на экране(или взятии скриншота или еще чего) ты использовал или будешь использовать еще не в одной из своих программ. И не только ты, а еще и некоторые начинающие программисты, забежавшие в эту тему. В результате получим кучу программ с утечками памяти.

Vayrus · #9 08.03.2010, 12:18

А c.free; это что по-твоему, разве не происходит высвобождения вместе с канвасом автоматом ?

0nni · #10 08.03.2010, 13:51

Цитата:

Сообщение от Vayrus

А c.free; это что по-твоему, разве не происходит высвобождения вместе с канвасом автоматом ?

Могу порекомендовать заглянуть в диспетчер задач:

Или код деструктора TCanvas.

PhoeniX · #11 08.03.2010, 13:53

В недостатки: по ходу просмотра исходника обнаружил, что тот же "vk.com" он спокойно пропустит.

Vayrus · #12 08.03.2010, 18:45

Цитата:

Сообщение от DJ PhoeniX

В недостатки: по ходу просмотра исходника обнаружил, что тот же "vk.com" он спокойно пропустит.

Нет, ошибаетесь

Vayrus · #13 08.03.2010, 18:57

Исправлено, спасибо 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.

PhoeniX · #14 09.03.2010, 23:14

Я только что спокойно обошёл эту "защиту" - подменил в cookies от vk.com параметр remixlang = 3 (Английский). Не привычно, но сидеть можно. Ибо заголовки "VK" он не палит.

Vayrus · #15 10.03.2010, 07:52

Цитата:

Сообщение от DJ PhoeniX

Я только что спокойно обошёл эту "защиту" - подменил в cookies от vk.com параметр remixlang = 3 (Английский). Не привычно, но сидеть можно. Ибо заголовки "VK" он не палит.

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

ЗЫ
А так меня больше интересует рисование без использования модуля Graphics, чтобы уменьшить конечный размер файла, или же другие
оптимизации. Ну ессно и то, применял ли кто мою прожку на практике

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

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