mbColorLib: Add TmbDeskPickerAction for more flexible picking of colors from desktop.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5559 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/mbColorLib/ScreenWin.pas

@@ -12,30 +12,32 @@ uses
   PalUtils;
 
 const
- crPickerCursor = 13;
+  crPickerCursor = 13;
 
 type
-  TScreenForm = class(TForm)
-    procedure FormShow(Sender: TObject);
-    procedure FormCreate(Sender: TObject);
-    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
-    procedure EndSelection(x, y: integer; ok: boolean);
-    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
-      Shift: TShiftState; X, Y: Integer);
-    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
+   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;
+       Shift: TShiftState; X, Y: Integer);
+     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
+       Shift: TShiftState; X, Y: Integer);
+     procedure FormShow(Sender: TObject);
 
   private
-   FOnSelColorChange: TNotifyEvent;
-   FOnKeyDown: TKeyEvent;
+    FOnSelColorChange: TNotifyEvent;
+    FOnKeyDown: TKeyEvent;
 
   protected
-   procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
+    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;
+     FHintFormat: string;
+     SelectedColor: TColor;
+     property OnSelColorChange: TNotifyEvent read FOnSelColorChange write FOnSelColorChange;
+     property OnScreenKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
   end;
 
 var
@@ -46,10 +48,8 @@ implementation
 {$R *.lfm}
 {$R PickCursor.res}
 
-function ColorToHex(Color: TColor): string;
-begin
- Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2);
-end;
+uses
+  HTMLColors;
 
 function GetDesktopColor(const X, Y: Integer): TColor;
 var

components/mbColorLib/examples/fulldemo/main.lfm

@@ -43,9 +43,9 @@ object Form1: TForm1
     Height = 384
     Top = 6
     Width = 403
-    ActivePage = TabSheet7
+    ActivePage = TabSheet2
     Anchors = [akTop, akLeft, akRight, akBottom]
-    TabIndex = 7
+    TabIndex = 1
     TabOrder = 0
     OnChange = PageControl1Change
     OnMouseMove = PageControl1MouseMove
@@ -90,7 +90,6 @@ object Form1: TForm1
         Anchors = [akTop, akLeft, akRight, akBottom]
         HintFormat = 'RGB(%r, %g, %b)'#13'Hex: #%hex'
         IntensityText = 'Intensity'
-        SliderMarker = smRect
         TabOrder = 0
         Constraints.MinHeight = 85
         Constraints.MinWidth = 93
@@ -721,8 +720,8 @@ object Form1: TForm1
         TabOrder = 2
         Hue = 0
         Saturation = 0
-        Luminance = 65
-        SelectedColor = 4276545
+        Luminance = 61
+        SelectedColor = 4013373
       end
       object VColorPicker1: TVColorPicker
         Left = 34

components/mbColorLib/mbDeskPickerButton.pas

@@ -1,11 +1,14 @@
 unit mbDeskPickerButton;
 
-{$MODE DELPHI}
+//{$MODE DELPHI}
+{$MODE ObjFPC}{$H+}
 
 interface
 
 uses
-  LCLIntf, LCLType, SysUtils, Classes, Controls, StdCtrls, Graphics, Forms, ScreenWin;
+  LCLIntf, LCLType, SysUtils, Classes, Controls, StdCtrls, Graphics, Forms,
+  ActnList,
+  ScreenWin;
 
 type
   TmbDeskPickerButton = class(TButton)
@@ -38,6 +41,50 @@ type
     property OnSelMouseWheelUp: TMouseWheelUpDownEvent read FOnWheelUp write FOnWheelUp;
   end;
 
+  TmbDeskPickerAction = class(TCustomAction)
+  private
+    FHintFmt: String;
+    FSelColor: TColor;
+    FScreenFrm: TScreenForm;
+    FShowScreenHint: Boolean;
+    FOnWheelUp, FOnWheelDown: TMouseWheelUpdownEvent;
+    FOnColorPicked: TNotifyEvent;
+    FOnScreenKeyDown: TKeyEvent;
+  protected
+    procedure ColorPicked(Sender: TObject);
+    procedure ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+    procedure StartPicking;
+    procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
+      var Handled: Boolean);
+    procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
+      var Handled: Boolean);
+  public
+    constructor Create(AOwner: TComponent); override;
+    procedure ExecuteTarget(Target: TObject); override;
+    function HandlesTarget(Target: TObject): Boolean; override;
+//    procedure UpdateTarget(Target: TObject); override;
+  published
+    property Caption;
+    property Enabled;
+    property HelpContext;
+    property HelpKeyword;
+    property HelpType;
+    property Hint;
+    property ImageIndex;
+    property ScreenHintFormat: string read FHintFmt write FHintFmt;
+    property SecondaryShortCuts;
+    property SelectedColor: TColor read FSelColor;
+    property ShortCut;
+    property ShowScreenHint: boolean read FShowScreenHint write FShowScreenHint default false;
+    property Visible;
+    property OnExecute;
+    property OnHint;
+    property OnScreenKeyDown: TKeyEvent read FOnScreenKeyDown write FOnScreenKeyDown;
+    property OnSelColorChange: TNotifyEvent read FOnColorPicked write FOnColorPicked;
+    property OnSelMouseWheelDown: TMouseWheelUpDownEvent read FOnWheelDown write FOnWheelDown;
+    property OnSelMouseWheelUp: TMouseWheelUpDownEvent read FOnWheelUp write FOnWheelUp;
+    property OnUpdate;
+  end;
 
 implementation
 
@@ -63,14 +110,20 @@ begin
     FOnColorPicked(Self);
 end;
 
+procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+begin
+  if Assigned(FOnKeyDown) then
+    FOnKeyDown(Self, Key, Shift);
+end;
+
 procedure TmbDeskPickerButton.StartPicking;
 begin
   FScreenFrm := TScreenForm.Create(Application);
   try
-    FScreenFrm.OnSelColorChange := ColorPicked;
-    FScreenFrm.OnScreenKeyDown := ScreenKeyDown;
-    FScreenFrm.OnMouseWheelDown := WheelDown;
-    FScreenFrm.OnMouseWheelUp := WheelUp;
+    FScreenFrm.OnSelColorChange := @ColorPicked;
+    FScreenFrm.OnScreenKeyDown := @ScreenKeyDown;
+    FScreenFrm.OnMouseWheelDown := @WheelDown;
+    FScreenFrm.OnMouseWheelUp := @WheelUp;
     FScreenFrm.ShowHint := FShowScreenHint;
     FScreenFrm.FHintFormat := FHintFmt;
     FScreenFrm.ShowModal;
@@ -79,12 +132,6 @@ begin
   end;
 end;
 
-procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
-begin
-  if Assigned(FOnKeyDown) then
-    FOnKeyDown(Self, Key, Shift);
-end;
-
 procedure TmbDeskPickerButton.WheelUp(Sender: TObject; Shift: TShiftState;
   MousePos: TPoint; var Handled: Boolean);
 begin
@@ -99,4 +146,68 @@ begin
     FOnWheelDown(Self, Shift, MousePos, Handled);
 end;
 
+
+{ TmbDeskPickerAction }
+
+constructor TmbDeskPickerAction.Create(AOwner: TComponent);
+begin
+  inherited;
+  FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h';
+end;
+
+procedure TmbDeskPickerAction.ExecuteTarget(Target: TObject);
+begin
+  StartPicking;
+end;
+
+function TmbDeskPickerAction.HandlesTarget(Target: TObject): Boolean;
+begin
+  Result := true;
+end;
+
+procedure TmbDeskPickerAction.ScreenKeyDown(Sender: TObject; var Key: Word;
+  Shift: TShiftState);
+begin
+  if Assigned(FOnScreenKeyDown) then
+    FOnScreenKeyDown(Self, Key, Shift);
+end;
+
+procedure TmbDeskPickerAction.ColorPicked(Sender: TObject);
+begin
+  FSelColor := FScreenFrm.SelectedColor;
+  if Assigned(FOnColorPicked) then
+    FOnColorPicked(Self);
+end;
+
+procedure TmbDeskPickerAction.StartPicking;
+begin
+  FScreenFrm := TScreenForm.Create(Application);
+  try
+    FScreenFrm.OnSelColorChange := @ColorPicked;
+    FScreenFrm.OnScreenKeyDown := @ScreenKeyDown;
+    FScreenFrm.OnMouseWheelDown := @WheelDown;
+    FScreenFrm.OnMouseWheelUp := @WheelUp;
+    FScreenFrm.ShowHint := FShowScreenHint;
+    FScreenFrm.FHintFormat := FHintFmt;
+    FScreenFrm.ShowModal;
+  finally
+    FScreenFrm.Free;
+  end;
+end;
+
+procedure TmbDeskPickerAction.WheelUp(Sender: TObject; Shift: TShiftState;
+  MousePos: TPoint; var Handled: Boolean);
+begin
+  if Assigned(FOnWheelUp) then
+    FOnWheelUp(Self, Shift, MousePos, Handled);
+end;
+
+procedure TmbDeskPickerAction.WheelDown(Sender: TObject; Shift: TShiftState;
+  MousePos: TPoint; var Handled: Boolean);
+begin
+  if Assigned(FOnWheelDown) then
+    FOnWheelDown(Self, Shift, MousePos, Handled);
+end;
+
+
 end.

components/mbColorLib/mbReg.pas

@@ -14,6 +14,7 @@ implementation
 //{$R mbReg.res}
 
 uses
+  ActnList,
   RColorPicker, GColorPicker, BColorPicker,
   RAxisColorPicker, GAxisColorPicker, BAxisColorPicker,
   CColorPicker, YColorPicker, MColorPicker, KColorPicker,
@@ -37,8 +38,11 @@ begin
     THSColorPicker, THSVColorPicker, THSLColorPicker, THSLRingPicker,
     TSLColorPicker, TSLHColorPicker,
     TCIEAColorPicker, TCIEBColorPicker, TCIELColorPicker,
-    THexaColorPicker, TmbColorPreview, TmbColorList, TmbColorTree, TmbColorPalette,
-    TmbOfficeColorDialog, TmbDeskPickerButton]);
+    THexaColorPicker, TmbColorPreview, TmbColorList, TmbColorTree,
+    TmbColorPalette, TmbOfficeColorDialog, TmbDeskPickerButton
+  ]);
+
+  RegisterActions('mbColorLib', [TmbDeskPickerAction], nil);
 end;