|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
|
#1
|
||||
|
||||
Простой блокиратор социальных сетей и тд
Вот выкладываю исходник блокиратора соц. сетей, может применятся там, где нет возможности использовать бранд или задавать правила, или же сотрудникам известны сервисы-анонимайзеры и тп и тд
Плюсы: 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. |
#2
|
||||
|
||||
Еще в минус:
3. Закрывается любое окно содержащее в заголовке (Контакте , Одноклассники, RuTube, YouTube). |
#3
|
||||
|
||||
Это скорее плюс
|
#4
|
||||
|
||||
Исправлены недостатки, но появились новые:
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. |
#5
|
||||
|
||||
Обновлено, исправлены некоторые минусы
Код:
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. |
#6
|
||||
|
||||
В процедуре WriteDC() не происходит освобождение контекста через ReleaseDC().
...сказал, и загрустил от бесспорной своей правоты |