Детектор "командного" пикселя

Хочу рассказать вам о том как делать не надо, но мы все же сделали :) Не буду рассказывать почему мы это сделали (у кого есть опыт, тот и сам догадается что это просто "костыли", для быстрой реализации нужного функционала).
Внезапно возникла потребность что бы клиентское ПО, реагировало на некую команду от сервера, без вмешательство в существующее API. Все что требуется клиенту - изменить реазрешение экрана, когда он "видит" в определенном месте, в браузере зеленый пиксель. Есть зеленый пиксель - изменить разрешение на максимальное, если пикселя нет - разрешение остается таким, которое задано в настройках.
Вот собственно ниже привожу код такого "детектора пикселя". Это фоновый поток \, который постоянно мониторит заданную область экрана. Если найден пиксель - генерирует событие.
unit Color.Detector;
interface
uses
System.SysUtils, System.Classes, System.UITypes, Winapi.Windows, VCL.Graphics;
type
TScreenDetector = class(TThread)
private
DesktopHDC: HDC;
DesktopBMP: TBitmap;
Color: TColor;
Detected: Boolean;
DRect: TRect;
FOnDetect: TProc<Boolean,TColor>;
procedure RefreshBitmap;
protected
procedure Execute; override;
public
constructor Create(AColor: TColor; ADetectRect: TRect);
destructor Destroy; override;
property OnDetect: TProc<Boolean,TColor> read FOnDetect write FOnDetect;
end;
implementation
{ TScreenDetector }
constructor TScreenDetector.Create(AColor: TColor; ADetectRect: TRect);
begin
inherited Create(True);
Detected := False;
Color := AColor;
DRect := ADetectRect;
DesktopHDC := GetDC(GetDesktopWindow);
DesktopBMP := TBitmap.Create;
DesktopBMP.PixelFormat := TPixelFormat.pf16bit;
DesktopBMP.SetSize(DRect.Width, DRect.Height);
end;
destructor TScreenDetector.Destroy;
begin
FreeAndNil(DesktopBMP);
DeleteDC(DesktopHDC);
inherited;
end;
procedure TScreenDetector.RefreshBitmap;
begin
DesktopBMP.Canvas.Lock;
try
BitBlt(DesktopBMP.Canvas.Handle, 0,0, DRect.Width, DRect.Height, DesktopHDC, DRect.Left, DRect.Top , SRCCOPY);
finally
DesktopBMP.Canvas.Unlock;
end;
end;
procedure TScreenDetector.Execute;
var
x,y: integer;
LDetect: Boolean;
begin
while not Terminated do
begin
RefreshBitmap;
LDetect := False;
for x := 0 to DesktopBMP.Width do
for y := 0 to DesktopBMP.Height do
begin
if (DesktopBMP.Canvas.Pixels[x,y] = Color) then
begin
LDetect := True;
Break;
end;
end;
Synchronize(nil,
procedure
begin
if LDetect and not Detected and Assigned(OnDetect) then
begin
Detected := True;
OnDetect(True,Color)
end
else
if not LDetect and Detected and Assigned(OnDetect) then
begin
Detected := False;
OnDetect(False,Color);
end;
end);
Sleep(100);
end;
end;
end.

Комментарии

  • 21 ноя 2017 18:52
    Pascal с классами. Тот самый, который я не стал изучать, потому что он под MS-DOS.
  • 21 ноя 2017 18:57
    У меня есть учебник "Основы программирования" (1999 год), который написан на Паскале. Я посмотрел и не стал его учить, потому что он под MS-DOS. Я все примеры перевожу с Паскаля на C, результат представлен в предыдущей теме. Из всех задач я тщательно вырезаю слова "на Паскале" и делаю на C.
  • 22 ноя 2017 06:52
    Вообще то это Object Pascal или попросту Delphi. А еще точней Delphi 10.2 Tokyo. Эта версия вышла весной 2017 года. О существовании DOS она даже не подозревает.  Но знает о Windows, Linux,  MacOS,  iOS, Android. Под эти операционки можно писать кросплатформенный код.
  • 22 ноя 2017 06:58
    "На вкус и цвет - все фломастеры разные" (с). С++ был первым языком который я изучил и написал на нем пару программ для промышленной эксплуатации. Это еще в 1996 году было. Даже есть бумажка с печатью :-) Но потом ушел в другие языки. В том числе в Pascal.
    Перевести код с одного языка на другой не является проблемой в 90% случаев. Но надо "не вырезать", а именно переводить. Потому как каждый язык имеет свои особенности. Хотя Pasсal и С++ очень похожи и отличаются в основном синтаксисом.