lazarus-ccr/components/mbColorLib/ScreenWin.pas

unit ScreenWin;

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}

interface

uses
  LCLIntf, LCLType, SysUtils, Classes, Graphics, Controls, Forms,
  ExtCtrls, StdCtrls,
  PalUtils;

const
  crPickerCursor = 13;

type
   TScreenForm = class(TForm)
   procedure EndSelection(x, y: integer; ok: boolean);
     procedure FormCreate(Sender: TObject);
     procedure FormKeyDown(Sender: TObject; var Key: Word;
       Shift: TShiftState);
     procedure FormMouseMove(Sender: TObject;
       {%H-}Shift: TShiftState; X, Y: Integer);
     procedure FormMouseUp(Sender: TObject; {%H-}Button: TMouseButton;
       {%H-}Shift: TShiftState; X, Y: Integer);
     procedure FormShow(Sender: TObject);

  private
    FOnSelColorChange: TNotifyEvent;
    FOnKeyDown: TKeyEvent;
    function GetDesktopColor(const X, Y: Integer): TColor;
    function ReadScreenColor(const X, Y: Integer): TColor;

  protected
    procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;

  public
     FHintFormat: string;
     SelectedColor: TColor;
     property OnSelColorChange: TNotifyEvent read FOnSelColorChange write FOnSelColorChange;
     property OnScreenKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
  end;

var
  ScreenForm: TScreenForm;

implementation

{$R *.lfm}
{$R PickCursor.res}

uses
  HTMLColors;


{ TScreenForm }

procedure TScreenForm.CMHintShow(var Message: TCMHintShow);
begin
  with TCMHintShow(Message) do
    if not ShowHint then
      Message.Result := 1
   else
     with HintInfo^ do
     begin
       Result := 0;
       ReshowTimeout := 1;
       HideTimeout := 5000;
       HintPos := Point(HintPos.X + 16, HintPos.y - 16);
       HintStr := FormatHint(FHintFormat, SelectedColor);
     end;
  inherited;
end;

procedure TScreenForm.EndSelection(x, y: integer; ok: boolean);
begin
  if ok then
    SelectedColor := GetDesktopColor(x, y)
  else
    SelectedColor := clNone;
  Close;
  if Assigned(FOnSelColorChange) then
    FOnSelColorChange(Self);
end;

procedure TScreenForm.FormCreate(Sender: TObject);
begin
  // The screen form is the same size of the screen and is transparent.
  // Unfortunately it cannot be made fully transparent (AlphaBlendvalue=0)
  // because it would not react on mouse event this way.
  AlphaBlendValue := 1;  // range 0..255; 1 is "almost" transparent
  AlphaBlend := true;

  Brush.Style := bsClear;
  Screen.Cursors[crPickerCursor] := LoadCursor(HInstance, 'PickerCursor');
  Cursor := crPickerCursor;
  SelectedColor := clNone;
  FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %h';
end;

procedure TScreenForm.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (key = VK_ESCAPE) or (ssAlt in Shift) or (ssCtrl in Shift) then
    EndSelection(0, 0, false);
  if (key = VK_RETURN) then
    EndSelection(Mouse.CursorPos.X, Mouse.CursorPos.Y, true);
  if Assigned(FOnKeyDown) then
    FOnKeyDown(Self, Key, Shift);
end;

procedure TScreenForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  SelectedColor := GetDesktopColor(x, y);
  if Assigned(FOnSelColorChange) then FOnSelColorChange(Self);
  Application.ProcessMessages;
end;

procedure TScreenForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  EndSelection(x, y, true);
end;

procedure TScreenForm.FormShow(Sender: TObject);
begin
  Width := Screen.DesktopWidth;
  Height := Screen.DesktopHeight;
  Left := Screen.DesktopLeft;
  Top := Screen.DesktopTop;
{
  Width := Screen.Width;
  Height := Screen.Height;
  Left := 0;
  Top := 0;
}
end;

function TScreenForm.GetDesktopColor(const X, Y: Integer): TColor;
var
  savedAlphaBlendValue: Integer;
begin
  savedAlphaBlendValue := AlphablendValue;
  try
    AlphaBlendValue := 0;
    Result := ReadScreenColor(X, Y);
  finally
    AlphaBlendValue := savedAlphaBlendValue;
  end;
end;

function TScreenForm.ReadScreenColor(const X, Y: integer):TColor;
var
  ScreenDC: HDC;
  SaveBitmap: TBitmap;
begin
  SaveBitmap := TBitmap.Create;
  try
    SaveBitmap.SetSize(Screen.Width, Screen.Height);
    ScreenDC := GetDC(0);
    try
      SaveBitmap.LoadFromDevice(ScreenDC);
    finally
      ReleaseDC(0, ScreenDC);
    end;
    Result := SaveBitmap.Canvas.Pixels[X, Y];
  finally
    SaveBitmap.Free;
  end;
end;


end.