From b8a19cf29b338a3392fd5d21acd3bd5de2ccc570 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Fri, 9 Dec 2016 23:47:46 +0000 Subject: [PATCH] mbColorLib: several bug fixes. Refactoring of gradient painting. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5456 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- components/mbColorLib/BColorPicker.pas | 284 +++--- components/mbColorLib/CColorPicker.pas | 311 +++---- components/mbColorLib/Demo/Demo.lpi | 7 - components/mbColorLib/Demo/main.lfm | 278 +++--- components/mbColorLib/GColorPicker.pas | 284 +++--- components/mbColorLib/HColorPicker.pas | 275 +++--- components/mbColorLib/HRingPicker.pas | 153 ++-- components/mbColorLib/HSColorPicker.pas | 43 +- components/mbColorLib/HSLColorPicker.pas | 148 ++- components/mbColorLib/HSLRingPicker.pas | 71 +- components/mbColorLib/HSVColorPicker.pas | 103 ++- components/mbColorLib/HexaColorPicker.pas | 83 +- components/mbColorLib/KColorPicker.pas | 313 +++---- components/mbColorLib/LColorPicker.pas | 281 +++--- components/mbColorLib/MColorPicker.pas | 307 ++++--- components/mbColorLib/RColorPicker.pas | 221 ++--- components/mbColorLib/RGBHSLUtils.pas | 50 +- components/mbColorLib/SColorPicker.pas | 218 ++--- components/mbColorLib/SLColorPicker.pas | 110 ++- components/mbColorLib/SLHColorPicker.pas | 176 ++-- components/mbColorLib/Scanlines.pas | 51 +- components/mbColorLib/VColorPicker.pas | 330 +++---- components/mbColorLib/YColorPicker.pas | 240 ++--- components/mbColorLib/mbBasicPicker.pas | 111 +++ components/mbColorLib/mbColorPalette.pas | 399 ++++---- .../mbColorLib/mbColorPickerControl.pas | 66 +- components/mbColorLib/mbColorTree.pas | 88 +- components/mbColorLib/mbTrackBarPicker.pas | 865 ++++++++++-------- components/mbColorLib/mbcolorliblaz.lpk | 6 +- 29 files changed, 3053 insertions(+), 2819 deletions(-) create mode 100644 components/mbColorLib/mbBasicPicker.pas diff --git a/components/mbColorLib/BColorPicker.pas b/components/mbColorLib/BColorPicker.pas index 85b1cac27..60eb30ad6 100644 --- a/components/mbColorLib/BColorPicker.pas +++ b/components/mbColorLib/BColorPicker.pas @@ -7,43 +7,42 @@ unit BColorPicker; interface uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Graphics, Forms, - mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + mbTrackBarPicker, HTMLColors; type - TBColorPicker = class(TmbTrackBarPicker) - private - FRed, FGreen, FBlue: integer; - FBmp: TBitmap; - function ArrowPosFromBlue(b: integer): integer; - function BlueFromArrowPos(p: integer): integer; - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - procedure CreateBGradient; - procedure SetRed(r: integer); - procedure SetGreen(g: integer); - procedure SetBlue(b: integer); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Red: integer read FRed write SetRed default 122; - property Green: integer read FGreen write SetGreen default 122; - property Blue: integer read FBlue write SetBlue default 255; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - property Layout default lyVertical; - end; + { TBColorPicker } + + TBColorPicker = class(TmbTrackBarPicker) + private + FRed, FGreen, FBlue: integer; + function ArrowPosFromBlue(b: integer): integer; + function BlueFromArrowPos(p: integer): integer; + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); + procedure SetRed(r: integer); + procedure SetGreen(g: integer); + procedure SetBlue(b: integer); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; + published + property Red: integer read FRed write SetRed default 122; + property Green: integer read FGreen write SetGreen default 122; + property Blue: integer read FBlue write SetBlue default 255; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + property Layout default lyVertical; + end; procedure Register; @@ -55,43 +54,34 @@ implementation procedure Register; begin - RegisterComponents('mbColor Lib', [TBColorPicker]); + RegisterComponents('mbColor Lib', [TBColorPicker]); end; {TBColorPicker} constructor TBColorPicker.Create(AOwner: TComponent); begin - inherited; - FBmp := TBitmap.Create; - FBmp.PixelFormat := pf32bit; - FBmp.SetSize(12, 256); - Width := 22; - Height := 268; - Layout := lyVertical; - FRed := 122; - FGreen := 122; - FBlue := 255; - FArrowPos := ArrowPosFromBlue(255); - FChange := false; - SetBlue(255); - HintFormat := 'Blue: %value'; - FManual := false; - FChange := true; -end; - -destructor TBColorPicker.Destroy; -begin - FBmp.Free; - inherited Destroy; -end; - -procedure TBColorPicker.CreateWnd; -begin - inherited; - CreateBGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + SetInitialBounds(0, 0, 22, 268); + { + Width := 22; + Height := 268; + } + Layout := lyVertical; + FRed := 122; + FGreen := 122; + FBlue := 255; + FArrowPos := ArrowPosFromBlue(255); + FChange := false; + SetBlue(255); + HintFormat := 'Blue: %value'; + FManual := false; + FChange := true; end; +(* procedure TBColorPicker.CreateBGradient; var i,j: integer; @@ -130,91 +120,93 @@ begin row[j] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, FGreen, 255-i))); end; end; +end; *) + +function TBColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := RGB(FRed, FGreen, AValue); end; procedure TBColorPicker.SetRed(r: integer); begin - if r < 0 then r := 0; - if r > 255 then r := 255; - if FRed <> r then + if r < 0 then r := 0; + if r > 255 then r := 255; + if FRed <> r then begin - FRed := r; - FManual := false; - CreateBGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FRed := r; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TBColorPicker.SetGreen(g: integer); begin - if g > 255 then g := 255; - if g < 0 then g := 0; - if FGreen <> g then + if g > 255 then g := 255; + if g < 0 then g := 0; + if FGreen <> g then begin - FGreen := g; - FManual := false; - CreateBGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FGreen := g; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TBColorPicker.SetBlue(b: integer); begin - if b > 255 then b := 255; - if b < 0 then b := 0; - if FBlue <> b then + if b > 255 then b := 255; + if b < 0 then b := 0; + if FBlue <> b then begin - FBlue := b; - FArrowPos := ArrowPosFromBlue(b); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FBlue := b; + FArrowPos := ArrowPosFromBlue(b); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TBColorPicker.ArrowPosFromBlue(b: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*b); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*b); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - b := 255 - b; - a := Round(((Height - 12)/255)*b); - if a > Height - FLimit then a := Height - FLimit; + b := 255 - b; + a := Round(((Height - 12)/255)*b); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TBColorPicker.BlueFromArrowPos(p: integer): integer; var - b: integer; + b: integer; begin - if Layout = lyHorizontal then - b := Round(p/((Width - 12)/255)) - else - b := Round(255 - p/((Height - 12)/255)); - if b < 0 then b := 0; - if b > 255 then b := 255; - Result := b; + if Layout = lyHorizontal then + b := Round(p/((Width - 12)/255)) + else + b := Round(255 - p/((Height - 12)/255)); + if b < 0 then b := 0; + if b > 255 then b := 255; + Result := b; end; function TBColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := RGB(FRed, FGreen, FBlue) - else - Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); + if not WebSafe then + Result := RGB(FRed, FGreen, FBlue) + else + Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); end; function TBColorPicker.GetSelectedValue: integer; @@ -224,41 +216,55 @@ end; procedure TBColorPicker.SetSelectedColor(c: TColor); begin - if WebSafe then c := GetWebSafe(c); - FChange := false; - SetRed(GetRValue(c)); - SetGreen(GetGValue(c)); - SetBlue(GetBValue(c)); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + FChange := false; + SetRed(GetRValue(c)); + SetGreen(GetGValue(c)); + SetBlue(GetBValue(c)); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TBColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromBlue(FBlue); + Result := ArrowPosFromBlue(FBlue); end; procedure TBColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetBlue(FBlue); - TBA_Paint: Canvas.StretchDraw(FPickRect, FBmp); - TBA_MouseMove: FBlue := BlueFromArrowPos(FArrowPos); - TBA_MouseDown: FBlue := BlueFromArrowPos(FArrowPos); - TBA_MouseUp: FBlue := BlueFromArrowPos(FArrowPos); - TBA_WheelUp: SetBlue(FBlue + Increment); - TBA_WheelDown: SetBlue(FBlue - Increment); - TBA_VKRight: SetBlue(FBlue + Increment); - TBA_VKCtrlRight: SetBlue(255); - TBA_VKLeft: SetBlue(FBlue - Increment); - TBA_VKCtrlLeft: SetBlue(0); - TBA_VKUp: SetBlue(FBlue + Increment); - TBA_VKCtrlUp: SetBlue(255); - TBA_VKDown: SetBlue(FBlue - Increment); - TBA_VKCtrlDown: SetBlue(0); - TBA_RedoBMP: CreateBGradient; - end; + case tbaAction of + TBA_Resize: + SetBlue(FBlue); + TBA_MouseMove: + FBlue := BlueFromArrowPos(FArrowPos); + TBA_MouseDown: + FBlue := BlueFromArrowPos(FArrowPos); + TBA_MouseUp: + FBlue := BlueFromArrowPos(FArrowPos); + TBA_WheelUp: + SetBlue(FBlue + Increment); + TBA_WheelDown: + SetBlue(FBlue - Increment); + TBA_VKRight: + SetBlue(FBlue + Increment); + TBA_VKCtrlRight: + SetBlue(255); + TBA_VKLeft: + SetBlue(FBlue - Increment); + TBA_VKCtrlLeft: + SetBlue(0); + TBA_VKUp: + SetBlue(FBlue + Increment); + TBA_VKCtrlUp: + SetBlue(255); + TBA_VKDown: + SetBlue(FBlue - Increment); + TBA_VKCtrlDown: + SetBlue(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/CColorPicker.pas b/components/mbColorLib/CColorPicker.pas index 058f8d2ce..e2f3ee03d 100644 --- a/components/mbColorLib/CColorPicker.pas +++ b/components/mbColorLib/CColorPicker.pas @@ -7,45 +7,41 @@ unit CColorPicker; interface uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Graphics, Forms, - RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBCMYKUtils, mbTrackBarPicker, HTMLColors; type - TCColorPicker = class(TmbTrackBarPicker) - private - FCyan, FMagenta, FYellow, FBlack: integer; - FCBmp: TBitmap; - - function ArrowPosFromCyan(c: integer): integer; - function CyanFromArrowPos(p: integer): integer; - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - procedure CreateCGradient; - procedure SetCyan(c: integer); - procedure SetMagenta(m: integer); - procedure SetYellow(y: integer); - procedure SetBlack(k: integer); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Cyan: integer read FCyan write SetCyan default 255; - property Magenta: integer read FMagenta write SetMagenta default 0; - property Yellow: integer read FYellow write SetYellow default 0; - property Black: integer read FBlack write SetBlack default 0; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - property Layout default lyVertical; - end; + TCColorPicker = class(TmbTrackBarPicker) + private + FCyan, FMagenta, FYellow, FBlack: integer; + function ArrowPosFromCyan(c: integer): integer; + function CyanFromArrowPos(p: integer): integer; + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); + procedure SetCyan(c: integer); + procedure SetMagenta(m: integer); + procedure SetYellow(y: integer); + procedure SetBlack(k: integer); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; + published + property Cyan: integer read FCyan write SetCyan default 255; + property Magenta: integer read FMagenta write SetMagenta default 0; + property Yellow: integer read FYellow write SetYellow default 0; + property Black: integer read FBlack write SetBlack default 0; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + property Layout default lyVertical; + end; procedure Register; @@ -57,44 +53,33 @@ implementation procedure Register; begin - RegisterComponents('mbColor Lib', [TCColorPicker]); + RegisterComponents('mbColor Lib', [TCColorPicker]); end; {TCColorPicker} constructor TCColorPicker.Create(AOwner: TComponent); begin - inherited; - FCBmp := TBitmap.Create; - FCBmp.PixelFormat := pf32bit; - FCBmp.SetSize(12, 255); - Width := 22; - Height := 267; - Layout := lyVertical; - FCyan := 255; - FMagenta := 0; - FYellow := 0; - FBlack := 0; - FArrowPos := ArrowPosFromCyan(255); - FChange := false; - SetCyan(255); - HintFormat := 'Cyan: %value'; - FManual := false; - FChange := true; -end; - -destructor TCColorPicker.Destroy; -begin - FCBmp.Free; - inherited Destroy; -end; - -procedure TCColorPicker.CreateWnd; -begin - inherited; - CreateCGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + SetInitialBounds(0, 0, 22, 267); + //Width := 22; + //Height := 267; + Layout := lyVertical; + FCyan := 255; + FMagenta := 0; + FYellow := 0; + FBlack := 0; + FArrowPos := ArrowPosFromCyan(255); + FChange := false; + SetCyan(255); + HintFormat := 'Cyan: %value'; + FManual := false; + FChange := true; end; +(* procedure TCColorPicker.CreateCGradient; var i,j: integer; @@ -134,105 +119,107 @@ begin end; end; end; +*) + +function TCColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := CMYKtoTColor(AValue, FMagenta, FYellow, FBlack); +end; procedure TCColorPicker.SetCyan(C: integer); begin - if C < 0 then C := 0; - if C > 255 then C := 255; - if FCyan <> c then + if C < 0 then C := 0; + if C > 255 then C := 255; + if FCyan <> c then begin - FCyan := c; - FArrowPos := ArrowPosFromCyan(c); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FCyan := c; + FArrowPos := ArrowPosFromCyan(c); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TCColorPicker.SetMagenta(m: integer); begin - if m > 255 then m := 255; - if m < 0 then m := 0; - if FMagenta <> m then + if m > 255 then m := 255; + if m < 0 then m := 0; + if FMagenta <> m then begin - FMagenta := m; - FManual := false; - CreateCGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FMagenta := m; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TCColorPicker.SetYellow(y: integer); begin - if y > 255 then y := 255; - if y < 0 then y := 0; - if FYellow <> y then + if y > 255 then y := 255; + if y < 0 then y := 0; + if FYellow <> y then begin - FYellow := y; - FManual := false; - CreateCGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FYellow := y; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TCColorPicker.SetBlack(k: integer); begin - if k > 255 then k := 255; - if k < 0 then k := 0; - if FBlack <> k then + if k > 255 then k := 255; + if k < 0 then k := 0; + if FBlack <> k then begin - FBlack := k; - FManual := false; - CreateCGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FBlack := k; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TCColorPicker.ArrowPosFromCyan(c: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*c); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*c); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - c := 255 - c; - a := Round(((Height - 12)/255)*c); - if a > Height - FLimit then a := Height - FLimit; + c := 255 - c; + a := Round(((Height - 12)/255)*c); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TCColorPicker.CyanFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/255)) - else - r := Round(255 - p/((Height - 12)/255)); - if r < 0 then r := 0; - if r > 255 then r := 255; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/255)) + else + r := Round(255 - p/((Height - 12)/255)); + if r < 0 then r := 0; + if r > 255 then r := 255; + Result := r; end; function TCColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) - else - Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); end; function TCColorPicker.GetSelectedValue: integer; @@ -242,45 +229,59 @@ end; procedure TCColorPicker.SetSelectedColor(c: TColor); var - cy, m, y, k: integer; + cy, m, y, k: integer; begin - if WebSafe then c := GetWebSafe(c); - ColorToCMYK(c, cy, m, y, k); - FChange := false; - SetMagenta(m); - SetYellow(y); - SetBlack(k); - SetCyan(cy); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + ColorToCMYK(c, cy, m, y, k); + FChange := false; + SetMagenta(m); + SetYellow(y); + SetBlack(k); + SetCyan(cy); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TCColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromCyan(FCyan); + Result := ArrowPosFromCyan(FCyan); end; procedure TCColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetCyan(FCyan); - TBA_Paint: Canvas.StretchDraw(FPickRect, FCBmp); - TBA_MouseMove: FCyan := CyanFromArrowPos(FArrowPos); - TBA_MouseDown: FCyan := CyanFromArrowPos(FArrowPos); - TBA_MouseUp: FCyan := CyanFromArrowPos(FArrowPos); - TBA_WheelUp: SetCyan(FCyan + Increment); - TBA_WheelDown: SetCyan(FCyan - Increment); - TBA_VKRight: SetCyan(FCyan + Increment); - TBA_VKCtrlRight: SetCyan(255); - TBA_VKLeft: SetCyan(FCyan - Increment); - TBA_VKCtrlLeft: SetCyan(0); - TBA_VKUp: SetCyan(FCyan + Increment); - TBA_VKCtrlUp: SetCyan(255); - TBA_VKDown: SetCyan(FCyan - Increment); - TBA_VKCtrlDown: SetCyan(0); - TBA_RedoBMP: CreateCGradient; - end; + case tbaAction of + TBA_Resize: + SetCyan(FCyan); + TBA_MouseMove: + FCyan := CyanFromArrowPos(FArrowPos); + TBA_MouseDown: + FCyan := CyanFromArrowPos(FArrowPos); + TBA_MouseUp: + FCyan := CyanFromArrowPos(FArrowPos); + TBA_WheelUp: + SetCyan(FCyan + Increment); + TBA_WheelDown: + SetCyan(FCyan - Increment); + TBA_VKRight: + SetCyan(FCyan + Increment); + TBA_VKCtrlRight: + SetCyan(255); + TBA_VKLeft: + SetCyan(FCyan - Increment); + TBA_VKCtrlLeft: + SetCyan(0); + TBA_VKUp: + SetCyan(FCyan + Increment); + TBA_VKCtrlUp: + SetCyan(255); + TBA_VKDown: + SetCyan(FCyan - Increment); + TBA_VKCtrlDown: + SetCyan(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/Demo/Demo.lpi b/components/mbColorLib/Demo/Demo.lpi index 33e1ffed0..8e3c1ed01 100644 --- a/components/mbColorLib/Demo/Demo.lpi +++ b/components/mbColorLib/Demo/Demo.lpi @@ -58,13 +58,6 @@ - - - - - - - diff --git a/components/mbColorLib/Demo/main.lfm b/components/mbColorLib/Demo/main.lfm index 7f51e68fe..005579781 100644 --- a/components/mbColorLib/Demo/main.lfm +++ b/components/mbColorLib/Demo/main.lfm @@ -1,64 +1,61 @@ object Form1: TForm1 - Left = 222 - Height = 338 - Top = 89 - Width = 541 + Left = 255 + Height = 344 + Top = 107 + Width = 543 Caption = 'mbColor Lib v2.0.1 Demo' - ClientHeight = 338 - ClientWidth = 541 - Color = clBtnFace + ClientHeight = 344 + ClientWidth = 543 Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Shell Dlg 2' OnCreate = FormCreate ShowHint = True LCLVersion = '1.7' object Label1: TLabel Left = 412 - Height = 13 + Height = 15 Top = 8 - Width = 66 + Width = 73 Anchors = [akTop, akRight] Caption = 'SelectedColor' ParentColor = False end object Label2: TLabel - Left = 410 - Height = 13 + Left = 412 + Height = 15 Top = 112 - Width = 86 + Width = 96 Anchors = [akTop, akRight] Caption = 'ColorUnderCursor' ParentColor = False end object Label5: TLabel - Left = 410 - Height = 65 + Left = 412 + Height = 75 Top = 238 - Width = 92 + Width = 99 Anchors = [akTop, akRight] Caption = 'Aditional controls:'#13#13'- Arrow keys'#13'- Ctrl + Arrow keys'#13'- Mouse wheel' ParentColor = False end object PageControl1: TPageControl Left = 6 - Height = 325 + Height = 331 Top = 6 - Width = 397 - ActivePage = TabSheet8 + Width = 399 + ActivePage = TabSheet11 Anchors = [akTop, akLeft, akRight, akBottom] - TabIndex = 8 + TabIndex = 6 TabOrder = 0 object TabSheet1: TTabSheet Caption = 'HSLColorPicker' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 303 + ClientWidth = 391 object HSLColorPicker1: THSLColorPicker Left = 8 - Height = 283 + Height = 287 Top = 8 - Width = 375 - SelectedColor = 639239 + Width = 377 + SelectedColor = 562183 HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex' LPickerHintFormat = 'Luminance: %l' Anchors = [akTop, akLeft, akRight, akBottom] @@ -69,23 +66,24 @@ object Form1: TForm1 end object TabSheet2: TTabSheet Caption = 'HexaColorPicker' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 303 + ClientWidth = 391 ImageIndex = 1 object Label4: TLabel - Left = 82 - Height = 13 - Top = 278 - Width = 37 - Anchors = [akLeft, akBottom] + AnchorSideTop.Control = ComboBox1 + AnchorSideTop.Side = asrCenter + Left = 112 + Height = 15 + Top = 282 + Width = 40 Caption = 'Marker:' ParentColor = False end object HexaColorPicker1: THexaColorPicker Left = 48 - Height = 267 + Height = 271 Top = 4 - Width = 283 + Width = 285 Anchors = [akTop, akLeft, akRight, akBottom] HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' IntensityText = 'Intensity' @@ -96,11 +94,12 @@ object Form1: TForm1 OnMouseMove = HexaColorPicker1MouseMove end object CheckBox1: TCheckBox + AnchorSideTop.Control = ComboBox1 + AnchorSideTop.Side = asrCenter Left = 4 - Height = 17 - Top = 274 - Width = 75 - Anchors = [akLeft, akBottom] + Height = 19 + Top = 280 + Width = 83 Caption = 'SliderVisible' Checked = True OnClick = CheckBox1Click @@ -108,12 +107,12 @@ object Form1: TForm1 TabOrder = 1 end object ComboBox1: TComboBox - Left = 124 - Height = 21 - Top = 274 + Left = 160 + Height = 23 + Top = 278 Width = 71 Anchors = [akLeft, akBottom] - ItemHeight = 13 + ItemHeight = 15 ItemIndex = 0 Items.Strings = ( 'smArrow' @@ -125,11 +124,13 @@ object Form1: TForm1 Text = 'smArrow' end object CheckBox2: TCheckBox - Left = 200 - Height = 17 - Top = 276 - Width = 97 - Anchors = [akLeft, akBottom] + AnchorSideTop.Control = ComboBox1 + AnchorSideTop.Side = asrCenter + Left = 256 + Height = 20 + Top = 279 + Width = 101 + Anchors = [akTop, akLeft, akBottom] Caption = 'NewArrowStyle' OnClick = CheckBox2Click TabOrder = 3 @@ -137,40 +138,43 @@ object Form1: TForm1 end object TabSheet3: TTabSheet Caption = 'mbColorPalette' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 303 + ClientWidth = 391 ImageIndex = 2 object Label3: TLabel + AnchorSideTop.Control = ComboBox2 + AnchorSideTop.Side = asrCenter Left = 6 - Height = 13 + Height = 15 Top = 272 Width = 24 - Anchors = [akLeft, akBottom] Caption = 'Sort:' ParentColor = False end object Label6: TLabel - Left = 214 - Height = 13 + AnchorSideTop.Control = ComboBox4 + AnchorSideTop.Side = asrCenter + Left = 224 + Height = 15 Top = 272 Width = 28 - Anchors = [akLeft, akBottom] Caption = 'Style:' ParentColor = False end object Label7: TLabel - Left = 320 - Height = 13 + AnchorSideTop.Control = UpDown1 + AnchorSideTop.Side = asrCenter + Left = 336 + Height = 15 Top = 272 Width = 23 - Anchors = [akLeft, akBottom] Caption = 'Size:' ParentColor = False end object Button1: TButton Left = 6 Height = 25 - Top = 232 + Top = 236 Width = 107 Anchors = [akLeft, akBottom] Caption = 'Generate blue pal' @@ -180,7 +184,7 @@ object Form1: TForm1 object Button2: TButton Left = 120 Height = 25 - Top = 232 + Top = 236 Width = 135 Anchors = [akLeft, akBottom] Caption = 'Generate gradient pal' @@ -190,7 +194,7 @@ object Form1: TForm1 object Button4: TButton Left = 262 Height = 25 - Top = 232 + Top = 236 Width = 121 Anchors = [akLeft, akBottom] Caption = 'Load palette from file' @@ -199,15 +203,15 @@ object Form1: TForm1 end object ScrollBox1: TScrollBox Left = 6 - Height = 217 + Height = 221 Top = 8 - Width = 379 + Width = 381 HorzScrollBar.Page = 75 - VertScrollBar.Page = 217 + VertScrollBar.Page = 221 Anchors = [akTop, akLeft, akRight, akBottom] BorderStyle = bsNone - ClientHeight = 217 - ClientWidth = 362 + ClientHeight = 221 + ClientWidth = 364 TabOrder = 3 object mbColorPalette1: TmbColorPalette Left = 0 @@ -482,11 +486,11 @@ object Form1: TForm1 end object ComboBox2: TComboBox Left = 34 - Height = 21 - Top = 266 + Height = 23 + Top = 268 Width = 87 Anchors = [akLeft, akBottom] - ItemHeight = 13 + ItemHeight = 15 ItemIndex = 0 Items.Strings = ( 'soAscending' @@ -499,11 +503,11 @@ object Form1: TForm1 end object ComboBox3: TComboBox Left = 124 - Height = 21 - Top = 266 + Height = 23 + Top = 268 Width = 87 Anchors = [akLeft, akBottom] - ItemHeight = 13 + ItemHeight = 15 ItemIndex = 7 Items.Strings = ( 'smRed' @@ -531,12 +535,12 @@ object Form1: TForm1 Text = 'smNone' end object ComboBox4: TComboBox - Left = 244 - Height = 21 - Top = 266 + Left = 256 + Height = 23 + Top = 268 Width = 71 Anchors = [akLeft, akBottom] - ItemHeight = 13 + ItemHeight = 15 ItemIndex = 0 Items.Strings = ( 'csDefault' @@ -548,10 +552,10 @@ object Form1: TForm1 Text = 'csDefault' end object UpDown1: TUpDown - Left = 348 - Height = 21 - Top = 266 - Width = 31 + Left = 364 + Height = 23 + Top = 268 + Width = 15 Anchors = [akLeft, akBottom] Min = 0 OnChanging = UpDown1Changing @@ -563,14 +567,14 @@ object Form1: TForm1 end object TabSheet4: TTabSheet Caption = 'HSLRingPicker' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 303 + ClientWidth = 391 ImageIndex = 3 object HSLRingPicker1: THSLRingPicker Left = 50 - Height = 285 + Height = 289 Top = 6 - Width = 291 + Width = 293 RingPickerHintFormat = 'Hue: %h' SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex' Anchors = [akTop, akLeft, akRight, akBottom] @@ -581,8 +585,8 @@ object Form1: TForm1 end object TabSheet5: TTabSheet Caption = 'HSVColorPicker' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 299 + ClientWidth = 389 ImageIndex = 4 object HSVColorPicker1: THSVColorPicker Left = 24 @@ -610,11 +614,11 @@ object Form1: TForm1 end object TabSheet6: TTabSheet Caption = 'SLHColorPicker' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 299 + ClientWidth = 389 ImageIndex = 5 object SLHColorPicker1: TSLHColorPicker - Left = 6 + Left = 5 Height = 287 Top = 6 Width = 379 @@ -628,8 +632,8 @@ object Form1: TForm1 end object TabSheet11: TTabSheet Caption = 'Lists && Trees' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 303 + ClientWidth = 391 ImageIndex = 10 object mbColorList1: TmbColorList Left = 192 @@ -661,14 +665,14 @@ object Form1: TForm1 end object TabSheet7: TTabSheet Caption = 'More' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 303 + ClientWidth = 391 ImageIndex = 6 object Label9: TLabel - Left = 118 - Height = 13 + Left = 128 + Height = 15 Top = 8 - Width = 103 + Width = 113 Caption = 'HintFormat variables:' ParentColor = False end @@ -676,7 +680,7 @@ object Form1: TForm1 Left = 8 Height = 25 Top = 8 - Width = 93 + Width = 104 Caption = 'Pick from screen' TabOrder = 0 OnSelColorChange = mbDeskPickerButton1SelColorChange @@ -686,19 +690,20 @@ object Form1: TForm1 Left = 8 Height = 25 Top = 40 - Width = 93 + Width = 104 Caption = 'OfficeColorDialog' OnClick = Button3Click TabOrder = 1 end object LColorPicker1: TLColorPicker - Left = 36 + Left = 34 Height = 25 - Top = 148 - Width = 329 + Top = 192 + Width = 343 HintFormat = 'Luminance: %l' Layout = lyHorizontal SelectionIndicator = siRect + Anchors = [akLeft, akRight, akBottom] TabOrder = 2 Saturation = 238 Luminance = 60 @@ -707,13 +712,14 @@ object Form1: TForm1 object VColorPicker1: TVColorPicker Left = 34 Height = 21 - Top = 116 - Width = 335 + Top = 160 + Width = 343 HintFormat = 'Value: %v' Layout = lyHorizontal ArrowPlacement = spBefore NewArrowStyle = True SelectionIndicator = siRect + Anchors = [akLeft, akRight, akBottom] TabOrder = 3 Hue = 240 Saturation = 255 @@ -721,21 +727,22 @@ object Form1: TForm1 SelectedColor = 2621440 end object HColorPicker1: THColorPicker - Left = 36 + Left = 34 Height = 61 - Top = 178 - Width = 335 + Top = 231 + Width = 343 HintFormat = 'Hue: %h' Increment = 5 ArrowPlacement = spBoth SelectionIndicator = siRect + Anchors = [akLeft, akRight, akBottom] TabOrder = 4 Saturation = 120 SelectedColor = 8882175 end object SColorPicker1: TSColorPicker Left = 8 - Height = 214 + Height = 222 Top = 70 Width = 19 HintFormat = 'Saturation: %s' @@ -743,19 +750,20 @@ object Form1: TForm1 ArrowPlacement = spBefore NewArrowStyle = True SelectionIndicator = siRect + Anchors = [akTop, akLeft, akBottom] TabOrder = 5 Hue = 60 Saturation = 80 SelectedColor = 11534335 end object Memo1: TMemo - Left = 118 - Height = 75 - Top = 24 - Width = 247 + Left = 128 + Height = 118 + Top = 26 + Width = 249 + Anchors = [akTop, akLeft, akRight, akBottom] Lines.Strings = ( - 'The following variables will be replaced in the ' - 'hint at runtime:' + 'The following variables will be replaced in the hint at runtime:' '' '%hex = HTML HEX color value' '' @@ -797,8 +805,8 @@ object Form1: TForm1 end object TabSheet8: TTabSheet Caption = 'Other' - ClientHeight = 299 - ClientWidth = 389 + ClientHeight = 292 + ClientWidth = 372 ImageIndex = 7 object HSColorPicker1: THSColorPicker Left = 6 @@ -837,14 +845,14 @@ object Form1: TForm1 end object TabSheet9: TTabSheet Caption = 'Even more' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 292 + ClientWidth = 372 ImageIndex = 8 object Label8: TLabel Left = 6 - Height = 13 + Height = 15 Top = 4 - Width = 128 + Width = 136 Caption = 'New: border styles added.' ParentColor = False end @@ -870,7 +878,7 @@ object Form1: TForm1 object YColorPicker1: TYColorPicker Left = 68 Height = 267 - Top = 18 + Top = 19 Width = 31 HintFormat = 'Yellow: %y' ArrowPlacement = spBoth @@ -983,8 +991,8 @@ object Form1: TForm1 end object TabSheet10: TTabSheet Caption = 'Yet even more' - ClientHeight = 0 - ClientWidth = 0 + ClientHeight = 299 + ClientWidth = 389 ImageIndex = 9 object RAxisColorPicker1: TRAxisColorPicker Left = 10 @@ -1052,15 +1060,15 @@ object Form1: TForm1 end end object sc: TmbColorPreview - Left = 410 + Left = 412 Height = 62 - Top = 24 + Top = 25 Width = 108 Color = clNone Anchors = [akTop, akRight] end object uc: TmbColorPreview - Left = 410 + Left = 412 Height = 62 Top = 130 Width = 108 @@ -1068,7 +1076,7 @@ object Form1: TForm1 Anchors = [akTop, akRight] end object tb1: TTrackBar - Left = 410 + Left = 412 Height = 20 Hint = 'Opacity' Top = 90 @@ -1081,7 +1089,7 @@ object Form1: TForm1 TabOrder = 3 end object tb2: TTrackBar - Left = 410 + Left = 412 Height = 20 Top = 196 Width = 108 @@ -1093,20 +1101,20 @@ object Form1: TForm1 TabOrder = 4 end object CheckBox3: TCheckBox - Left = 443 + Left = 412 Height = 19 - Top = 308 - Width = 64 + Top = 320 + Width = 66 Anchors = [akTop, akRight] Caption = 'WebSafe' OnClick = CheckBox3Click TabOrder = 5 end object CheckBox4: TCheckBox - Left = 428 + Left = 412 Height = 19 Top = 218 - Width = 79 + Width = 83 Anchors = [akTop, akRight] Caption = 'SwatchStyle' OnClick = CheckBox4Click @@ -1114,12 +1122,12 @@ object Form1: TForm1 end object mbOfficeColorDialog1: TmbOfficeColorDialog UseHints = True - left = 472 - top = 302 + left = 448 + top = 136 end object OpenDialog1: TOpenDialog Filter = 'JASC PAL (*.pal)|*.pal|Photoshop (*.act; *.aco)|*.act;*.aco' left = 440 - top = 304 + top = 40 end end diff --git a/components/mbColorLib/GColorPicker.pas b/components/mbColorLib/GColorPicker.pas index ec410051f..e0c5be965 100644 --- a/components/mbColorLib/GColorPicker.pas +++ b/components/mbColorLib/GColorPicker.pas @@ -5,91 +5,76 @@ unit GColorPicker; interface uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Graphics, Forms, - mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + mbTrackBarPicker, HTMLColors; type - TGColorPicker = class(TmbTrackBarPicker) - private - FRed, FGreen, FBlue: integer; - FBmp: TBitmap; - - function ArrowPosFromGreen(g: integer): integer; - function GreenFromArrowPos(p: integer): integer; - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - procedure CreateGGradient; - procedure SetRed(r: integer); - procedure SetGreen(g: integer); - procedure SetBlue(b: integer); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Red: integer read FRed write SetRed default 122; - property Green: integer read FGreen write SetGreen default 255; - property Blue: integer read FBlue write SetBlue default 122; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - property Layout default lyVertical; - end; + TGColorPicker = class(TmbTrackBarPicker) + private + FRed, FGreen, FBlue: integer; + function ArrowPosFromGreen(g: integer): integer; + function GreenFromArrowPos(p: integer): integer; + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); + procedure SetRed(r: integer); + procedure SetGreen(g: integer); + procedure SetBlue(b: integer); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; + published + property Red: integer read FRed write SetRed default 122; + property Green: integer read FGreen write SetGreen default 255; + property Blue: integer read FBlue write SetBlue default 122; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + property Layout default lyVertical; + end; procedure Register; implementation {$IFDEF FPC} -{$R GColorPicker.dcr} + {$R GColorPicker.dcr} {$ENDIF} procedure Register; begin - RegisterComponents('mbColor Lib', [TGColorPicker]); + RegisterComponents('mbColor Lib', [TGColorPicker]); end; {TGColorPicker} constructor TGColorPicker.Create(AOwner: TComponent); begin - inherited; - FBmp := TBitmap.Create; - FBmp.PixelFormat := pf32bit; - FBmp.SetSize(12, 256); - Width := 22; - Height := 268; - Layout := lyVertical; - FRed := 122; - FGreen := 255; - FBlue := 122; - FArrowPos := ArrowPosFromGreen(255); - FChange := false; - SetGreen(255); - HintFormat := 'Green: %value'; - FManual := false; - FChange := true; -end; - -destructor TGColorPicker.Destroy; -begin - FBmp.Free; - inherited Destroy; -end; - -procedure TGColorPicker.CreateWnd; -begin - inherited; - CreateGGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + SetInitialBounds(0, 0, 22, 268); + //Width := 22; + //Height := 268; + Layout := lyVertical; + FRed := 122; + FGreen := 255; + FBlue := 122; + FArrowPos := ArrowPosFromGreen(255); + FChange := false; + SetGreen(255); + HintFormat := 'Green: %value'; + FManual := false; + FChange := true; end; +(* procedure TGColorPicker.CreateGGradient; var i,j: integer; @@ -131,90 +116,93 @@ begin end; end; end; +*) + +function TGColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := RGB(FRed, AValue, FBlue); +end; procedure TGColorPicker.SetRed(r: integer); begin - if r < 0 then r := 0; - if r > 255 then r := 255; - if FRed <> r then + if r < 0 then r := 0; + if r > 255 then r := 255; + if FRed <> r then begin - FRed := r; - FManual := false; - CreateGGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FRed := r; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TGColorPicker.SetGreen(g: integer); begin - if g > 255 then g := 255; - if g < 0 then g := 0; - if FGreen <> g then + if g > 255 then g := 255; + if g < 0 then g := 0; + if FGreen <> g then begin - FGreen := g; - FArrowPos := ArrowPosFromGreen(g); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FGreen := g; + FArrowPos := ArrowPosFromGreen(g); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TGColorPicker.SetBlue(b: integer); begin - if b > 255 then b := 255; - if b < 0 then b := 0; - if FBlue <> b then + if b > 255 then b := 255; + if b < 0 then b := 0; + if FBlue <> b then begin - FBlue := b; - FManual := false; - CreateGGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FBlue := b; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TGColorPicker.ArrowPosFromGreen(g: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*g); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*g); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - g := 255 - g; - a := Round(((Height - 12)/255)*g); - if a > Height - FLimit then a := Height - FLimit; + g := 255 - g; + a := Round(((Height - 12)/255)*g); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TGColorPicker.GreenFromArrowPos(p: integer): integer; var - g: integer; + g: integer; begin - if Layout = lyHorizontal then - g := Round(p/((Width - 12)/255)) - else - g := Round(255 - p/((Height - 12)/255)); - if g < 0 then g := 0; - if g > 255 then g := 255; - Result := g; + if Layout = lyHorizontal then + g := Round(p/((Width - 12)/255)) + else + g := Round(255 - p/((Height - 12)/255)); + if g < 0 then g := 0; + if g > 255 then g := 255; + Result := g; end; function TGColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := RGB(FRed, FGreen, FBlue) - else - Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); + if not WebSafe then + Result := RGB(FRed, FGreen, FBlue) + else + Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); end; function TGColorPicker.GetSelectedValue: integer; @@ -224,41 +212,55 @@ end; procedure TGColorPicker.SetSelectedColor(c: TColor); begin - if WebSafe then c := GetWebSafe(c); - FChange := false; - SetRed(GetRValue(c)); - SetBlue(GetBValue(c)); - SetGreen(GetGValue(c)); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + FChange := false; + SetRed(GetRValue(c)); + SetBlue(GetBValue(c)); + SetGreen(GetGValue(c)); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TGColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromGreen(FGreen); + Result := ArrowPosFromGreen(FGreen); end; procedure TGColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetGreen(FGreen); - TBA_Paint: Canvas.StretchDraw(FPickRect, FBmp); - TBA_MouseMove: FGreen := GreenFromArrowPos(FArrowPos); - TBA_MouseDown: FGreen := GreenFromArrowPos(FArrowPos); - TBA_MouseUp: FGreen := GreenFromArrowPos(FArrowPos); - TBA_WheelUp: SetGreen(FGreen + Increment); - TBA_WheelDown: SetGreen(FGreen - Increment); - TBA_VKRight: SetGreen(FGreen + Increment); - TBA_VKCtrlRight: SetGreen(255); - TBA_VKLeft: SetGreen(FGreen - Increment); - TBA_VKCtrlLeft: SetGreen(0); - TBA_VKUp: SetGreen(FGreen + Increment); - TBA_VKCtrlUp: SetGreen(255); - TBA_VKDown: SetGreen(FGreen - Increment); - TBA_VKCtrlDown: SetGreen(0); - TBA_RedoBMP: CreateGGradient; - end; + case tbaAction of + TBA_Resize: + SetGreen(FGreen); + TBA_MouseMove: + FGreen := GreenFromArrowPos(FArrowPos); + TBA_MouseDown: + FGreen := GreenFromArrowPos(FArrowPos); + TBA_MouseUp: + FGreen := GreenFromArrowPos(FArrowPos); + TBA_WheelUp: + SetGreen(FGreen + Increment); + TBA_WheelDown: + SetGreen(FGreen - Increment); + TBA_VKRight: + SetGreen(FGreen + Increment); + TBA_VKCtrlRight: + SetGreen(255); + TBA_VKLeft: + SetGreen(FGreen - Increment); + TBA_VKCtrlLeft: + SetGreen(0); + TBA_VKUp: + SetGreen(FGreen + Increment); + TBA_VKCtrlUp: + SetGreen(255); + TBA_VKDown: + SetGreen(FGreen - Increment); + TBA_VKCtrlDown: + SetGreen(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/HColorPicker.pas b/components/mbColorLib/HColorPicker.pas index 4abcc1278..7a58c110d 100644 --- a/components/mbColorLib/HColorPicker.pas +++ b/components/mbColorLib/HColorPicker.pas @@ -7,42 +7,38 @@ unit HColorPicker; interface uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Graphics, Forms, - RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBHSVUtils, mbTrackBarPicker, HTMLColors; type - THColorPicker = class(TmbTrackBarPicker) - private - FVal, FSat, FHue: integer; - FHBmp: TBitmap; - - function ArrowPosFromHue(h: integer): integer; - function HueFromArrowPos(p: integer): integer; - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - procedure CreateHGradient; - procedure SetHue(h: integer); - procedure SetSat(s: integer); - procedure SetValue(v: integer); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Hue: integer read FHue write SetHue default 0; - property Saturation: integer read FSat write SetSat default 255; - property Value: integer read FVal write SetValue default 255; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - end; + THColorPicker = class(TmbTrackBarPicker) + private + FVal, FSat, FHue: integer; + function ArrowPosFromHue(h: integer): integer; + function HueFromArrowPos(p: integer): integer; + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); + procedure SetHue(h: integer); + procedure SetSat(s: integer); + procedure SetValue(v: integer); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; + published + property Hue: integer read FHue write SetHue default 0; + property Saturation: integer read FSat write SetSat default 255; + property Value: integer read FVal write SetValue default 255; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + end; procedure Register; @@ -54,40 +50,30 @@ implementation procedure Register; begin - RegisterComponents('mbColor Lib', [THColorPicker]); + RegisterComponents('mbColor Lib', [THColorPicker]); end; {THColorPicker} constructor THColorPicker.Create(AOwner: TComponent); begin - inherited; - FHBmp := TBitmap.Create; - FHBmp.PixelFormat := pf32bit; - Width := 267; - Height := 22; - FSat := 255; - FVal := 255; - FArrowPos := ArrowPosFromHue(0); - FChange := false; - SetHue(0); - HintFormat := 'Hue: %value'; - FManual := false; - FChange := true; -end; - -destructor THColorPicker.Destroy; -begin - FHBmp.Free; - inherited Destroy; -end; - -procedure THColorPicker.CreateWnd; -begin - inherited; - CreateHGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + SetInitialBounds(0, 0, 267, 22); + //Width := 267; + //Height := 22; + FSat := 255; + FVal := 255; + FArrowPos := ArrowPosFromHue(0); + FChange := false; + SetHue(0); + HintFormat := 'Hue: %value'; + FManual := false; + FChange := true; end; +(* procedure THColorPicker.CreateHGradient; var i,j: integer; @@ -129,89 +115,92 @@ begin end; end; end; +*) + +function THColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := HSVtoColor(AValue, FSat, FVal); +end; procedure THColorPicker.SetValue(v: integer); begin - if v < 0 then v := 0; - if v > 255 then v := 255; - if FVal <> v then + if v < 0 then v := 0; + if v > 255 then v := 255; + if FVal <> v then begin - FVal := v; - FManual := false; - CreateHGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FVal := v; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure THColorPicker.SetHue(h: integer); begin - if h > 360 then h := 360; - if h < 0 then h := 0; - if FHue <> h then + if h > 360 then h := 360; + if h < 0 then h := 0; + if FHue <> h then begin - FHue := h; - FArrowPos := ArrowPosFromHue(h); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FHue := h; + FArrowPos := ArrowPosFromHue(h); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure THColorPicker.SetSat(s: integer); begin - if s > 255 then s := 255; - if s < 0 then s := 0; - if FSat <> s then + if s > 255 then s := 255; + if s < 0 then s := 0; + if FSat <> s then begin - FSat := s; - FManual := false; - CreateHGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FSat := s; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function THColorPicker.ArrowPosFromHue(h: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/360)*h); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/360)*h); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - a := Round(((Height - 12)/360)*h); - if a > Height - FLimit then a := Height - FLimit; + a := Round(((Height - 12)/360)*h); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function THColorPicker.HueFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/360)) - else - r := Round(p/((Height - 12)/360)); - if r < 0 then r := 0; - if r > 360 then r := 360; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/360)) + else + r := Round(p/((Height - 12)/360)); + if r < 0 then r := 0; + if r > 360 then r := 360; + Result := r; end; function THColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := HSVtoColor(FHue, FSat, FVal) - else - Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FVal) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); end; function THColorPicker.GetSelectedValue: integer; @@ -221,43 +210,57 @@ end; procedure THColorPicker.SetSelectedColor(c: TColor); var - h, s, v: integer; + h, s, v: integer; begin - if WebSafe then c := GetWebSafe(c); - RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); - FChange := false; - SetHue(h); - SetSat(s); - SetValue(v); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); + FChange := false; + SetHue(h); + SetSat(s); + SetValue(v); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function THColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromHue(FHue); + Result := ArrowPosFromHue(FHue); end; procedure THColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetHue(FHue); - TBA_Paint: Canvas.StretchDraw(FPickRect, FHBmp); - TBA_MouseMove: FHue := HueFromArrowPos(FArrowPos); - TBA_MouseDown: FHue := HueFromArrowPos(FArrowPos); - TBA_MouseUp: FHue := HueFromArrowPos(FArrowPos); - TBA_WheelUp: SetHue(FHue + Increment); - TBA_WheelDown: SetHue(FHue - Increment); - TBA_VKLeft: SetHue(FHue - Increment); - TBA_VKCtrlLeft: SetHue(0); - TBA_VKRight: SetHue(FHue + Increment); - TBA_VKCtrlRight: SetHue(360); - TBA_VKUp: SetHue(FHue - Increment); - TBA_VKCtrlUp: SetHue(0); - TBA_VKDown: SetHue(FHue + Increment); - TBA_VKCtrlDown: SetHue(360); - TBA_RedoBMP: CreateHGradient; + case tbaAction of + TBA_Resize: + SetHue(FHue); + TBA_MouseMove: + FHue := HueFromArrowPos(FArrowPos); + TBA_MouseDown: + FHue := HueFromArrowPos(FArrowPos); + TBA_MouseUp: + FHue := HueFromArrowPos(FArrowPos); + TBA_WheelUp: + SetHue(FHue + Increment); + TBA_WheelDown: + SetHue(FHue - Increment); + TBA_VKLeft: + SetHue(FHue - Increment); + TBA_VKCtrlLeft: + SetHue(0); + TBA_VKRight: + SetHue(FHue + Increment); + TBA_VKCtrlRight: + SetHue(360); + TBA_VKUp: + SetHue(FHue - Increment); + TBA_VKCtrlUp: + SetHue(0); + TBA_VKDown: + SetHue(FHue + Increment); + TBA_VKCtrlDown: + SetHue(360); + else + inherited; end; end; diff --git a/components/mbColorLib/HRingPicker.pas b/components/mbColorLib/HRingPicker.pas index 2d5ccf126..6d923f713 100644 --- a/components/mbColorLib/HRingPicker.pas +++ b/components/mbColorLib/HRingPicker.pas @@ -75,6 +75,9 @@ implementation {$IFDEF FPC} {$R HRingPicker.dcr} + +uses + IntfGraphics, fpimage; {$ENDIF} procedure Register; @@ -116,49 +119,76 @@ end; procedure THRingPicker.CreateHSVCircle; var - dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; - row: pRGBQuadArray; - tc: TColor; + dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; + row: pRGBQuadArray; + c: TColor; + {$IFDEF FPC} + intfimg: TLazIntfImage; + imgHandle, imgMaskHandle: HBitmap; + {$ENDIF} begin - if FBMP = nil then - begin - FBMP := TBitmap.Create; - FBMP.PixelFormat := pf32bit; - end; - size := Min(Width, Height); - FBMP.Width := size; - FBMP.Height := size; - Radius := size div 2; - RadiusSquared := Radius*Radius; - PaintParentBack(FBMP.Canvas); - V := FValue; - for j := 0 to size - 1 do + if FBmp = nil then begin - Y := Size - 1 - j - Radius; - row := FBMP.Scanline[Size - 1 - j]; - for i := 0 to size - 1 do - begin - X := i - Radius; - dSquared := X*X + Y*Y; - if dSquared <= RadiusSquared then - begin - if Radius <> 0 then - S := ROUND((255*SQRT(dSquared))/Radius) - else - S := 0; - H := ROUND( 180 * (1 + ArcTan2(X, Y) / PI)); - H := H + 90; - if H > 360 then H := H - 360; - if not WebSafe then - row[i] := HSVtoRGBQuad(H,S,V) - else - begin - tc := GetWebSafe(HSVtoColor(H, S, V)); - row[i] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc)); - end; - end - end; + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; end; + + size := Min(Width, Height); + FBmp.Width := size; + FBmp.Height := size; + PaintParentBack(FBmp); + + radius := size div 2; + radiusSquared := radius * radius; + V := FValue; + +{$IFDEF FPC} + intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height); + try + intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle); +{$ENDIF} + + for j := 0 to size - 1 do + begin + Y := Size - 1 - j - radius; + + {$IFDEF FPC} + row := intfImg.GetDataLineStart(size - 1 - j); + {$ELSE} + row := FBmp.Scanline(size - 1 - j); + {$ENDIF} + + for i := 0 to size - 1 do + begin + X := i - radius; + dSquared := X*X + Y*Y; + if dSquared <= radiusSquared then + begin + if Radius <> 0 then + S := round((255 * sqrt(dSquared)) / radius) + else + S := 0; + H := round( 180 * (1 + arctan2(X, Y) / PI)); // wp: order (x,y) is correct! + H := H + 90; + if H > 360 then H := H - 360; + if not WebSafe then + row[i] := HSVtoRGBQuad(H,S,V) + else + begin + c := GetWebSafe(HSVtoColor(H, S, V)); + row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c)); + end; + end + end; + end; +{$IFDEF FPC} + intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false); + FBmp.Handle := imgHandle; + FBmp.MaskHandle := imgMaskHandle; + finally + intfimg.Free; + end; +{$ENDIF} end; procedure THRingPicker.Resize; @@ -267,26 +297,33 @@ end; procedure THRingPicker.Paint; var - rgn, r1, r2: HRGN; - r: TRect; + rgn, r1, r2: HRGN; + r: TRect; + size: Integer; + ringwidth: Integer; begin - PaintParentBack(Canvas); - r := ClientRect; - r.Right := R.Left + Min(Width, Height); - R.Bottom := R.Top + Min(Width, Height); - r1 := CreateEllipticRgnIndirect(R); - rgn := r1; - InflateRect(R, - Min(Width, Height) + FRadius, - Min(Width, Height) + FRadius); - r2 := CreateEllipticRgnIndirect(R); - CombineRgn(rgn, r1, r2, RGN_DIFF); - SelectClipRgn(Canvas.Handle, rgn); - Canvas.Draw(0, 0, FBMP); - DeleteObject(rgn); - DrawHueLine; - if FDoChange then + PaintParentBack(Canvas); + size := Min(Width, Height); // diameter of circle + ringwidth := size div 2 - FRadius; // FRadius is inner radius + r := ClientRect; + r.Right := R.Left + size; + R.Bottom := R.Top + size; + r1 := CreateEllipticRgnIndirect(R); + if ringwidth > 0 then begin - if Assigned(FOnChange) then FOnChange(Self); - FDoChange := false; + rgn := r1; + InflateRect(R, -ringwidth, - ringwidth); + r2 := CreateEllipticRgnIndirect(R); + CombineRgn(rgn, r1, r2, RGN_DIFF); + end; + SelectClipRgn(Canvas.Handle, rgn); + Canvas.Draw(0, 0, FBmp); + DeleteObject(rgn); + DrawHueLine; + if FDoChange then + begin + if Assigned(FOnChange) then FOnChange(Self); + FDoChange := false; end; end; diff --git a/components/mbColorLib/HSColorPicker.pas b/components/mbColorLib/HSColorPicker.pas index 9f64d6f60..15ad7de3b 100644 --- a/components/mbColorLib/HSColorPicker.pas +++ b/components/mbColorLib/HSColorPicker.pas @@ -10,10 +10,10 @@ uses {$IFDEF FPC} LCLIntf, LCLType, LMessages, {$ELSE} - Windows, Messages, + Windows, Messages, Scanlines, {$ENDIF} SysUtils, Classes, Controls, Graphics, Math, Forms, - RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; + RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl; type THSColorPicker = class(TmbColorPickerControl) @@ -66,6 +66,9 @@ implementation {$IFDEF FPC} {$R HSColorPicker.dcr} + +uses + IntfGraphics, fpimage; {$ENDIF} procedure Register; @@ -109,6 +112,7 @@ begin CreateHSLGradient; end; +{$IFDEF DELPHI} procedure THSColorPicker.CreateHSLGradient; var Hue, Sat : integer; @@ -133,6 +137,41 @@ begin // FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120)); end; end; +{$ELSE} +procedure THSColorPicker.CreateHSLGradient; +var + Hue, Sat: Integer; + intfimg: TLazIntfImage; + imgHandle, imgMaskHandle: HBitmap; + c: TColor; +begin + if FHSLBmp = nil then + begin + FHSLBmp := TBitmap.Create; + FHSLBmp.PixelFormat := pf32Bit; + FHSLBmp.Width := 240; + FHSLBmp.Height := 241; + end; + intfimg := TLazIntfImage.Create(FHSLBmp.Width, FHSLBmp.Height); + try + intfImg.LoadFromBitmap(FHSLBmp.Handle, FHSLBmp.MaskHandle); + for Hue := 0 to 239 do + for Sat := 0 to 240 do + begin + if not WebSafe then + c := HSLRangeToRGB(Hue, Sat, 120) + else + c := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120)); + intfimg.Colors[Hue, 240-Sat] := TColorToFPColor(c); + end; + intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false); + FHSLBmp.Handle := imgHandle; + FHSLBmp.MaskHandle := imgMaskHandle; + finally + intfimg.Free; + end; +end; +{$ENDIF} procedure THSColorPicker.CorrectCoords(var x, y: integer); begin diff --git a/components/mbColorLib/HSLColorPicker.pas b/components/mbColorLib/HSLColorPicker.pas index d6aa64a76..c3182a696 100644 --- a/components/mbColorLib/HSLColorPicker.pas +++ b/components/mbColorLib/HSLColorPicker.pas @@ -16,10 +16,10 @@ uses {$ENDIF} SysUtils, Classes, Controls, Graphics, Forms, Menus, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} - RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors; + RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors, mbBasicPicker; type - THSLColorPicker = class(TCustomControl) + THSLColorPicker = class(TmbBasicPicker) private FOnChange: TNotifyEvent; FHSPicker: THSColorPicker; @@ -48,14 +48,12 @@ type procedure SetHSMenu(m: TPopupMenu); procedure SetHSCursor(c: TCursor); procedure SetLCursor(c: TCursor); - procedure PaintParentBack; procedure SetSelectedColor(Value: TColor); protected procedure CreateWnd; override; procedure Resize; override; procedure Paint; override; - procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); - message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; + procedure PaintParentBack; override; procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF}; procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); @@ -121,55 +119,61 @@ end; constructor THSLColorPicker.Create(AOwner: TComponent); begin - inherited; - ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; - DoubleBuffered := true; - ParentColor := true; - PBack := TBitmap.Create; - PBack.PixelFormat := pf32bit; - {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} - ParentBackground := true; - {$ENDIF} {$ENDIF} - Width := 206; - Height := 146; - TabStop := true; - FSelectedColor := clRed; - FHSPicker := THSColorPicker.Create(Self); - InsertControl(FHSPicker); - FLumIncrement := 1; - FHSCursor := crDefault; - FLCursor := crDefault; - with FHSPicker do + inherited; + ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; + DoubleBuffered := true; + PBack := TBitmap.Create; + PBack.PixelFormat := pf32bit; + {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} + ParentBackground := true; + {$ENDIF} {$ENDIF} + SetInitialBounds(0, 0, 206, 146); + //Width := 206; + //Height := 146; + TabStop := true; + FSelectedColor := clRed; + FHSPicker := THSColorPicker.Create(Self); + InsertControl(FHSPicker); + FLumIncrement := 1; + FHSCursor := crDefault; + FLCursor := crDefault; + with FHSPicker do begin - Height := 134; - Width := 174; - Top := 6; - Left := 0; - Anchors := [akLeft, akTop, akRight, akBottom]; - Visible := true; - OnChange := HSPickerChange; - OnMouseMove := DoMouseMove; + SetInitialBounds(0, 6, 174, 134); + { + Height := 134; + Width := 174; + Top := 6; + Left := 0; + } + Anchors := [akLeft, akTop, akRight, akBottom]; + Visible := true; + OnChange := HSPickerChange; + OnMouseMove := DoMouseMove; end; - FLPicker := TLColorPicker.Create(Self); - InsertControl(FLPicker); - with FLPicker do + FLPicker := TLColorPicker.Create(Self); + InsertControl(FLPicker); + with FLPicker do begin - Height := 146; - Top := 0; - Left := 184; - Anchors := [akRight, akTop, akBottom]; - Visible := true; - OnChange := LPickerChange; - OnMouseMove := DoMouseMove; + SetInitialBounds(184, 0, 25, 146); + { + Height := 146; + Top := 0; + Left := 184; + } + Anchors := [akRight, akTop, akBottom]; + Visible := true; + OnChange := LPickerChange; + OnMouseMove := DoMouseMove; end; - FHValue := 0; - FSValue := 240; - FLValue := 120; - FRValue := 255; - FGValue := 0; - FBValue := 0; - FHSHint := 'H: %h S: %hslS'#13'Hex: %hex'; - FLHint := 'Luminance: %l'; + FHValue := 0; + FSValue := 240; + FLValue := 120; + FRValue := 255; + FGValue := 0; + FBValue := 0; + FHSHint := 'H: %h S: %hslS'#13'Hex: %hex'; + FLHint := 'Luminance: %l'; end; destructor THSLColorPicker.Destroy; @@ -328,11 +332,6 @@ begin end; procedure THSLColorPicker.PaintParentBack; -{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} -var - MemDC: HDC; - OldBMP: HBITMAP; - {$ENDIF} {$ENDIF} begin if PBack = nil then begin @@ -341,31 +340,22 @@ begin end; PBack.Width := Width; PBack.Height := Height; - {$IFDEF FPC} - if Color = clDefault then - PBack.Canvas.Brush.Color := clForm - else - {$ENDIF} - PBack.Canvas.Brush.Color := Color; - PBack.Canvas.FillRect(PBack.Canvas.ClipRect); - {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} - if ParentBackground then - with ThemeServices do - if ThemesEnabled then - begin - MemDC := CreateCompatibleDC(0); - OldBMP := SelectObject(MemDC, PBack.Handle); - DrawParentBackground(Handle, MemDC, nil, False); - if OldBMP <> 0 then SelectObject(MemDC, OldBMP); - if MemDC <> 0 then DeleteDC(MemDC); - end; - {$ENDIF} {$ENDIF} + PaintParentBack(PBack); end; procedure THSLColorPicker.Resize; begin - inherited; - PaintParentBack; + inherited; + PaintParentBack; + + if (FHSPicker = nil) or (FLPicker = nil) then + exit; + + FHSPicker.Width := Width - FLPicker.Width - 15; + FHSPicker.Height := Height - 12; + + FLPicker.Left := Width - FLPicker.Width - 2; + FLPicker.Height := Height; // - 12; end; procedure THSLColorPicker.CreateWnd; @@ -380,12 +370,6 @@ begin Canvas.Draw(0, 0, PBack); end; -procedure THSLColorPicker.WMEraseBkgnd( - var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF} ); -begin - Message.Result := 1; -end; - procedure THSLColorPicker.SetSelectedColor(Value: TColor); begin if FSelectedColor <> Value then diff --git a/components/mbColorLib/HSLRingPicker.pas b/components/mbColorLib/HSLRingPicker.pas index fc1a4f958..87af77649 100644 --- a/components/mbColorLib/HSLRingPicker.pas +++ b/components/mbColorLib/HSLRingPicker.pas @@ -16,10 +16,10 @@ uses {$ENDIF} SysUtils, Classes, Controls, Graphics, Forms, Menus, Math, {$IFDEF DELPHI_7_UP}Themes,{$ENDIF} - RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors; + RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors, mbBasicPicker; type - THSLRingPicker = class(TCustomControl) + THSLRingPicker = class(TmbBasicPicker) private FOnChange: TNotifyEvent; FRingPicker: THRingPicker; @@ -46,7 +46,6 @@ type procedure SetRingMenu(m: TPopupMenu); procedure SetRingCursor(c: TCursor); procedure SetSLCursor(c: TCursor); - procedure PaintParentBack; protected procedure CreateWnd; override; procedure Paint; override; @@ -56,10 +55,8 @@ type procedure DoChange; procedure Resize; override; {$IFDEF DELPHI} - procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS; {$ELSE} - procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS; {$ENDIF} public @@ -123,7 +120,6 @@ begin inherited; ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}]; DoubleBuffered := true; - ParentColor := true; PBack := TBitmap.Create; PBack.PixelFormat := pf32bit; {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} @@ -143,6 +139,7 @@ begin Width := 246; Top := 0; Left := 0; + Radius := 100; Align := alClient; Visible := true; Saturation := 255; @@ -182,16 +179,33 @@ begin end; procedure THSLRingPicker.Resize; +var + circ: TPoint; + ctr: double; begin inherited; if (FRingPicker = nil) or (FSLPicker = nil) then exit; + + ctr := Min(Width, Height)/100; + + circ.x := Min(Width, Height) div 2; + circ.y := circ.x; + + FRingPicker.Radius := circ.x - round(12*ctr); + + FSLPicker.Left := circ.x - FSLPicker.Width div 2; + FSLPicker.Top := circ.y - FSLPicker.Height div 2; + FSLPicker.Width := round(50*ctr); + FSLPicker.Height := FSLPicker.Width; + (* FRingPicker.Radius := (Min(Width, Height)*30) div 245; FSLPicker.Left := (21*FRingPicker.Radius) div 10; FSLPicker.Top := (21*FRingPicker.Radius) div 10; FSLPicker.Width := 4*FRingPicker.Radius; FSLPicker.Height := 4*FRingPicker.Radius; - PaintParentBack; + *) + PaintParentBack(PBack); end; procedure THSLRingPicker.RingPickerChange(Sender: TObject); @@ -351,55 +365,16 @@ begin Result := FRingPicker.Manual or FSLPicker.Manual; end; -procedure THSLRingPicker.PaintParentBack; -var - MemDC: HDC; - OldBMP: HBITMAP; -begin - if PBack = nil then - begin - PBack := TBitmap.Create; - PBack.PixelFormat := pf32bit; - end; - PBack.Width := Width; - PBack.Height := Height; - {$IFDEF FPC} - if Color = clDefault then - PBack.Canvas.Brush.Color := clForm - else - {$ENDIF} - PBack.Canvas.Brush.Color := Color; - PBack.Canvas.FillRect(PBack.Canvas.ClipRect); - {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} - if ParentBackground then - with ThemeServices do - if ThemesEnabled then - begin - MemDC := CreateCompatibleDC(0); - OldBMP := SelectObject(MemDC, PBack.Handle); - DrawParentBackground(Handle, MemDC, nil, False); - if OldBMP <> 0 then SelectObject(MemDC, OldBMP); - if MemDC <> 0 then DeleteDC(MemDC); - end; - {$ENDIF} {$ENDIF} -end; - procedure THSLRingPicker.Paint; begin - PaintParentBack; + PaintParentBack(PBack); Canvas.Draw(0, 0, PBack); end; procedure THSLRingPicker.CreateWnd; begin inherited; - PaintParentBack; -end; - -procedure THSLRingPicker.WMEraseBkgnd( - var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} ); -begin - Message.Result := 1; + PaintParentBack(PBack); end; end. diff --git a/components/mbColorLib/HSVColorPicker.pas b/components/mbColorLib/HSVColorPicker.pas index 8828a8295..0029d283b 100644 --- a/components/mbColorLib/HSVColorPicker.pas +++ b/components/mbColorLib/HSVColorPicker.pas @@ -85,6 +85,9 @@ implementation {$IFDEF FPC} {$R HSVColorPicker.dcr} + +uses + IntfGraphics, fpimage; {$ENDIF} procedure Register; @@ -153,51 +156,83 @@ end; procedure THSVColorPicker.CreateHSVCircle; var - dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; - row: pRGBQuadArray; - tc: TColor; + dSquared, H, S, V, i, j, radius, radiusSquared, x, y, size: integer; + row: pRGBQuadArray; + c: TColor; + {$IFDEF FPC} + intfimg: TLazIntfImage; + imgHandle, imgMaskHandle: HBitmap; + {$ENDIF} begin - if FHSVBmp = nil then + if FHSVBmp = nil then begin - FHSVBmp := TBitmap.Create; - FHSVBmp.PixelFormat := pf32bit; + FHSVBmp := TBitmap.Create; + FHSVBmp.PixelFormat := pf32bit; end; - size := Min(Width, Height); - FHSVBmp.Width := size; - FHSVBmp.Height := size; - Radius := size div 2; - RadiusSquared := Radius*Radius; - PaintParentBack(FHSVBmp.Canvas); + size := Min(Width, Height); + FHSVBmp.Width := size; + FHSVBmp.Height := size; + PaintParentBack(FHSVBmp.Canvas); - V := FValue; - for j := 0 to size-1 do - begin - Y := Size - 1 - j - Radius; - row := FHSVBmp.Scanline[Size - 1 - j]; - for i := 0 to size-1 do + radius := size div 2; + radiusSquared := radius * radius; + V := FValue; + + {$IFDEF FPC} + intfimg := TLazIntfImage.Create(FHSVBmp.Width, FHSVBmp.Height); + try + intfImg.LoadFromBitmap(FHSVBmp.Handle, FHSVBmp.MaskHandle); + {$ENDIF} + + for j := 0 to size - 1 do begin - X := i - Radius; - dSquared := X*X + Y*Y; - if dSquared <= RadiusSquared then + Y := size - 1 - j - Radius; + {$IFDEF FPC} + row := intfImg.GetDataLineStart(size - 1 - j); + {$ELSE} + row := FHSVBmp.Scanline(size - 1 - j); + {$ENDIF} + for i := 0 to size - 1 do begin - if Radius <> 0 then - S := ROUND((255*SQRT(dSquared))/Radius) - else - S := 0; - H := ROUND(180*(1 + ArcTan2(X, Y)/PI)); - H := H + 90; - if H > 360 then H := H - 360; - if not WebSafe then - row[i] := HSVtoRGBQuad(H,S,V) - else + X := i - Radius; + dSquared := X*X + Y*Y; + if dSquared <= RadiusSquared then begin - tc := GetWebSafe(HSVtoColor(H, S, V)); - row[i] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc)); + if Radius <> 0 then + S := round(255.0 * sqrt(dSquared) / radius) + else + S := 0; + H := round(180 * (1 + arctan2(X, Y) / pi)); // wp: order (x,y) is correct! + H := H + 90; + if H > 360 then H := H - 360; + {$IFDEF FPC} + c := HSVtoColor(H, S, V); + if WebSafe then + c := GetWebSafe(c); + row^[i].rgbRed := GetRValue(c); + row^[i].rgbGreen := GetGValue(c); + row^[i].rgbBlue := GetBValue(c); + {$ELSE} + if not WebSafe then + row[i] := HSVtoRGBQuad(H,S,V) + else + begin + c := GetWebSafe(HSVtoColor(H, S, V)); + row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c)); + end; + {$ENDIF} end; - end + end; end; + {$IFDEF FPC} + intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false); + FHSVBmp.Handle := imgHandle; + FHSVBmp.MaskHandle := imgMaskHandle; + finally + intfimg.Free; end; + {$ENDIF} end; procedure THSVColorPicker.Resize; diff --git a/components/mbColorLib/HexaColorPicker.pas b/components/mbColorLib/HexaColorPicker.pas index 55a853a7d..d7042a2ff 100644 --- a/components/mbColorLib/HexaColorPicker.pas +++ b/components/mbColorLib/HexaColorPicker.pas @@ -16,7 +16,7 @@ uses {$ENDIF} SysUtils, Classes, Controls, Graphics, StdCtrls, Forms, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math, - RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils; + RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker; const CustomCell = -2; @@ -43,7 +43,7 @@ type TSelectionMode = (smNone, smColor, smBW, smRamp); - THexaColorPicker = class(TCustomControl) + THexaColorPicker = class(TmbBasicPicker) private FIncrement: integer; FSelectedCombIndex: integer; @@ -60,7 +60,7 @@ type FCenterColor: TRGBrec; FCenterIntensity: Single; FSliderWidth: integer; - FCustomIndex, // If FSelectedIndex contains CustomCell then this index shows + FCustomIndex: Integer; // If FSelectedIndex contains CustomCell then this index shows // which index in the custom area has been selected. // Positive values indicate the color comb and negative values // indicate the B&W combs (complement). This value is offset with @@ -84,7 +84,6 @@ type procedure DrawAll; procedure SetSelectedColor(const Value: TColor); procedure DrawCombControls; - procedure PaintParentBack; procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer); procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}); procedure CalculateCombLayout; @@ -101,23 +100,25 @@ type function GetNextCombIndex(i: integer): integer; function GetPreviousCombIndex(i: integer): integer; protected + procedure CreateWnd; override; + procedure Paint; override; + procedure Resize; override; procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); - procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); - message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; - procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); - message CN_KEYDOWN; - procedure CMHintShow(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); - message CM_HINTSHOW; - procedure WMLButtonDown(var Message: {$IFDEF FPC}TLMLButtonDown{$ELSE}TWMLButtonDown{$ENDIF}); - message {$IFDEF FPC}LM_LBUTTONDOWN{$ELSE}WM_LBUTTONDOWN{$ENDIF}; - procedure WMLButtonUp(var Message: {$IFDEF FPC}TLMLButtonUp{$ELSE}TWMLButtonUp{$ENDIF}); - message {$IFDEF FPC}LM_LBUTTONUP{$ELSE}WM_LBUTTONUP{$ENDIF}; - procedure WMMouseMove(var Message: {$IFDEF FPC}TLMMouseMove{$ELSE}TWMMouseMove{$ENDIF}); - message {$IFDEF FPC}LM_MOUSEMOVE{$ELSE}WM_MOUSEMOVE{$ENDIF}; - procedure Paint; override; - procedure CreateWnd; override; - procedure Resize; override; + {$IFDEF DELPHI} + procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; + procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; + {$ELSE} + procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN; + procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW; + procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN; + procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP; + procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE; + {$ENDIF} + public constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -145,12 +146,12 @@ type property Visible; property Enabled; property PopupMenu; - property ParentColor default true; {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} property ParentBackground default true; {$ENDIF}{$ENDIF} property TabOrder; property Color; + property ParentColor; property SliderWidth: integer read FSliderWidth write SetSliderWidth default 12; property DragCursor; property DragMode; @@ -214,7 +215,6 @@ begin FRadius := 90; FSliderWidth := 12; DoubleBuffered := true; - ParentColor := true; {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} ParentBackground := true; {$ENDIF}{$ENDIF} @@ -453,47 +453,6 @@ begin EnumerateCombs; end; -procedure THexaColorPicker.WMEraseBkgnd( - var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); -begin - Message.Result := 1; -end; - -procedure THexaColorPicker.PaintParentBack; -var - OffScreen: TBitmap; - {$IFDEF DELPHI_7_UP} - MemDC: HDC; - OldBMP: HBITMAP; - {$ENDIF} -begin - Offscreen := TBitmap.Create; - Offscreen.PixelFormat := pf32bit; - Offscreen.Width := Width; - Offscreen.Height := Height; - {$IFDEF FPC} - if Color = clDefault then - Offscreen.Canvas.Brush.Color := clForm - else - {$ENDIF} - Offscreen.Canvas.Brush.Color := Color; - Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect); - {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} - if ParentBackground then - with ThemeServices do - if ThemesEnabled then - begin - MemDC := CreateCompatibleDC(0); - OldBMP := SelectObject(MemDC, OffScreen.Handle); - DrawParentBackground(Handle, MemDC, nil, False); - if OldBMP <> 0 then SelectObject(MemDC, OldBMP); - if MemDC <> 0 then DeleteDC(MemDC); - end; - {$ENDIF}{$ENDIF} - Canvas.Draw(0, 0, Offscreen); - Offscreen.Free; -end; - procedure THexaColorPicker.Paint; begin PaintParentBack; diff --git a/components/mbColorLib/KColorPicker.pas b/components/mbColorLib/KColorPicker.pas index d22757377..cb49f5f9a 100644 --- a/components/mbColorLib/KColorPicker.pas +++ b/components/mbColorLib/KColorPicker.pas @@ -7,45 +7,41 @@ unit KColorPicker; interface uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Graphics, Forms, - RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBCMYKUtils, mbTrackBarPicker, HTMLColors; type - TKColorPicker = class(TmbTrackBarPicker) - private - FCyan, FMagenta, FYellow, FBlack: integer; - FKBmp: TBitmap; - - function ArrowPosFromBlack(k: integer): integer; - function BlackFromArrowPos(p: integer): integer; - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - procedure CreateKGradient; - procedure SetCyan(c: integer); - procedure SetMagenta(m: integer); - procedure SetYellow(y: integer); - procedure SetBlack(k: integer); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Cyan: integer read FCyan write SetCyan default 255; - property Magenta: integer read FMagenta write SetMagenta default 0; - property Yellow: integer read FYellow write SetYellow default 0; - property Black: integer read FBlack write SetBlack default 0; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - property Layout default lyVertical; - end; + TKColorPicker = class(TmbTrackBarPicker) + private + FCyan, FMagenta, FYellow, FBlack: integer; + function ArrowPosFromBlack(k: integer): integer; + function BlackFromArrowPos(p: integer): integer; + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); + procedure SetCyan(c: integer); + procedure SetMagenta(m: integer); + procedure SetYellow(y: integer); + procedure SetBlack(k: integer); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; + published + property Cyan: integer read FCyan write SetCyan default 255; + property Magenta: integer read FMagenta write SetMagenta default 0; + property Yellow: integer read FYellow write SetYellow default 0; + property Black: integer read FBlack write SetBlack default 0; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + property Layout default lyVertical; + end; procedure Register; @@ -57,47 +53,36 @@ implementation procedure Register; begin - RegisterComponents('mbColor Lib', [TKColorPicker]); + RegisterComponents('mbColor Lib', [TKColorPicker]); end; {TKColorPicker} constructor TKColorPicker.Create(AOwner: TComponent); begin - inherited; - FKBmp := TBitmap.Create; - FKBmp.PixelFormat := pf32bit; - FKBmp.SetSize(12, 255); - Width := 22; - Height := 267; - Layout := lyVertical; - FCyan := 0; - FMagenta := 0; - FYellow := 0; - FBlack := 255; - FArrowPos := ArrowPosFromBlack(255); - FChange := false; - SetBlack(255); - HintFormat := 'Black: %value'; - FManual := false; - FChange := true; -end; - -destructor TKColorPicker.Destroy; -begin - FKBmp.Free; - inherited Destroy; -end; - -procedure TKColorPicker.CreateWnd; -begin - inherited; - CreateKGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + SetInitialBounds(0, 0, 22, 267); + //Width := 22; + //Height := 267; + Layout := lyVertical; + FCyan := 0; + FMagenta := 0; + FYellow := 0; + FBlack := 255; + FArrowPos := ArrowPosFromBlack(255); + FChange := false; + SetBlack(255); + HintFormat := 'Black: %value'; + FManual := false; + FChange := true; end; +(* procedure TKColorPicker.CreateKGradient; var - i,j: integer; + i,j: integer; row: pRGBQuadArray; begin if FKBmp = nil then @@ -138,105 +123,107 @@ begin end; end; end; + *) + +function TKColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, AValue); +end; procedure TKColorPicker.SetBlack(k: integer); begin - if k < 0 then k := 0; - if k > 255 then k := 255; - if FBlack <> k then + if k < 0 then k := 0; + if k > 255 then k := 255; + if FBlack <> k then begin - FBlack := k; - FArrowPos := ArrowPosFromBlack(k); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FBlack := k; + FArrowPos := ArrowPosFromBlack(k); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TKColorPicker.SetMagenta(m: integer); begin - if m > 255 then m := 255; - if m < 0 then m := 0; - if FMagenta <> m then + if m > 255 then m := 255; + if m < 0 then m := 0; + if FMagenta <> m then begin - FMagenta := m; - FManual := false; - CreateKGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FMagenta := m; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TKColorPicker.SetYellow(y: integer); begin - if y > 255 then y := 255; - if y < 0 then y := 0; - if FYellow <> y then + if y > 255 then y := 255; + if y < 0 then y := 0; + if FYellow <> y then begin - FYellow := y; - FManual := false; - CreateKGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FYellow := y; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TKColorPicker.SetCyan(c: integer); begin - if c > 255 then c := 255; - if c < 0 then c := 0; - if FCyan <> c then + if c > 255 then c := 255; + if c < 0 then c := 0; + if FCyan <> c then begin - FCyan := c; - FManual := false; - CreateKGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FCyan := c; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TKColorPicker.ArrowPosFromBlack(k: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*k); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*k); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - k := 255 - k; - a := Round(((Height - 12)/255)*k); - if a > Height - FLimit then a := Height - FLimit; + k := 255 - k; + a := Round(((Height - 12)/255)*k); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TKColorPicker.BlackFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/255)) - else - r := Round(255 - p/((Height - 12)/255)); - if r < 0 then r := 0; - if r > 255 then r := 255; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/255)) + else + r := Round(255 - p/((Height - 12)/255)); + if r < 0 then r := 0; + if r > 255 then r := 255; + Result := r; end; function TKColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) - else - Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); end; function TKColorPicker.GetSelectedValue: integer; @@ -246,45 +233,59 @@ end; procedure TKColorPicker.SetSelectedColor(c: TColor); var - cy, m, y, k: integer; + cy, m, y, k: integer; begin - if WebSafe then c := GetWebSafe(c); - ColorToCMYK(c, cy, m, y, k); - FChange := false; - SetMagenta(m); - SetYellow(y); - SetCyan(cy); - SetBlack(k); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + ColorToCMYK(c, cy, m, y, k); + FChange := false; + SetMagenta(m); + SetYellow(y); + SetCyan(cy); + SetBlack(k); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TKColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromBlack(FBlack); + Result := ArrowPosFromBlack(FBlack); end; procedure TKColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetBlack(FBlack); - TBA_Paint: Canvas.StretchDraw(FPickRect, FKBmp); - TBA_MouseMove: FBlack := BlackFromArrowPos(FArrowPos); - TBA_MouseDown: FBlack := BlackFromArrowPos(FArrowPos); - TBA_MouseUp: FBlack := BlackFromArrowPos(FArrowPos); - TBA_WheelUp: SetBlack(FBlack + Increment); - TBA_WheelDown: SetBlack(FBlack - Increment); - TBA_VKRight: SetBlack(FBlack + Increment); - TBA_VKCtrlRight: SetBlack(255); - TBA_VKLeft: SetBlack(FBlack - Increment); - TBA_VKCtrlLeft: SetBlack(0); - TBA_VKUp: SetBlack(FBlack + Increment); - TBA_VKCtrlUp: SetBlack(255); - TBA_VKDown: SetBlack(FBlack - Increment); - TBA_VKCtrlDown: SetBlack(0); - TBA_RedoBMP: CreateKGradient; - end; + case tbaAction of + TBA_Resize: + SetBlack(FBlack); + TBA_MouseMove: + FBlack := BlackFromArrowPos(FArrowPos); + TBA_MouseDown: + FBlack := BlackFromArrowPos(FArrowPos); + TBA_MouseUp: + FBlack := BlackFromArrowPos(FArrowPos); + TBA_WheelUp: + SetBlack(FBlack + Increment); + TBA_WheelDown: + SetBlack(FBlack - Increment); + TBA_VKRight: + SetBlack(FBlack + Increment); + TBA_VKCtrlRight: + SetBlack(255); + TBA_VKLeft: + SetBlack(FBlack - Increment); + TBA_VKCtrlLeft: + SetBlack(0); + TBA_VKUp: + SetBlack(FBlack + Increment); + TBA_VKCtrlUp: + SetBlack(255); + TBA_VKDown: + SetBlack(FBlack - Increment); + TBA_VKCtrlDown: + SetBlack(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/LColorPicker.pas b/components/mbColorLib/LColorPicker.pas index 6de4e5d33..ed0a0ec7b 100644 --- a/components/mbColorLib/LColorPicker.pas +++ b/components/mbColorLib/LColorPicker.pas @@ -7,43 +7,39 @@ interface {$ENDIF} uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Graphics, Forms, - RGBHSLUtils, mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBHSLUtils, mbTrackBarPicker, HTMLColors; type - TLColorPicker = class(TmbTrackBarPicker) - private - FHue, FSat, FLuminance: integer; - FLBmp: TBitmap; - - function ArrowPosFromLum(l: integer): integer; - function LumFromArrowPos(p: integer): integer; - procedure CreateLGradient; - procedure SetHue(h: integer); - procedure SetSat(s: integer); - procedure SetLuminance(l: integer); - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Hue: integer read FHue write SetHue default 0; - property Saturation: integer read FSat write SetSat default 240; - property Luminance: integer read FLuminance write SetLuminance default 120; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - property Layout default lyVertical; - end; + TLColorPicker = class(TmbTrackBarPicker) + private + FHue, FSat, FLuminance: integer; + function ArrowPosFromLum(l: integer): integer; + function LumFromArrowPos(p: integer): integer; + procedure SetHue(h: integer); + procedure SetSat(s: integer); + procedure SetLuminance(l: integer); + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; + published + property Hue: integer read FHue write SetHue default 0; + property Saturation: integer read FSat write SetSat default 240; + property Luminance: integer read FLuminance write SetLuminance default 120; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + property Layout default lyVertical; + end; procedure Register; @@ -55,41 +51,28 @@ implementation procedure Register; begin - RegisterComponents('mbColor Lib', [TLColorPicker]); + RegisterComponents('mbColor Lib', [TLColorPicker]); end; {TLColorPicker} constructor TLColorPicker.Create(AOwner: TComponent); begin - inherited; - FLBmp := TBitmap.Create; - FLBmp.PixelFormat := pf32bit; - Width := 22; - Height := 252; - Layout := lyVertical; - FHue := 0; - FSat := MaxSat; - FArrowPos := ArrowPosFromLum(MaxLum div 2); - Fchange := false; - SetLuminance(MaxLum div 2); - HintFormat := 'Luminance: %value'; - FManual := false; - FChange := true; -end; - -destructor TLColorPicker.Destroy; -begin - FLBmp.Free; - inherited Destroy; -end; - -procedure TLColorPicker.CreateWnd; -begin - inherited; - CreateLGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + Layout := lyVertical; + FHue := 0; + FSat := MaxSat; + FArrowPos := ArrowPosFromLum(MaxLum div 2); + FChange := false; + SetLuminance(MaxLum div 2); + HintFormat := 'Luminance: %value'; + FManual := false; + FChange := true; end; +(* procedure TLColorPicker.CreateLGradient; var i,j: integer; @@ -133,90 +116,93 @@ begin end; end; end; +*) + +function TLColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := HSLRangeToRGB(FHue, FSat, AValue); +end; procedure TLColorPicker.SetHue(h: integer); begin - if h > MaxHue then h := MaxHue; - if h < 0 then h := 0; - if FHue <> h then + if h > MaxHue then h := MaxHue; + if h < 0 then h := 0; + if FHue <> h then begin - FHue := h; - FManual := false; - CreateLGradient; - Invalidate; - if Fchange then - if Assigned(OnChange) then OnChange(Self); + FHue := h; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TLColorPicker.SetSat(s: integer); begin - if s > MaxSat then s := MaxSat; - if s < 0 then s := 0; - if FSat <> s then + if s > MaxSat then s := MaxSat; + if s < 0 then s := 0; + if FSat <> s then begin - FSat := s; - FManual := false; - CreateLGradient; - Invalidate; - if Fchange then - if Assigned(OnChange) then OnChange(Self); + FSat := s; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TLColorPicker.ArrowPosFromLum(l: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/MaxLum)*l); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/MaxLum)*l); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - l := MaxLum - l; - a := Round(((Height - 12)/MaxLum)*l); - if a > Height - FLimit then a := Height - FLimit; + l := MaxLum - l; + a := Round(((Height - 12)/MaxLum)*l); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TLColorPicker.LumFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/MaxLum)) - else - r := Round(MaxLum - p/((Height - 12)/MaxLum)); - if r < 0 then r := 0; - if r > MaxLum then r := MaxLum; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/MaxLum)) + else + r := Round(MaxLum - p/((Height - 12)/MaxLum)); + if r < 0 then r := 0; + if r > MaxLum then r := MaxLum; + Result := r; end; procedure TLColorPicker.SetLuminance(l: integer); begin - if l < 0 then l := 0; - if l > MaxLum then l := MaxLum; - if FLuminance <> l then + if l < 0 then l := 0; + if l > MaxLum then l := MaxLum; + if FLuminance <> l then begin - FLuminance := l; - FArrowPos := ArrowPosFromLum(l); - FManual := false; - Invalidate; - if Fchange then - if Assigned(OnChange) then OnChange(Self); + FLuminance := l; + FArrowPos := ArrowPosFromLum(l); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TLColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := HSLRangeToRGB(FHue, FSat, FLuminance) - else - Result := GetWebSafe(HSLRangeToRGB(FHue, FSat, FLuminance)); + if not WebSafe then + Result := HSLRangeToRGB(FHue, FSat, FLuminance) + else + Result := GetWebSafe(HSLRangeToRGB(FHue, FSat, FLuminance)); end; function TLColorPicker.GetSelectedValue: integer; @@ -226,45 +212,58 @@ end; procedure TLColorPicker.SetSelectedColor(c: TColor); var - h1, s1, l1: integer; + h1, s1, l1: integer; begin - if WebSafe then c := GetWebSafe(c); - RGBtoHSLRange(c, h1, s1, l1); - Fchange := false; - SetHue(h1); - SetSat(s1); - SetLuminance(l1); - Fchange := true; - FManual := false; - if Fchange then - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + RGBtoHSLRange(c, h1, s1, l1); + Fchange := false; + SetHue(h1); + SetSat(s1); + SetLuminance(l1); + FChange := true; + FManual := false; + if FChange and Assigned(OnChange) then OnChange(Self); end; function TLColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromLum(FLuminance); + Result := ArrowPosFromLum(FLuminance); end; procedure TLColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetLuminance(FLuminance); - TBA_Paint: Canvas.StretchDraw(FPickRect, FLBmp); - TBA_MouseMove: FLuminance := LumFromArrowPos(FArrowPos); - TBA_MouseDown: Fluminance := LumFromArrowPos(FArrowPos); - TBA_MouseUp: Fluminance := LumFromArrowPos(FArrowPos); - TBA_WheelUp: SetLuminance(FLuminance + Increment); - TBA_WheelDown: SetLuminance(FLuminance - Increment); - TBA_VKRight: SetLuminance(FLuminance + Increment); - TBA_VKCtrlRight: SetLuminance(MaxLum); - TBA_VKLeft: SetLuminance(FLuminance - Increment); - TBA_VKCtrlLeft: SetLuminance(0); - TBA_VKUp: SetLuminance(FLuminance + Increment); - TBA_VKCtrlUp: SetLuminance(MaxLum); - TBA_VKDown: SetLuminance(FLuminance - Increment); - TBA_VKCtrlDown: SetLuminance(0); - TBA_RedoBMP: CreateLGradient; - end; + case tbaAction of + TBA_Resize: + SetLuminance(FLuminance); + TBA_MouseMove: + FLuminance := LumFromArrowPos(FArrowPos); + TBA_MouseDown: + Fluminance := LumFromArrowPos(FArrowPos); + TBA_MouseUp: + Fluminance := LumFromArrowPos(FArrowPos); + TBA_WheelUp: + SetLuminance(FLuminance + Increment); + TBA_WheelDown: + SetLuminance(FLuminance - Increment); + TBA_VKRight: + SetLuminance(FLuminance + Increment); + TBA_VKCtrlRight: + SetLuminance(MaxLum); + TBA_VKLeft: + SetLuminance(FLuminance - Increment); + TBA_VKCtrlLeft: + SetLuminance(0); + TBA_VKUp: + SetLuminance(FLuminance + Increment); + TBA_VKCtrlUp: + SetLuminance(MaxLum); + TBA_VKDown: + SetLuminance(FLuminance - Increment); + TBA_VKCtrlDown: + SetLuminance(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/MColorPicker.pas b/components/mbColorLib/MColorPicker.pas index ff9528b4f..ab1aee7aa 100644 --- a/components/mbColorLib/MColorPicker.pas +++ b/components/mbColorLib/MColorPicker.pas @@ -7,45 +7,41 @@ interface {$ENDIF} uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Graphics, Forms, - RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBCMYKUtils, mbTrackBarPicker, HTMLColors; //, Scanlines; type - TMColorPicker = class(TmbTrackBarPicker) - private - FCyan, FMagenta, FYellow, FBlack: integer; - FMBmp: TBitmap; - - function ArrowPosFromMagenta(m: integer): integer; - function MagentaFromArrowPos(p: integer): integer; - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - procedure CreateMGradient; - procedure SetCyan(c: integer); - procedure SetMagenta(m: integer); - procedure SetYellow(y: integer); - procedure SetBlack(k: integer); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Cyan: integer read FCyan write SetCyan default 0; - property Magenta: integer read FMagenta write SetMagenta default 255; - property Yellow: integer read FYellow write SetYellow default 0; - property Black: integer read FBlack write SetBlack default 0; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - property Layout default lyVertical; - end; + TMColorPicker = class(TmbTrackBarPicker) + private + FCyan, FMagenta, FYellow, FBlack: integer; + function ArrowPosFromMagenta(m: integer): integer; + function MagentaFromArrowPos(p: integer): integer; + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); + procedure SetCyan(c: integer); + procedure SetMagenta(m: integer); + procedure SetYellow(y: integer); + procedure SetBlack(k: integer); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; + published + property Cyan: integer read FCyan write SetCyan default 0; + property Magenta: integer read FMagenta write SetMagenta default 255; + property Yellow: integer read FYellow write SetYellow default 0; + property Black: integer read FBlack write SetBlack default 0; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + property Layout default lyVertical; + end; procedure Register; @@ -64,37 +60,25 @@ end; constructor TMColorPicker.Create(AOwner: TComponent); begin - inherited; - FMBmp := TBitmap.Create; - FMBmp.PixelFormat := pf32bit; - FMBmp.SetSize(12, 255); - Width := 22; - Height := 267; - Layout := lyVertical; - FCyan := 0; - FMagenta := 255; - FYellow := 0; - FBlack := 0; - FArrowPos := ArrowPosFromMagenta(255); - FChange := false; - SetMagenta(255); - HintFormat := 'Magenta: %value'; - FManual := false; - FChange := true; -end; - -destructor TMColorPicker.Destroy; -begin - FMBmp.Free; - inherited Destroy; -end; - -procedure TMColorPicker.CreateWnd; -begin - inherited; - CreateMGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + Width := 22; + Height := 267; + Layout := lyVertical; + FCyan := 0; + FMagenta := 255; + FYellow := 0; + FBlack := 0; + FArrowPos := ArrowPosFromMagenta(255); + FChange := false; + SetMagenta(255); + HintFormat := 'Magenta: %value'; + FManual := false; + FChange := true; end; +(* procedure TMColorPicker.CreateMGradient; var i,j: integer; @@ -138,105 +122,106 @@ begin end; end; end; +*) +function TMColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := CMYKtoTColor(FCyan, AValue, FYellow, FBlack); +end; procedure TMColorPicker.SetMagenta(m: integer); begin - if M < 0 then M := 0; - if M > 255 then M := 255; - if FMagenta <> m then + if M < 0 then M := 0; + if M > 255 then M := 255; + if FMagenta <> m then begin - FMagenta := m; - FArrowPos := ArrowPosFromMagenta(m); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FMagenta := m; + FArrowPos := ArrowPosFromMagenta(m); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TMColorPicker.SetCyan(c: integer); begin - if c > 255 then c := 255; - if c < 0 then c := 0; - if FCyan <> c then + if c > 255 then c := 255; + if c < 0 then c := 0; + if FCyan <> c then begin - FCyan := c; - FManual := false; - CreateMGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FCyan := c; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TMColorPicker.SetYellow(y: integer); begin - if y > 255 then y := 255; - if y < 0 then y := 0; - if FYellow <> y then + if y > 255 then y := 255; + if y < 0 then y := 0; + if FYellow <> y then begin - FYellow := y; - FManual := false; - CreateMGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FYellow := y; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TMColorPicker.SetBlack(k: integer); begin - if k > 255 then k := 255; - if k < 0 then k := 0; - if FBlack <> k then + if k > 255 then k := 255; + if k < 0 then k := 0; + if FBlack <> k then begin - FBlack := k; - FManual := false; - CreateMGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FBlack := k; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TMColorPicker.ArrowPosFromMagenta(m: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*m); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*m); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - m := 255 - m; - a := Round(((Height - 12)/255)*m); - if a > Height - FLimit then a := Height - FLimit; + m := 255 - m; + a := Round(((Height - 12)/255)*m); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TMColorPicker.MagentaFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/255)) - else - r := Round(255 - p/((Height - 12)/255)); - if r < 0 then r := 0; - if r > 255 then r := 255; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/255)) + else + r := Round(255 - p/((Height - 12)/255)); + if r < 0 then r := 0; + if r > 255 then r := 255; + Result := r; end; function TMColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) - else - Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); end; function TMColorPicker.GetSelectedValue: integer; @@ -246,45 +231,59 @@ end; procedure TMColorPicker.SetSelectedColor(c: TColor); var - cy, m, y, k: integer; + cy, m, y, k: integer; begin - if WebSafe then c := GetWebSafe(c); - ColorToCMYK(c, cy, m, y, k); - FChange := false; - SetCyan(cy); - SetYellow(y); - SetBlack(k); - SetMagenta(m); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + ColorToCMYK(c, cy, m, y, k); + FChange := false; + SetCyan(cy); + SetYellow(y); + SetBlack(k); + SetMagenta(m); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TMColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromMagenta(FMagenta); + Result := ArrowPosFromMagenta(FMagenta); end; procedure TMColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetMagenta(FMagenta); - TBA_Paint: Canvas.StretchDraw(FPickRect, FMBmp); - TBA_MouseMove: FMagenta := MagentaFromArrowPos(FArrowPos); - TBA_MouseDown: FMagenta := MagentaFromArrowPos(FArrowPos); - TBA_MouseUp: FMagenta := MagentaFromArrowPos(FArrowPos); - TBA_WheelUp: SetMagenta(FMagenta + Increment); - TBA_WheelDown: SetMagenta(FMagenta - Increment); - TBA_VKRight: SetMagenta(FMagenta + Increment); - TBA_VKCtrlRight: SetMagenta(255); - TBA_VKLeft: SetMagenta(FMagenta - Increment); - TBA_VKCtrlLeft: SetMagenta(0); - TBA_VKUp: SetMagenta(FMagenta + Increment); - TBA_VKCtrlUp: SetMagenta(255); - TBA_VKDown: SetMagenta(FMagenta - Increment); - TBA_VKCtrlDown: SetMagenta(0); - TBA_RedoBMP: CreateMGradient; - end; + case tbaAction of + TBA_Resize: + SetMagenta(FMagenta); + TBA_MouseMove: + FMagenta := MagentaFromArrowPos(FArrowPos); + TBA_MouseDown: + FMagenta := MagentaFromArrowPos(FArrowPos); + TBA_MouseUp: + FMagenta := MagentaFromArrowPos(FArrowPos); + TBA_WheelUp: + SetMagenta(FMagenta + Increment); + TBA_WheelDown: + SetMagenta(FMagenta - Increment); + TBA_VKRight: + SetMagenta(FMagenta + Increment); + TBA_VKCtrlRight: + SetMagenta(255); + TBA_VKLeft: + SetMagenta(FMagenta - Increment); + TBA_VKCtrlLeft: + SetMagenta(0); + TBA_VKUp: + SetMagenta(FMagenta + Increment); + TBA_VKCtrlUp: + SetMagenta(255); + TBA_VKDown: + SetMagenta(FMagenta - Increment); + TBA_VKCtrlDown: + SetMagenta(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/RColorPicker.pas b/components/mbColorLib/RColorPicker.pas index 7aa5bf7ff..42469c336 100644 --- a/components/mbColorLib/RColorPicker.pas +++ b/components/mbColorLib/RColorPicker.pas @@ -16,27 +16,26 @@ uses mbTrackBarPicker, HTMLColors, Scanlines; type + + { TRColorPicker } + TRColorPicker = class(TmbTrackBarPicker) private FRed, FGreen, FBlue: integer; - FBmp: TBitmap; - function ArrowPosFromRed(r: integer): integer; function RedFromArrowPos(p: integer): integer; function GetSelectedColor: TColor; procedure SetSelectedColor(c: TColor); - procedure CreateRGradient; procedure SetRed(r: integer); procedure SetGreen(g: integer); procedure SetBlue(b: integer); protected - procedure CreateWnd; override; procedure Execute(tbaAction: integer); override; function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; function GetSelectedValue: integer; override; public constructor Create(AOwner: TComponent); override; - destructor Destroy; override; published property Red: integer read FRed write SetRed default 255; property Green: integer read FGreen write SetGreen default 122; @@ -62,36 +61,24 @@ end; constructor TRColorPicker.Create(AOwner: TComponent); begin - inherited; - FBmp := TBitmap.Create; - FBmp.PixelFormat := pf32bit; - FBmp.SetSize(12, 256); - Width := 22; - Height := 268; - Layout := lyVertical; - FRed := 255; - FGreen := 122; - FBlue := 122; - FArrowPos := ArrowPosFromRed(255); - FChange := false; - SetRed(255); - HintFormat := 'Red: %value'; - FManual := false; - FChange := true; -end; - -destructor TRColorPicker.Destroy; -begin - FBmp.Free; - inherited Destroy; -end; - -procedure TRColorPicker.CreateWnd; -begin - inherited; - CreateRGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + Width := 22; + Height := 268; + Layout := lyVertical; + FRed := 255; + FGreen := 122; + FBlue := 122; + FArrowPos := ArrowPosFromRed(255); + FChange := false; + SetRed(255); + HintFormat := 'Red: %value'; + FManual := false; + FChange := true; end; + (* procedure TRColorPicker.CreateRGradient; var i,j: integer; @@ -134,91 +121,93 @@ begin // FBmp.Canvas.Pixels[j, i] := GetWebSafe(RGB(255-i, FGreen, FBlue)); end; end; +end; *) + +function TRColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := RGB(AValue, FGreen, FBlue); end; procedure TRColorPicker.SetRed(r: integer); begin - if r < 0 then r := 0; - if r > 255 then r := 255; - if FRed <> r then + if r < 0 then r := 0; + if r > 255 then r := 255; + if FRed <> r then begin - FRed := r; - FArrowPos := ArrowPosFromRed(r); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FRed := r; + FArrowPos := ArrowPosFromRed(r); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TRColorPicker.SetGreen(g: integer); begin - if g > 255 then g := 255; - if g < 0 then g := 0; - if FGreen <> g then + if g > 255 then g := 255; + if g < 0 then g := 0; + if FGreen <> g then begin - FGreen := g; - FManual := false; - CreateRGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FGreen := g; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TRColorPicker.SetBlue(b: integer); begin - if b > 255 then b := 255; - if b < 0 then b := 0; - if FBlue <> b then + if b > 255 then b := 255; + if b < 0 then b := 0; + if FBlue <> b then begin - FBlue := b; - FManual := false; - CreateRGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FBlue := b; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TRColorPicker.ArrowPosFromRed(r: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*r); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*r); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - r := 255 - r; - a := Round(((Height - 12)/255)*r); - if a > Height - FLimit then a := Height - FLimit; + r := 255 - r; + a := Round(((Height - 12)/255)*r); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TRColorPicker.RedFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/255)) - else - r := Round(255 - p/((Height - 12)/255)); - if r < 0 then r := 0; - if r > 255 then r := 255; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/255)) + else + r := Round(255 - p/((Height - 12)/255)); + if r < 0 then r := 0; + if r > 255 then r := 255; + Result := r; end; function TRColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := RGB(FRed, FGreen, FBlue) - else - Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); + if not WebSafe then + Result := RGB(FRed, FGreen, FBlue) + else + Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); end; function TRColorPicker.GetSelectedValue: integer; @@ -228,41 +217,55 @@ end; procedure TRColorPicker.SetSelectedColor(c: TColor); begin - if WebSafe then c := GetWebSafe(c); - FChange := false; - SetGreen(GetGValue(c)); - SetBlue(GetBValue(c)); - SetRed(GetRValue(c)); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + FChange := false; + SetGreen(GetGValue(c)); + SetBlue(GetBValue(c)); + SetRed(GetRValue(c)); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TRColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromRed(FRed); + Result := ArrowPosFromRed(FRed); end; procedure TRColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetRed(FRed); - TBA_Paint: Canvas.StretchDraw(FPickRect, FBmp); - TBA_MouseMove: FRed := RedFromArrowPos(FArrowPos); - TBA_MouseDown: FRed := RedFromArrowPos(FArrowPos); - TBA_MouseUp: FRed := RedFromArrowPos(FArrowPos); - TBA_WheelUp: SetRed(FRed + Increment); - TBA_WheelDown: SetRed(FRed - Increment); - TBA_VKRight: SetRed(FRed + Increment); - TBA_VKCtrlRight: SetRed(255); - TBA_VKLeft: SetRed(FRed - Increment); - TBA_VKCtrlLeft: SetRed(0); - TBA_VKUp: SetRed(FRed + Increment); - TBA_VKCtrlUp: SetRed(255); - TBA_VKDown: SetRed(FRed - Increment); - TBA_VKCtrlDown: SetRed(0); - TBA_RedoBMP: CreateRGradient; - end; + case tbaAction of + TBA_Resize: + SetRed(FRed); + TBA_MouseMove: + FRed := RedFromArrowPos(FArrowPos); + TBA_MouseDown: + FRed := RedFromArrowPos(FArrowPos); + TBA_MouseUp: + FRed := RedFromArrowPos(FArrowPos); + TBA_WheelUp: + SetRed(FRed + Increment); + TBA_WheelDown: + SetRed(FRed - Increment); + TBA_VKRight: + SetRed(FRed + Increment); + TBA_VKCtrlRight: + SetRed(255); + TBA_VKLeft: + SetRed(FRed - Increment); + TBA_VKCtrlLeft: + SetRed(0); + TBA_VKUp: + SetRed(FRed + Increment); + TBA_VKCtrlUp: + SetRed(255); + TBA_VKDown: + SetRed(FRed - Increment); + TBA_VKCtrlDown: + SetRed(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/RGBHSLUtils.pas b/components/mbColorLib/RGBHSLUtils.pas index f43559790..ff2efa2dd 100644 --- a/components/mbColorLib/RGBHSLUtils.pas +++ b/components/mbColorLib/RGBHSLUtils.pas @@ -165,34 +165,34 @@ end; function HSLToRGBTriple(H, S, L: integer): TRGBTriple; const - Divisor = 255*60; + Divisor = 255*60; var - hTemp, f, LS, p, q, r: integer; + hTemp, f, LS, p, q, r: integer; begin - Clamp(H, 0, MaxHue); - Clamp(S, 0, MaxSat); - Clamp(L, 0, MaxLum); - if (S = 0) then - Result := RGBToRGBTriple(L, L, L) - else + Clamp(H, 0, MaxHue); + Clamp(S, 0, MaxSat); + Clamp(L, 0, MaxLum); + if (S = 0) then + Result := RGBToRGBTriple(L, L, L) + else begin - hTemp := H mod MaxHue; - f := hTemp mod 60; - hTemp := hTemp div 60; - LS := L*S; - p := L - LS div MaxLum; - q := L - (LS*f) div Divisor; - r := L - (LS*(60 - f)) div Divisor; - case hTemp of - 0: Result := RGBToRGBTriple(L, r, p); - 1: Result := RGBToRGBTriple(q, L, p); - 2: Result := RGBToRGBTriple(p, L, r); - 3: Result := RGBToRGBTriple(p, q, L); - 4: Result := RGBToRGBTriple(r, p, L); - 5: Result := RGBToRGBTriple(L, p, q); - else - Result := RGBToRGBTriple(0, 0, 0); - end; + hTemp := H mod MaxHue; + f := hTemp mod 60; + hTemp := hTemp div 60; + LS := L*S; + p := L - LS div MaxLum; + q := L - (LS*f) div Divisor; + r := L - (LS*(60 - f)) div Divisor; + case hTemp of + 0: Result := RGBToRGBTriple(L, r, p); + 1: Result := RGBToRGBTriple(q, L, p); + 2: Result := RGBToRGBTriple(p, L, r); + 3: Result := RGBToRGBTriple(p, q, L); + 4: Result := RGBToRGBTriple(r, p, L); + 5: Result := RGBToRGBTriple(L, p, q); + else + Result := RGBToRGBTriple(0, 0, 0); + end; end; end; diff --git a/components/mbColorLib/SColorPicker.pas b/components/mbColorLib/SColorPicker.pas index 07ddec8aa..db6b4bf0e 100644 --- a/components/mbColorLib/SColorPicker.pas +++ b/components/mbColorLib/SColorPicker.pas @@ -19,24 +19,20 @@ type TSColorPicker = class(TmbTrackBarPicker) private FVal, FHue, FSat: integer; - FSBmp: TBitmap; - function ArrowPosFromSat(s: integer): integer; function SatFromArrowPos(p: integer): integer; function GetSelectedColor: TColor; procedure SetSelectedColor(c: TColor); - procedure CreateSGradient; procedure SetHue(h: integer); procedure SetSat(s: integer); procedure SetValue(v: integer); protected - procedure CreateWnd; override; procedure Execute(tbaAction: integer); override; function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; function GetSelectedValue: integer; override; public constructor Create(AOwner: TComponent); override; - destructor Destroy; override; published property Hue: integer read FHue write SetHue default 0; property Saturation: integer read FSat write SetSat default 255; @@ -61,33 +57,22 @@ end; constructor TSColorPicker.Create(AOwner: TComponent); begin - inherited; - FSBmp := TBitmap.Create; - FSBmp.PixelFormat := pf32bit; - Width := 267; - Height := 22; - FHue := 0; - FVal := 255; - FArrowPos := ArrowPosFromSat(0); - FChange := false; - SetSat(255); - HintFormat := 'Saturation: %value'; - FManual := false; - FChange := true; -end; - -destructor TSColorPicker.Destroy; -begin - FSBmp.Free; - inherited Destroy; -end; - -procedure TSColorPicker.CreateWnd; -begin - inherited; - CreateSGradient; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + Width := 267; + Height := 22; + FHue := 0; + FVal := 255; + FArrowPos := ArrowPosFromSat(0); + FChange := false; + SetSat(255); + HintFormat := 'Saturation: %value'; + FManual := false; + FChange := true; end; +(* procedure TSColorPicker.CreateSGradient; var i,j: integer; @@ -131,90 +116,93 @@ begin end; end; end; + *) + +function TSColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := HSVtoColor(FHue, AValue, FVal); +end; procedure TSColorPicker.SetValue(v: integer); begin - if v < 0 then v := 0; - if v > 255 then v := 255; - if FVal <> v then + if v < 0 then v := 0; + if v > 255 then v := 255; + if FVal <> v then begin - FVal := v; - FManual := false; - CreateSGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FVal := v; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TSColorPicker.SetHue(h: integer); begin - if h > 360 then h := 360; - if h < 0 then h := 0; - if FHue <> h then + if h > 360 then h := 360; + if h < 0 then h := 0; + if FHue <> h then begin - FHue := h; - CreateSGradient; - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FHue := h; + CreateGradient; + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TSColorPicker.SetSat(s: integer); begin - if s > 255 then s := 255; - if s < 0 then s := 0; - if FSat <> s then + if s > 255 then s := 255; + if s < 0 then s := 0; + if FSat <> s then begin - FSat := s; - FManual := false; - FArrowPos := ArrowPosFromSat(s); - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FSat := s; + FManual := false; + FArrowPos := ArrowPosFromSat(s); + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TSColorPicker.ArrowPosFromSat(s: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*s); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*s); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - s := 255 - s; - a := Round(((Height - 12)/255)*s); - if a > Height - FLimit then a := Height - FLimit; + s := 255 - s; + a := Round(((Height - 12)/255)*s); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TSColorPicker.SatFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/255)) - else - r := Round(255 - p/((Height - 12)/255)); - if r < 0 then r := 0; - if r > 255 then r := 255; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/255)) + else + r := Round(255 - p/((Height - 12)/255)); + if r < 0 then r := 0; + if r > 255 then r := 255; + Result := r; end; function TSColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := HSVtoColor(FHue, FSat, FVal) - else - Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FVal) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); end; function TSColorPicker.GetSelectedValue: integer; @@ -224,44 +212,58 @@ end; procedure TSColorPicker.SetSelectedColor(c: TColor); var - h, s, v: integer; + h, s, v: integer; begin - if WebSafe then c := GetWebSafe(c); - RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); - FChange := false; - SetHue(h); - SetSat(s); - SetValue(v); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); + FChange := false; + SetHue(h); + SetSat(s); + SetValue(v); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TSColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromSat(FSat); + Result := ArrowPosFromSat(FSat); end; procedure TSColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetSat(FSat); - TBA_Paint: Canvas.StretchDraw(FPickRect, FSBmp); - TBA_MouseMove: FSat := SatFromArrowPos(FArrowPos); - TBA_MouseDown: FSat := SatFromArrowPos(FArrowPos); - TBA_MouseUp: FSat := SatFromArrowPos(FArrowPos); - TBA_WheelUp: SetSat(FSat + Increment); - TBA_WheelDown: SetSat(FSat - Increment); - TBA_VKLeft: SetSat(FSat - Increment); - TBA_VKCtrlLeft: SetSat(0); - TBA_VKRight: SetSat(FSat + Increment); - TBA_VKCtrlRight: SetSat(255); - TBA_VKUp: SetSat(FSat + Increment); - TBA_VKCtrlUp: SetSat(255); - TBA_VKDown: SetSat(FSat - Increment); - TBA_VKCtrlDown: SetSat(0); - TBA_RedoBMP: CreateSGradient; - end; + case tbaAction of + TBA_Resize: + SetSat(FSat); + TBA_MouseMove: + FSat := SatFromArrowPos(FArrowPos); + TBA_MouseDown: + FSat := SatFromArrowPos(FArrowPos); + TBA_MouseUp: + FSat := SatFromArrowPos(FArrowPos); + TBA_WheelUp: + SetSat(FSat + Increment); + TBA_WheelDown: + SetSat(FSat - Increment); + TBA_VKLeft: + SetSat(FSat - Increment); + TBA_VKCtrlLeft: + SetSat(0); + TBA_VKRight: + SetSat(FSat + Increment); + TBA_VKCtrlRight: + SetSat(255); + TBA_VKUp: + SetSat(FSat + Increment); + TBA_VKCtrlUp: + SetSat(255); + TBA_VKDown: + SetSat(FSat - Increment); + TBA_VKCtrlDown: + SetSat(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/SLColorPicker.pas b/components/mbColorLib/SLColorPicker.pas index f11f86b66..d6bf6618a 100644 --- a/components/mbColorLib/SLColorPicker.pas +++ b/components/mbColorLib/SLColorPicker.pas @@ -65,6 +65,9 @@ implementation {$IFDEF FPC} {$R SLColorPicker.dcr} + +uses + IntfGraphics, fpimage; {$ENDIF} procedure Register; @@ -96,35 +99,98 @@ begin inherited; end; +//{$IFDEF DELPHI} procedure TSLColorPicker.CreateSLGradient; var - x, y, skip: integer; - row: pRGBQuadArray; - tc: TColor; + x, y, skip: integer; + row: pRGBQuadArray; + c: TColor; + {$IFDEF FPC} + intfimg: TLazIntfImage; + imgHandle, imgMaskHandle: HBitmap; + {$ENDIF} begin - if FBMP = nil then + if FBmp = nil then begin - FBMP := TBitmap.Create; - FBMP.PixelFormat := pf32bit; - FBMP.Width := 256; - FBMP.Height := 256; - end; - row := FBMP.ScanLine[0]; - skip := integer(FBMP.ScanLine[1]) - Integer(row); - for y := 0 to 255 do - begin - for x := 0 to 255 do - if not WebSafe then - row[x] := HSLtoRGBQuad(FHue, x, 255 - y) - else - begin - tc := GetWebSafe(RGBTripleToTColor(HSLToRGBTriple(FHue, x, 255 - y))); - row[x] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc)); - end; - row := pRGBQuadArray(Integer(row) + skip); + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.Width := 256; + FBmp.Height := 256; end; + + {$IFDEF FPC} + intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height); + try + intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle); + {$ENDIF} + { + row := FBMP.ScanLine[0]; + skip := integer(FBMP.ScanLine[1]) - Integer(row); + } + for y := 0 to 255 do + begin + {$IFDEF FPC} + row := intfImg.GetDataLineStart(y); + {$ELSE} + row := FHSVBmp.Scanline(y); + {$ENDIF} + + for x := 0 to 255 do + if not WebSafe then + row[x] := HSLtoRGBQuad(FHue, x, 255 - y) + else + begin + c := GetWebSafe(RGBTripleToTColor(HSLToRGBTriple(FHue, x, 255 - y))); + row[x] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c)); + end; +// row := pRGBQuadArray(Integer(row) + skip); + end; + {$IFDEF FPC} + intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false); + FBmp.Handle := imgHandle; + FBmp.MaskHandle := imgMaskHandle; + finally + intfimg.Free; + end; + {$ENDIF} end; + (* +{$ELSE} +procedure TSLColorPicker.CreateSLGradient; +var + x, y: Integer; + c: TColor; + intfimg: TLazIntfImage; + imgHandle, imgMaskHandle: HBitmap; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32Bit; + FBmp.Width := 256; + FBmp.Height := 256; + end; + intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height); + try + intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle); + for y := 0 to 255 do // y = L + for x := 0 to 255 do // x = S + begin + c := HSLRangeToRGB(FHue, x, 255-y); + if WebSafe then + c := GetWebSafe(c); + intfImg.Colors[x, y] := TColorToFPColor(c); + end; + intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false); + FBmp.Handle := imgHandle; + FBmp.MaskHandle := imgMaskHandle; + finally + intfimg.Free; + end; +end; +{$ENDIF} + *) procedure TSLColorPicker.Resize; begin inherited; diff --git a/components/mbColorLib/SLHColorPicker.pas b/components/mbColorLib/SLHColorPicker.pas index c5699c45a..3ec206928 100644 --- a/components/mbColorLib/SLHColorPicker.pas +++ b/components/mbColorLib/SLHColorPicker.pas @@ -16,10 +16,10 @@ uses {$ENDIF} SysUtils, Classes, Controls, Graphics, Forms, RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus, - {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors; + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, mbBasicPicker; type - TSLHColorPicker = class(TCustomControl) + TSLHColorPicker = class(TmbBasicPicker) private FOnChange: TNotifyEvent; FSLPicker: TSLColorPicker; @@ -46,13 +46,11 @@ type procedure SetHMenu(m: TPopupMenu); procedure SetHCursor(c: TCursor); procedure SetSLCursor(c: TCursor); - procedure PaintParentBack; protected procedure CreateWnd; override; procedure Resize; override; procedure Paint; override; - procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); - message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; + procedure PaintParentBack; override; procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF}; procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); @@ -117,59 +115,70 @@ end; constructor TSLHColorPicker.Create(AOwner: TComponent); begin - inherited; - ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; - DoubleBuffered := true; - PBack := TBitmap.Create; - PBack.PixelFormat := pf32bit; - ParentColor := true; + inherited; + ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; + DoubleBuffered := true; + PBack := TBitmap.Create; + PBack.PixelFormat := pf32bit; + ParentColor := true; {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} - ParentBackground := true; + ParentBackground := true; {$ENDIF}{$ENDIF} - Width := 297; - Height := 271; - TabStop := true; - FSelectedColor := clRed; - FHPicker := THColorPicker.Create(Self); - InsertControl(FHPicker); - FHCursor := crDefault; - FSLCursor := crDefault; - with FHPicker do + SetInitialBounds(0, 0, 297, 271); +// Width := 297; +// Height := 271; + TabStop := true; + FSelectedColor := clRed; + FHPicker := THColorPicker.Create(Self); + InsertControl(FHPicker); + FHCursor := crDefault; + FSLCursor := crDefault; + + // Hue picker + with FHPicker do begin - Height := 271; - Width := 40; - Top := 0; - Left := 257; - Anchors := [akTop, akRight, akBottom]; - Visible := true; - Layout := lyVertical; - ArrowPlacement := spBoth; - NewArrowStyle := true; - OnChange := HPickerChange; - OnMouseMove := DoMouseMove; + SetInitialBounds(257, 0, 40, 271); + { + Height := 271; + Width := 40; + Top := 0; + Left := 257; + } + Anchors := [akTop, akRight, akBottom]; + Visible := true; + Layout := lyVertical; + ArrowPlacement := spBoth; + NewArrowStyle := true; + OnChange := HPickerChange; + OnMouseMove := DoMouseMove; end; - FSLPicker := TSLColorPicker.Create(Self); - InsertControl(FSLPicker); - with FSLPicker do + + // Saturation-Lightness picker + FSLPicker := TSLColorPicker.Create(Self); + InsertControl(FSLPicker); + with FSLPicker do begin - Width := 255; - Height := 255; - Top := 8; - Left := 0; - Anchors := [akRight, akTop, akBottom, akLeft]; - Visible := true; - SelectedColor := clRed; - OnChange := SLPickerChange; - OnMouseMove := DoMouseMove; + SetInitialBounds(0, 0, 255, 271); + { + Width := 255; + Height := 271; //255; + Top := 0; //8; + Left := 0; + } + Anchors := [akLeft, akRight, akTop, akBottom]; + Visible := true; + SelectedColor := clRed; + OnChange := SLPickerChange; + OnMouseMove := DoMouseMove; end; - FHValue := 0; - FSValue := 255; - FLValue := 255; - FRValue := 255; - FGValue := 0; - FBValue := 0; - FHHint := 'Hue: %h'; - FSLHint := 'S: %hslS L: %l'#13'Hex: %hex'; + FHValue := 0; + FSValue := 255; + FLValue := 255; + FRValue := 255; + FGValue := 0; + FBValue := 0; + FHHint := 'Hue: %h'; + FSLHint := 'S: %hslS L: %l'#13'Hex: %hex'; end; destructor TSLHColorPicker.Destroy; @@ -182,8 +191,8 @@ end; procedure TSLHColorPicker.HPickerChange(Sender: TObject); begin - FSLPicker.Hue := FHPicker.Hue; - DoChange; + FSLPicker.Hue := FHPicker.Hue; + DoChange; end; procedure TSLHColorPicker.SLPickerChange(Sender: TObject); @@ -320,48 +329,37 @@ end; procedure TSLHColorPicker.Resize; begin - inherited; - PaintParentBack; + inherited; + PaintParentBack; + + if FSLPicker = nil then + exit; + if FHPicker = nil then + exit; + + FSLPicker.Width := Width - FHPicker.Width - 10; + FSLPicker.Height := Height - 2; + + FHPicker.Left := Width - FHPicker.Width - 2; + FHPicker.Height := Height - 2; end; procedure TSLHColorPicker.PaintParentBack; -{$IFDEF DELPHI_7_UP} -var - MemDC: HDC; - OldBMP: HBITMAP; -{$ENDIF} begin - if PBack = nil then + if PBack = nil then begin - PBack := TBitmap.Create; - PBack.PixelFormat := pf32bit; + PBack := TBitmap.Create; + PBack.PixelFormat := pf32bit; end; - PBack.Width := Width; - PBack.Height := Height; - {$IFDEF FPC} - if Color = clDefault then - PBack.Canvas.Brush.Color := clForm else - {$ENDIF} - PBack.Canvas.Brush.Color := Color; - PBack.Canvas.FillRect(PBack.Canvas.ClipRect); - {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} - if ParentBackground then - with ThemeServices do - if ThemesEnabled then - begin - MemDC := CreateCompatibleDC(0); - OldBMP := SelectObject(MemDC, PBack.Handle); - DrawParentBackground(Handle, MemDC, nil, False); - if OldBMP <> 0 then SelectObject(MemDC, OldBMP); - if MemDC <> 0 then DeleteDC(MemDC); - end; - {$ENDIF}{$ENDIF} + PBack.Width := Width; + PBack.Height := Height; + PaintParentBack(PBack); end; procedure TSLHColorPicker.Paint; begin - PaintParentBack; - Canvas.Draw(0, 0, PBack); + PaintParentBack; + Canvas.Draw(0, 0, PBack); end; procedure TSLHColorPicker.CreateWnd; @@ -370,10 +368,4 @@ begin PaintParentBack; end; -procedure TSLHColorPicker.WMEraseBkgnd( - var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF} ); -begin - Message.Result := 1; -end; - end. diff --git a/components/mbColorLib/Scanlines.pas b/components/mbColorLib/Scanlines.pas index 9a10ceb37..829ac1187 100644 --- a/components/mbColorLib/Scanlines.pas +++ b/components/mbColorLib/Scanlines.pas @@ -7,16 +7,19 @@ unit Scanlines; interface uses - {$IFDEF FPC}LCLIntf, LCLType, - {$ELSE}Windows, - {$ENDIF} - Graphics; + {$IFDEF FPC} + LCLIntf, LCLType, + {$ELSE} + Windows, + {$ENDIF} + Graphics; type - TRGBTripleArray = array [0..65535] of TRGBTriple; - pRGBTripleArray = ^TRGBTripleArray; - TRGBQuadArray = array [0..65535] of TRGBQuad; - pRGBQuadArray = ^TRGBQuadArray; + TRGBTripleArray = array [0..65535] of TRGBTriple; + pRGBTripleArray = ^TRGBTripleArray; + + TRGBQuadArray = array [0..65535] of TRGBQuad; + pRGBQuadArray = ^TRGBQuadArray; function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload; @@ -28,44 +31,44 @@ implementation function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; begin - with Result do + with Result do begin - rgbtRed := R; - rgbtGreen := G; - rgbtBlue := B; + rgbtRed := R; + rgbtGreen := G; + rgbtBlue := B; end end; function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload; begin - with Result do + with Result do begin - rgbRed := R; - rgbGreen := G; - rgbBlue := B; - rgbReserved := 0; + rgbRed := R; + rgbGreen := G; + rgbBlue := B; + rgbReserved := 0; end end; function RGBToRGBQuad(c: TColor): TRGBQuad; overload; begin - with Result do + with Result do begin - rgbRed := GetRValue(c); - rgbGreen := GetGValue(c); - rgbBlue := GetBValue(c); - rgbReserved := 0 + rgbRed := GetRValue(c); + rgbGreen := GetGValue(c); + rgbBlue := GetBValue(c); + rgbReserved := 0 end; end; function RGBQuadToRGB(q: TRGBQuad): TColor; begin - Result := RGB(q.rgbRed, q.rgbGreen, q.rgbBlue); + Result := RGB(q.rgbRed, q.rgbGreen, q.rgbBlue); end; function RGBTripleToTColor(RGBTriple: TRGBTriple): TColor; begin - Result := RGBTriple.rgbtBlue shl 16 + RGBTriple.rgbtGreen shl 8 + RGBTriple.rgbtRed; + Result := RGBTriple.rgbtBlue shl 16 + RGBTriple.rgbtGreen shl 8 + RGBTriple.rgbtRed; end; end. diff --git a/components/mbColorLib/VColorPicker.pas b/components/mbColorLib/VColorPicker.pas index 05ae87442..eecbbbe30 100644 --- a/components/mbColorLib/VColorPicker.pas +++ b/components/mbColorLib/VColorPicker.pas @@ -7,43 +7,43 @@ interface {$ENDIF} uses - {$IFDEF FPC} - LCLIntf, LCLType, LMessages, - {$ELSE} - Windows, Messages, - {$ENDIF} - SysUtils, Classes, Controls, Forms, Graphics, - RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Forms, Graphics, + RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; type - TVColorPicker = class(TmbTrackBarPicker) - private - FHue, FSat, FVal: integer; - FVBmp: TBitmap; + TVColorPicker = class(TmbTrackBarPicker) + private + FHue, FSat, FVal: integer; + // FVBmp: TBitmap; - function ArrowPosFromVal(l: integer): integer; - function ValFromArrowPos(p: integer): integer; - function GetSelectedColor: TColor; - procedure SetSelectedColor(c: TColor); - procedure CreateVGradient; - procedure SetHue(h: integer); - procedure SetSat(s: integer); - procedure SetValue(v: integer); - protected - procedure CreateWnd; override; - procedure Execute(tbaAction: integer); override; - function GetArrowPos: integer; override; - function GetSelectedValue: integer; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Hue: integer read FHue write SetHue default 0; - property Saturation: integer read FSat write SetSat default 0; - property Value: integer read FVal write SetValue default 255; - property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; - property Layout default lyVertical; - end; + function ArrowPosFromVal(l: integer): integer; + function ValFromArrowPos(p: integer): integer; + function GetSelectedColor: TColor; + procedure SetSelectedColor(c: TColor); +// procedure CreateVGradient; + procedure SetHue(h: integer); + procedure SetSat(s: integer); + procedure SetValue(v: integer); + protected + procedure Execute(tbaAction: integer); override; + function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; + function GetSelectedValue: integer; override; + public + constructor Create(AOwner: TComponent); override; +// destructor Destroy; override; + published + property Hue: integer read FHue write SetHue default 0; + property Saturation: integer read FSat write SetSat default 0; + property Value: integer read FVal write SetValue default 255; + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; + property Layout default lyVertical; + end; procedure Register; @@ -51,173 +51,127 @@ implementation {$IFDEF FPC} {$R VColorPicker.dcr} + +{uses + IntfGraphics, fpimage;} {$ENDIF} procedure Register; begin - RegisterComponents('mbColor Lib', [TVColorPicker]); + RegisterComponents('mbColor Lib', [TVColorPicker]); end; {TVColorPicker} constructor TVColorPicker.Create(AOwner: TComponent); begin - inherited; - FVBmp := TBitmap.Create; - FVBmp.PixelFormat := pf32bit; - FVBmp.SetSize(12, 255); - Width := 22; - Height := 267; - Layout := lyVertical; - FHue := 0; - FSat := 0; - FArrowPos := ArrowPosFromVal(255); - FChange := false; - SetValue(255); - HintFormat := 'Value: %value'; - FManual := false; - FChange := true; + inherited; + FGradientWidth := 256; + FGradientHeight := 12; + { + FVBmp := TBitmap.Create; + FVBmp.PixelFormat := pf32bit; + FVBmp.SetSize(12, 255); + } +// Width := 22; +// Height := 267; + SetInitialBounds(0, 0, 22, 267); + Layout := lyVertical; + FHue := 0; + FSat := 0; + FArrowPos := ArrowPosFromVal(255); + FChange := false; + SetValue(255); + HintFormat := 'Value: %value'; + FManual := false; + FChange := true; end; -destructor TVColorPicker.Destroy; +function TVColorPicker.GetGradientColor(AValue: Integer): TColor; begin - FVBmp.Free; - inherited Destroy; -end; - -procedure TVColorPicker.CreateWnd; -begin - inherited; - CreateVGradient; -end; - -procedure TVColorPicker.CreateVGradient; -var - i,j: integer; - row: pRGBQuadArray; -begin - if FVBmp = nil then - begin - FVBmp := TBitmap.Create; - FVBmp.PixelFormat := pf32bit; - end; - if Layout = lyHorizontal then - begin - FVBmp.width := 255; - FVBmp.height := 12; - for i := 0 to 254 do - for j := 0 to 11 do - begin - row := FVBmp.Scanline[j]; - if not WebSafe then - row[i] := RGBToRGBQuad(HSVtoColor(FHue, FSat, i)) -// FVBmp.Canvas.Pixels[i, j] := HSVtoColor(FHue, FSat, i) - else - row[i] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, FSat, i))); -// FVBmp.Canvas.Pixels[i, j] := GetWebSafe(HSVtoColor(FHue, FSat, i)); - end; - end - else - begin - FVBmp.width := 12; - FVBmp.height := 255; - for i := 0 to 254 do - begin - row := FVBmp.ScanLine[i]; - for j := 0 to 11 do - if not WebSafe then - row[j] := RGBToRGBQuad(HSVtoColor(FHue, FSat, 255 - i)) -// FVBmp.Canvas.Pixels[j, i] := HSVtoColor(FHue, FSat, 255 - i) - else - row[j] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, FSat, 255 - i))); -// FVBmp.Canvas.Pixels[j, i] := GetWebSafe(HSVtoColor(FHue, FSat, 255 - i)); - end; - end; + Result := HSVtoColor(FHue, FSat, AValue); end; procedure TVColorPicker.SetHue(h: integer); begin - if h > 360 then h := 360; - if h < 0 then h := 0; - if FHue <> h then + if h > 360 then h := 360; + if h < 0 then h := 0; + if FHue <> h then begin - FHue := h; - FManual := false; - CreateVGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FHue := h; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TVColorPicker.SetSat(s: integer); begin - if s > 255 then s := 255; - if s < 0 then s := 0; - if FSat <> s then + if s > 255 then s := 255; + if s < 0 then s := 0; + if FSat <> s then begin - FSat := s; - FManual := false; - CreateVGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FSat := s; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TVColorPicker.ArrowPosFromVal(l: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*l); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*l); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - l := 255 - l; - a := Round(((Height - 12)/255)*l); - if a > Height - FLimit then a := Height - FLimit; + l := 255 - l; + a := Round(((Height - 12)/255)*l); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TVColorPicker.ValFromArrowPos(p: integer): integer; var - r: integer; + r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/255)) - else - r := Round(255 - p/((Height - 12)/255)); - if r < 0 then r := 0; - if r > 255 then r := 255; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/255)) + else + r := Round(255 - p/((Height - 12)/255)); + if r < 0 then r := 0; + if r > 255 then r := 255; + Result := r; end; procedure TVColorPicker.SetValue(V: integer); begin - if v < 0 then v := 0; - if v > 255 then v := 255; - if FVal <> v then + if v < 0 then v := 0; + if v > 255 then v := 255; + if FVal <> v then begin - FVal := v; - FArrowPos := ArrowPosFromVal(v); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FVal := v; + FArrowPos := ArrowPosFromVal(v); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TVColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := HSVtoColor(FHue, FSat, FVal) - else - Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FVal) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); end; function TVColorPicker.GetSelectedValue: integer; @@ -227,44 +181,58 @@ end; procedure TVColorPicker.SetSelectedColor(c: TColor); var - h, s, v: integer; + h, s, v: integer; begin - if WebSafe then c := GetWebSafe(c); - RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); - FChange := false; - SetHue(h); - SetSat(s); - SetValue(v); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); + FChange := false; + SetHue(h); + SetSat(s); + SetValue(v); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TVColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromVal(FVal); + Result := ArrowPosFromVal(FVal); end; procedure TVColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetValue(FVal); - TBA_Paint: Canvas.StretchDraw(FPickRect, FVBmp); - TBA_MouseMove: FVal := ValFromArrowPos(FArrowPos); - TBA_MouseDown: FVal := ValFromArrowPos(FArrowPos); - TBA_MouseUp: FVal := ValFromArrowPos(FArrowPos); - TBA_WheelUp: SetValue(FVal + Increment); - TBA_WheelDown: SetValue(FVal - Increment); - TBA_VKRight: SetValue(FVal + Increment); - TBA_VKCtrlRight: SetValue(255); - TBA_VKLeft: SetValue(FVal - Increment); - TBA_VKCtrlLeft: SetValue(0); - TBA_VKUp: SetValue(FVal + Increment); - TBA_VKCtrlUp: SetValue(255); - TBA_VKDown: SetValue(FVal - Increment); - TBA_VKCtrlDown: SetValue(0); - TBA_RedoBMP: CreateVGradient; - end; + case tbaAction of + TBA_Resize: + SetValue(FVal); + TBA_MouseMove: + FVal := ValFromArrowPos(FArrowPos); + TBA_MouseDown: + FVal := ValFromArrowPos(FArrowPos); + TBA_MouseUp: + FVal := ValFromArrowPos(FArrowPos); + TBA_WheelUp: + SetValue(FVal + Increment); + TBA_WheelDown: + SetValue(FVal - Increment); + TBA_VKRight: + SetValue(FVal + Increment); + TBA_VKCtrlRight: + SetValue(255); + TBA_VKLeft: + SetValue(FVal - Increment); + TBA_VKCtrlLeft: + SetValue(0); + TBA_VKUp: + SetValue(FVal + Increment); + TBA_VKCtrlUp: + SetValue(255); + TBA_VKDown: + SetValue(FVal - Increment); + TBA_VKCtrlDown: + SetValue(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/YColorPicker.pas b/components/mbColorLib/YColorPicker.pas index c4179b16f..6a8b90a7e 100644 --- a/components/mbColorLib/YColorPicker.pas +++ b/components/mbColorLib/YColorPicker.pas @@ -19,25 +19,22 @@ type TYColorPicker = class(TmbTrackBarPicker) private FYellow, FMagenta, FCyan, FBlack: integer; - FYBmp: TBitmap; function ArrowPosFromYellow(y: integer): integer; function YellowFromArrowPos(p: integer): integer; function GetSelectedColor: TColor; procedure SetSelectedColor(c: TColor); - procedure CreateYGradient; procedure SetYellow(y: integer); procedure SetMagenta(m: integer); procedure SetCyan(c: integer); procedure SetBlack(k: integer); protected - procedure CreateWnd; override; procedure Execute(tbaAction: integer); override; function GetArrowPos: integer; override; + function GetGradientColor(AValue: Integer): TColor; override; function GetSelectedValue: integer; override; public constructor Create(AOwner: TComponent); override; - destructor Destroy; override; published property Yellow: integer read FYellow write SetYellow default 255; property Magenta: integer read FMagenta write SetMagenta default 0; @@ -64,37 +61,26 @@ end; constructor TYColorPicker.Create(AOwner: TComponent); begin - inherited; - FYBmp := TBitmap.Create; - FYBmp.PixelFormat := pf32bit; - FYBmp.SetSize(12, 255); - Width := 22; - Height := 267; - Layout := lyVertical; - FYellow := 255; - FMagenta := 0; - FCyan := 0; - FBlack := 0; - FArrowPos := ArrowPosFromYellow(255); - FChange := false; - SetYellow(255); - HintFormat := 'Yellow: %value'; - FManual := false; - FChange := true; + inherited; + FGradientWidth := 255; + FGradientHeight := 12; + Width := 22; + Height := 267; + Layout := lyVertical; + FYellow := 255; + FMagenta := 0; + FCyan := 0; + FBlack := 0; + FArrowPos := ArrowPosFromYellow(255); + FChange := false; + SetYellow(255); + HintFormat := 'Yellow: %value'; + FManual := false; + FChange := true; end; -destructor TYColorPicker.Destroy; -begin - FYBmp.Free; - inherited Destroy; -end; - -procedure TYColorPicker.CreateWnd; -begin - inherited; - CreateYGradient; -end; +(* procedure TYColorPicker.CreateYGradient; var i,j: integer; @@ -138,105 +124,107 @@ begin end; end; end; +*) + +function TYColorPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := CMYKtoTColor(FCyan, FMagenta, AValue, FBlack); +end; procedure TYColorPicker.SetYellow(y: integer); begin - if y < 0 then y := 0; - if y > 255 then y := 255; - if FYellow <> y then + if y < 0 then y := 0; + if y > 255 then y := 255; + if FYellow <> y then begin - FYellow := y; - FArrowPos := ArrowPosFromYellow(y); - FManual := false; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FYellow := y; + FArrowPos := ArrowPosFromYellow(y); + FManual := false; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TYColorPicker.SetMagenta(m: integer); begin - if m > 255 then m := 255; - if m < 0 then m := 0; - if FMagenta <> m then + if m > 255 then m := 255; + if m < 0 then m := 0; + if FMagenta <> m then begin - FMagenta := m; - FManual := false; - CreateYGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FMagenta := m; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TYColorPicker.SetCyan(c: integer); begin - if c > 255 then c := 255; - if c < 0 then c := 0; - if FCyan <> c then + if c > 255 then c := 255; + if c < 0 then c := 0; + if FCyan <> c then begin - FCyan := c; - FManual := false; - CreateYGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FCyan := c; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; procedure TYColorPicker.SetBlack(k: integer); begin - if k > 255 then k := 255; - if k < 0 then k := 0; - if FBlack <> k then + if k > 255 then k := 255; + if k < 0 then k := 0; + if FBlack <> k then begin - FBlack := k; - FManual := false; - CreateYGradient; - Invalidate; - if FChange then - if Assigned(OnChange) then OnChange(Self); + FBlack := k; + FManual := false; + CreateGradient; + Invalidate; + if FChange and Assigned(OnChange) then OnChange(Self); end; end; function TYColorPicker.ArrowPosFromYellow(y: integer): integer; var - a: integer; + a: integer; begin - if Layout = lyHorizontal then + if Layout = lyHorizontal then begin - a := Round(((Width - 12)/255)*y); - if a > Width - FLimit then a := Width - FLimit; + a := Round(((Width - 12)/255)*y); + if a > Width - FLimit then a := Width - FLimit; end - else + else begin - y := 255 - y; - a := Round(((Height - 12)/255)*y); - if a > Height - FLimit then a := Height - FLimit; + y := 255 - y; + a := Round(((Height - 12)/255)*y); + if a > Height - FLimit then a := Height - FLimit; end; - if a < 0 then a := 0; - Result := a; + if a < 0 then a := 0; + Result := a; end; function TYColorPicker.YellowFromArrowPos(p: integer): integer; var r: integer; begin - if Layout = lyHorizontal then - r := Round(p/((Width - 12)/255)) - else - r := Round(255 - p/((Height - 12)/255)); - if r < 0 then r := 0; - if r > 255 then r := 255; - Result := r; + if Layout = lyHorizontal then + r := Round(p/((Width - 12)/255)) + else + r := Round(255 - p/((Height - 12)/255)); + if r < 0 then r := 0; + if r > 255 then r := 255; + Result := r; end; function TYColorPicker.GetSelectedColor: TColor; begin - if not WebSafe then - Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) - else - Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); end; function TYColorPicker.GetSelectedValue: integer; @@ -246,45 +234,59 @@ end; procedure TYColorPicker.SetSelectedColor(c: TColor); var - cy, m, y, k: integer; + cy, m, y, k: integer; begin - if WebSafe then c := GetWebSafe(c); - ColorToCMYK(c, cy, m, y, k); - FChange := false; - SetMagenta(m); - SetCyan(cy); - SetBlack(k); - SetYellow(y); - FManual := false; - FChange := true; - if Assigned(OnChange) then OnChange(Self); + if WebSafe then c := GetWebSafe(c); + ColorToCMYK(c, cy, m, y, k); + FChange := false; + SetMagenta(m); + SetCyan(cy); + SetBlack(k); + SetYellow(y); + FManual := false; + FChange := true; + if Assigned(OnChange) then OnChange(Self); end; function TYColorPicker.GetArrowPos: integer; begin - Result := ArrowPosFromYellow(FYellow); + Result := ArrowPosFromYellow(FYellow); end; procedure TYColorPicker.Execute(tbaAction: integer); begin - case tbaAction of - TBA_Resize: SetYellow(FYellow); - TBA_Paint: Canvas.StretchDraw(FPickRect, FYBmp); - TBA_MouseMove: FYellow := YellowFromArrowPos(FArrowPos); - TBA_MouseDown: FYellow := YellowFromArrowPos(FArrowPos); - TBA_MouseUp: FYellow := YellowFromArrowPos(FArrowPos); - TBA_WheelUp: SetYellow(FYellow + Increment); - TBA_WheelDown: SetYellow(FYellow - Increment); - TBA_VKRight: SetYellow(FYellow + Increment); - TBA_VKCtrlRight: SetYellow(255); - TBA_VKLeft: SetYellow(FYellow - Increment); - TBA_VKCtrlLeft: SetYellow(0); - TBA_VKUp: SetYellow(FYellow + Increment); - TBA_VKCtrlUp: SetYellow(255); - TBA_VKDown: SetYellow(FYellow - Increment); - TBA_VKCtrlDown: SetYellow(0); - TBA_RedoBMP: CreateYGradient; - end; + case tbaAction of + TBA_Resize: + SetYellow(FYellow); + TBA_MouseMove: + FYellow := YellowFromArrowPos(FArrowPos); + TBA_MouseDown: + FYellow := YellowFromArrowPos(FArrowPos); + TBA_MouseUp: + FYellow := YellowFromArrowPos(FArrowPos); + TBA_WheelUp: + SetYellow(FYellow + Increment); + TBA_WheelDown: + SetYellow(FYellow - Increment); + TBA_VKRight: + SetYellow(FYellow + Increment); + TBA_VKCtrlRight: + SetYellow(255); + TBA_VKLeft: + SetYellow(FYellow - Increment); + TBA_VKCtrlLeft: + SetYellow(0); + TBA_VKUp: + SetYellow(FYellow + Increment); + TBA_VKCtrlUp: + SetYellow(255); + TBA_VKDown: + SetYellow(FYellow - Increment); + TBA_VKCtrlDown: + SetYellow(0); + else + inherited; + end; end; end. diff --git a/components/mbColorLib/mbBasicPicker.pas b/components/mbColorLib/mbBasicPicker.pas new file mode 100644 index 000000000..18cac25b6 --- /dev/null +++ b/components/mbColorLib/mbBasicPicker.pas @@ -0,0 +1,111 @@ +unit mbBasicPicker; + +{$mode objfpc}{$H+} + +interface + +uses + {$IFDEF FPC} + LMessages, + {$ELSE} + Messages, + {$ENDIF} + Classes, SysUtils, Graphics, Controls; + +type + TmbBasicPicker = class(TCustomControl) + protected + procedure PaintParentBack; virtual; overload; + procedure PaintParentBack(ACanvas: TCanvas); overload; + procedure PaintParentBack(ABitmap: TBitmap); overload; + {$IFDEF DELPHI} + procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED; + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + {$ELSE} + procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED; + procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; + {$ENDIF} + public + constructor Create(AOwner: TComponent); override; + function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override; + published + property ParentColor default true; + end; + + +implementation + +constructor TmbBasicPicker.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := ControlStyle - [csOpaque]; + ParentColor := true; +end; + +procedure TmbBasicPicker.CMParentColorChanged(var Message: TLMessage); +begin + if ParentColor then + ControlStyle := ControlStyle - [csOpaque] + else + ControlStyle := ControlStyle + [csOpaque]; + inherited; +end; + +function TmbBasicPicker.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; +begin + result := inherited GetDefaultColor(DefaultColorType); +end; + +procedure TmbBasicPicker.PaintParentBack; +begin + PaintParentBack(Canvas); +end; + +procedure TmbBasicPicker.PaintParentBack(ABitmap: TBitmap); +begin + {$IFNDEF DELPHI} + if Color = clDefault then + ABitmap.Canvas.Brush.Color := GetDefaultColor(dctBrush) + else + {$ENDIF} + ABitmap.Canvas.Brush.Color := Color; + ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect); + {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} + if ParentBackground then + with ThemeServices do + if ThemesEnabled then + begin + MemDC := CreateCompatibleDC(0); + OldBMP := SelectObject(MemDC, ABitmap.Handle); + DrawParentBackground(Handle, MemDC, nil, False); + if OldBMP <> 0 then SelectObject(MemDC, OldBMP); + if MemDC <> 0 then DeleteDC(MemDC); + end; + {$ENDIF}{$ENDIF} +end; + +procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas); +var + OffScreen: TBitmap; +begin + Offscreen := TBitmap.Create; + try + Offscreen.PixelFormat := pf32bit; + Offscreen.Width := Width; + Offscreen.Height := Height; + PaintParentBack(Offscreen); + ACanvas.Draw(0, 0, Offscreen); + finally + Offscreen.Free; + end; +end; + +procedure TmbBasicPicker.WMEraseBkgnd( + var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} ); +begin + inherited; +// Message.Result := 1; +end; + +end. + diff --git a/components/mbColorLib/mbColorPalette.pas b/components/mbColorLib/mbColorPalette.pas index 53aa6dada..c9af468bf 100644 --- a/components/mbColorLib/mbColorPalette.pas +++ b/components/mbColorLib/mbColorPalette.pas @@ -15,7 +15,7 @@ uses Windows, Messages, {$ENDIF} SysUtils, Classes, Controls, Graphics, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} - Forms, HTMLColors, PalUtils, Dialogs; + Forms, HTMLColors, PalUtils, Dialogs, mbBasicPicker; type TMouseLoc = (mlNone, mlOver, mlDown); @@ -28,7 +28,7 @@ type TGetHintTextEvent = procedure (AColor: TColor; Index: integer; var HintStr: string; var Handled: boolean) of object; TArrowKeyEvent = procedure (Key: Word; Shift: TShiftState) of object; - TmbColorPalette = class(TCustomControl) + TmbColorPalette = class(TmbBasicPicker) private FMouseLoc: TMouseLoc; FMouseOver, FMouseDown, FAutoHeight: boolean; @@ -77,13 +77,11 @@ type procedure Click; override; procedure Resize; override; procedure SelectCell(i: integer); - procedure PaintParentBack; procedure CreateWnd; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; {$IFDEF DELPHI} - procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN; @@ -92,7 +90,6 @@ type procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; {$ELSE} - procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; procedure CMMouseEnter(var Message: TLMessage); message CM_MOUSEENTER; procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN; @@ -101,6 +98,7 @@ type procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED; procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW; {$ENDIF} + public constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -116,6 +114,7 @@ type procedure SaveColorsAsPalette(FileName: TFileName); procedure GeneratePalette(BaseColor: TColor); procedure GenerateGradientPalette(Colors: array of TColor); + published property Align; property Anchors; @@ -141,8 +140,6 @@ type property TabOrder; property ShowHint default false; property Constraints; - property Color; - property ParentColor; property ParentShowHint default true; property PopupMenu; property Visible; @@ -193,6 +190,8 @@ begin DoubleBuffered := true; PBack := TBitmap.Create; PBack.PixelFormat := pf32bit; + FTempBmp := TBitmap.Create; + FTempBmp.PixelFormat := pf32bit; {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} ParentBackground := true; {$ENDIF} {$ENDIF} @@ -229,35 +228,36 @@ end; destructor TmbColorPalette.Destroy; begin - PBack.Free; - FNames.Free; - FColors.Free; - inherited Destroy; + PBack.Free; + FTempBmp.Free; + FNames.Free; + FColors.Free; + inherited Destroy; end; procedure TmbColorPalette.CalcAutoHeight; begin - if Parent = nil then - exit; - FColCount := Width div FCellSize; - if FAutoHeight and (FColCount <> 0) then + if Parent = nil then + exit; + FColCount := Width div FCellSize; + if FAutoHeight and (FColCount <> 0) then begin - if FColors.Count mod FColCount > 0 then - Height := (FColors.Count div FColCount + 1) * FCellSize - else - Height := (FColors.Count div FColCount) * FCellSize; + if FColors.Count mod FColCount > 0 then + Height := (FColors.Count div FColCount + 1) * FCellSize + else + Height := (FColors.Count div FColCount) * FCellSize; end; - if Height = 0 then Height := FCellSize; - FRowCount := Height div FCellSize; - Width := FColCount * FCellSize; + if Height = 0 then Height := FCellSize; + FRowCount := Height div FCellSize; + Width := FColCount * FCellSize; end; function TmbColorPalette.GetTotalRowCount: integer; begin -if FColCount <> 0 then - Result := FTotalCells div FColCount -else - Result := 0; + if FColCount <> 0 then + Result := FTotalCells div FColCount + else + Result := 0; end; procedure TmbColorPalette.CreateWnd; @@ -266,7 +266,7 @@ begin CalcAutoHeight; Invalidate; end; - + (* procedure TmbColorPalette.PaintParentBack; {$IFDEF DELPHI_7_UP} var @@ -283,7 +283,7 @@ begin PBack.Height := Height; {$IFDEF FPC} if Color = clDefault then - PBack.Canvas.Brush.Color := clForm + PBack.Canvas.Brush.Color := GetDefaultColor(dctBrush) else {$ENDIF} PBack.Canvas.Brush.Color := Color; @@ -300,170 +300,154 @@ begin if MemDC <> 0 then DeleteDC(MemDC); end; {$ENDIF} {$ENDIF} -end; +end; *) procedure TmbColorPalette.Paint; var - i: integer; + i: integer; begin - PaintParentBack; - //make bmp - FTempBmp := TBitmap.Create; - try - FTempBmp.PixelFormat := pf32bit; + PBack.Width := Width; + PBack.Height := Height; + PaintParentBack(PBack); + + //make bmp FTempBmp.Width := Width; FTempBmp.Height := Height; + PaintParentBack(FTempBmp); - {$IFDEF FPC} - if Color = clDefault then - FTempBmp.Canvas.Brush.Color := clForm - else - {$ENDIF} - FTempBmp.Canvas.Brush.Color := Color; - - {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} - if not ParentBackground then - {$ENDIF} {$ENDIF} - FTempBmp.Canvas.FillRect(FTempBmp.Canvas.ClipRect) - {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} - else - FTempBmp.Canvas.Draw(0, 0, PBack){$ENDIF} {$ENDIF}; - - FTotalCells := FColors.Count - 1; //reset counters + FTotalCells := FColors.Count - 1; FTop := 0; FLeft := 0; + //draw the cells for i := 0 to FColors.Count - 1 do - begin + begin if FColors.Strings[i] <> '' then - DrawCell(FColors.Strings[i]); + DrawCell(FColors.Strings[i]); Inc(FLeft); - end; - //draw the result + end; + + //draw the bmp Canvas.Draw(0, 0, FTempBmp); - //csDesiginng border + + //csDesiging border if csDesigning in ComponentState then - begin + begin Canvas.Brush.Style := bsClear; Canvas.Pen.Style := psDot; Canvas.Pen.Color := clBtnShadow; Canvas.Rectangle(ClientRect); Canvas.Brush.Style := bsSolid; Canvas.Pen.Style := psSolid; - end; - finally - FTempBmp.Free; - end; + end; end; procedure TmbColorPalette.DrawCell(clr: string); var - R: Trect; - FCurrentIndex: integer; - c: TColor; - Handled: boolean; + R: Trect; + FCurrentIndex: integer; + c: TColor; + Handled: boolean; begin - // set props - if (FLeft + 1) * FCellSize > FTempBmp.width then + // set props + if (FLeft + 1) * FCellSize > FTempBmp.Width then begin - Inc(FTop); - FLeft := 0; + Inc(FTop); + FLeft := 0; end; - FCurrentIndex := FTop * FColCount + FLeft; - R := Rect(FLeft * FCellSize, FTop * FCellSize, (FLeft + 1) * FCellSize, (FTop + 1) * FCellSize); - //start drawing - with FTempBmp.Canvas do + + FCurrentIndex := FTop * FColCount + FLeft; + R := Rect(FLeft * FCellSize, FTop * FCellSize, (FLeft + 1) * FCellSize, (FTop + 1) * FCellSize); + + //start drawing + + //get current state + if FCurrentIndex = FCheckedIndex then begin - {$IFDEF FPC} - if Color = clDefault then - Brush.Color := clForm else - {$ENDIF} - Brush.Color := Color; - //get current state - if FCurrentIndex = FCheckedIndex then + if FCheckedIndex = FIndex then begin - if FCheckedIndex = FIndex then - begin - if FMouseDown then + if FMouseDown then FState := ccsDown - else + else FState := ccsCheckedHover; - end - else - FState := ccsChecked; end - else - if FIndex = FCurrentIndex then - case FMouseLoc of + else + FState := ccsChecked; + end + else + if FIndex = FCurrentIndex then + case FMouseLoc of mlNone: FState := ccsNone; mlOver: FState := ccsOver; - end - else - FState := ccsNone; + end + else + FState := ccsNone; - //paint - DrawCellBack(FTempBmp.Canvas, R, FCurrentIndex); + //paint + DrawCellBack(FTempBmp.Canvas, R, FCurrentIndex); - // fire the event - Handled := false; - if Assigned(FOnPaintCell) then + // fire the event + Handled := false; + if Assigned(FOnPaintCell) then case FCellStyle of - csDefault: FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled); - csCorel: - if FColCount = 1 then - FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled) - else - FOnPaintCell(FTempBmp.Canvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled); + csDefault: + FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled); + csCorel: + if FColCount = 1 then + FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled) + else + FOnPaintCell(FTempBmp.Canvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled); end; - if not Handled then - begin - // if standard colors draw the rect - if not SameText(clr, 'clCustom') and not SameText(clr, 'clTransparent') then + + if not Handled then + begin + // if standard colors draw the rect + c := mbStringToColor(clr); + if not SameText(clr, 'clCustom') and not SameText(clr, 'clTransparent') then case FCellStyle of - csDefault: - begin - InflateRect(R, -3, -3); - c := mbStringToColor(clr); - if Enabled then + csDefault: begin - Brush.Color := c; - Pen.Color := clBtnShadow; - end - else - begin - Brush.Color := clGray; - Pen.Color := clGray; + InflateRect(R, -3, -3); + if Enabled then + begin + FTempBmp.Canvas.Brush.Color := c; + FTempBmp.Canvas.Pen.Color := clBtnShadow; + end + else + begin + FTempBmp.Canvas.Brush.Color := clGray; + FTempBmp.Canvas.Pen.Color := clGray; + end; + FTempBmp.Canvas.Rectangle(R); + Exit; end; - Rectangle(R); - Exit; - end; - csCorel: - begin - if (FState <> ccsNone) then - InflateRect(R, -2, -2) - else + + csCorel: begin - Inc(R.Left); - Dec(R.Bottom); - if R.Top <= 1 then - Inc(R.Top); - if R.Right = Width then - Dec(R.Right); + if (FState <> ccsNone) then + InflateRect(R, -2, -2) + else + begin + Inc(R.Left); + Dec(R.Bottom); + if R.Top <= 1 then + Inc(R.Top); + if R.Right = Width then + Dec(R.Right); + end; + if Enabled then + FTempBmp.Canvas.Brush.Color := c + else + FTempBmp.Canvas.Brush.Color := clGray; + FTempBmp.Canvas.FillRect(R); + Exit; end; - c := mbStringToColor(clr); - if Enabled then - Brush.Color := c - else - Brush.Color := clGray; - FillRect(R); - Exit; - end; end; - //if transparent draw the glyph - if SameText(clr, 'clTransparent') then PaintTransparentGlyph(FTempBmp.Canvas, R); - end; + //if transparent draw the glyph + if SameText(clr, 'clTransparent') then + PaintTransparentGlyph(FTempBmp.Canvas, R); end; end; @@ -588,6 +572,10 @@ begin else {$ENDIF} begin + {$IFDEF FPC} + if Color = clDefault then + ACanvas.Brush.Color := GetDefaultColor(dctBrush) else + {$ENDIF} ACanvas.Brush.Color := Color; ACanvas.FillRect(R); end; @@ -680,7 +668,7 @@ end; procedure TmbColorPalette.Resize; begin inherited; - CalcAutoHeight; + //CalcAutoHeight; // wp: will cause a ChangedBounds endless loop Invalidate; end; @@ -704,14 +692,17 @@ begin end; procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer); +var + newIndex: Integer; begin - if FIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then + newIndex := (y div FCellSize) * FColCount + (x div FCellSize); + if FIndex <> newIndex then begin - FIndex := (y div FCellSize)* FColCount + (x div FCellSize); - if FIndex > FTotalCells then FIndex := -1; - Invalidate; + FIndex := newIndex; + if FIndex > FTotalCells then FIndex := -1; + Invalidate; end; - inherited; + inherited; end; procedure TmbColorPalette.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); @@ -739,99 +730,93 @@ end; procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var - DontCheck: boolean; - AColor: TColor; + DontCheck: boolean; + AColor: TColor; begin - FMouseDown := false; - if FMouseOver then - FMouseLoc := mlOver - else - FMouseLoc := mlNone; - DontCheck := false; - if (FCheckedIndex > -1) and (FCheckedIndex < FColors.Count) then - AColor := mbStringToColor(FColors.Strings[FCheckedIndex]) - else - AColor := clNone; - if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then - if Assigned(FOnCellClick) then - FOnCellClick(Button, Shift, FCheckedIndex, AColor, DontCheck); - if DontCheck then FCheckedIndex := FOldIndex; - Invalidate; - inherited; - if Assigned(FOnChange) then FOnChange(Self); + FMouseDown := false; + if FMouseOver then + FMouseLoc := mlOver + else + FMouseLoc := mlNone; + DontCheck := false; + if (FCheckedIndex > -1) and (FCheckedIndex < FColors.Count) then + AColor := mbStringToColor(FColors.Strings[FCheckedIndex]) + else + AColor := clNone; + if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then + if Assigned(FOnCellClick) then + FOnCellClick(Button, Shift, FCheckedIndex, AColor, DontCheck); + if DontCheck then FCheckedIndex := FOldIndex; + Invalidate; + inherited; + if Assigned(FOnChange) then FOnChange(Self); end; procedure TmbColorPalette.CMGotFocus( var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); begin - inherited; - Invalidate; + inherited; + Invalidate; end; procedure TmbColorPalette.CMLostFocus( var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); begin - inherited; - if FMouseOver then - FMouseLoc := mlOver - else - FMouseLoc := mlNone; - Invalidate; + inherited; + if FMouseOver then + FMouseLoc := mlOver + else + FMouseLoc := mlNone; + Invalidate; end; procedure TmbColorPalette.CMEnabledChanged( var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); begin - inherited; - Invalidate; -end; - -procedure TmbColorPalette.WMEraseBkgnd( - var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF}); -begin - Message.Result := 1; + inherited; + Invalidate; end; procedure TmbColorPalette.SelectCell(i: integer); begin - if i < FColors.Count - 1 then - FCheckedIndex := i - else - FCheckedIndex := -1; - Invalidate; - if Assigned(FOnChange) then FOnChange(Self); + if i < FColors.Count - 1 then + FCheckedIndex := i + else + FCheckedIndex := -1; + Invalidate; + if Assigned(FOnChange) then FOnChange(Self); end; function TmbColorPalette.GetSelColor: TColor; begin -if (FCheckedIndex > -1) and (FCheckedIndex <= FTotalCells) then - Result := mbStringToColor(FColors.Strings[FCheckedIndex]) -else - Result := FOld; + if (FCheckedIndex > -1) and (FCheckedIndex <= FTotalCells) then + Result := mbStringToColor(FColors.Strings[FCheckedIndex]) + else + Result := FOld; end; function TmbColorPalette.GetColorUnderCursor: TColor; begin - Result := clNone; - if FIndex > -1 then - if FIndex < FColors.Count then - Result := mbStringToColor(FColors.Strings[FIndex]); + Result := clNone; + if FIndex > -1 then + if FIndex < FColors.Count then + Result := mbStringToColor(FColors.Strings[FIndex]); end; function TmbColorPalette.GetIndexUnderCursor: integer; begin - Result := -1; - if FIndex > -1 then - if FIndex < FColors.Count then - Result := FIndex; + Result := -1; + if FIndex > -1 then + if FIndex < FColors.Count then + Result := FIndex; end; procedure TmbColorPalette.SetTStyle(s: TTransparentStyle); begin - if FTStyle <> s then + if FTStyle <> s then begin - FTStyle := s; - Invalidate; + FTStyle := s; + Invalidate; end; end; diff --git a/components/mbColorLib/mbColorPickerControl.pas b/components/mbColorLib/mbColorPickerControl.pas index f30a3cc22..37487fd14 100644 --- a/components/mbColorLib/mbColorPickerControl.pas +++ b/components/mbColorLib/mbColorPickerControl.pas @@ -16,39 +16,37 @@ uses {$ENDIF} SysUtils, Classes, Controls, Graphics, Forms, {$IFDEF DELPHI_7_UP} Themes,{$ENDIF} - RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors; + RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker; type TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc); - TmbCustomPicker = class(TCustomControl) + TmbCustomPicker = class(TmbBasicPicker) private FHintFormat: string; FMarkerStyle: TMarkerStyle; FWebSafe: boolean; - procedure SetMarkerStyle(s: TMarkerStyle); procedure SetWebSafe(s: boolean); protected mx, my, mdx, mdy: integer; - function GetSelectedColor: TColor; virtual; procedure SetSelectedColor(C: TColor); virtual; procedure WebSafeChanged; dynamic; - procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); - message {$IFDEF FPC} LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; - procedure CMGotFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF}); - message CM_ENTER; - procedure CMLostFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF}); - message CM_EXIT; - procedure CMMouseLeave(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); - message CM_MOUSELEAVE; - procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; - procedure PaintParentBack(ACanvas: TCanvas); procedure CreateWnd; override; + procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; + {$IFDEF DELPHI} + procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER; + procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + {$ELSE} + procedure CMGotFocus(var Message: TLMessage); message CM_ENTER; + procedure CMLostFocus(var Message: TLMessage); message CM_EXIT; + procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; + {$ENDIF} property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle; public constructor Create(AOwner: TComponent); override; @@ -112,7 +110,6 @@ begin ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls]; DoubleBuffered := true; TabStop := true; - ParentColor := true; {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} ParentBackground := true; {$ENDIF}{$ENDIF} @@ -129,39 +126,6 @@ begin inherited; end; -procedure TmbCustomPicker.PaintParentBack(ACanvas: TCanvas); -var - OffScreen: TBitmap; - {$IFDEF DELPHI_7_UP} - MemDC: HDC; - OldBMP: HBITMAP; - {$ENDIF} -begin - Offscreen := TBitmap.Create; - Offscreen.Width := Width; - Offscreen.Height := Height; - {$IFDEF FPC} - if Color = clDefault then - Offscreen.Canvas.Brush.Color := clForm else - {$ENDIF} - Offscreen.Canvas.Brush.Color := Color; - Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect); - {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} - if ParentBackground then - with ThemeServices do - if ThemesEnabled then - begin - MemDC := CreateCompatibleDC(0); - OldBMP := SelectObject(MemDC, OffScreen.Handle); - DrawParentBackground(Handle, MemDC, nil, False); - if OldBMP <> 0 then SelectObject(MemDC, OldBMP); - if MemDC <> 0 then DeleteDC(MemDC); - end; - {$ENDIF}{$ENDIF} - ACanvas.Draw(0, 0, Offscreen); - Offscreen.Free; -end; - procedure TmbCustomPicker.CMGotFocus( var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} ); begin @@ -176,12 +140,6 @@ begin Invalidate; end; -procedure TmbCustomPicker.WMEraseBkgnd( - var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); -begin - Message.Result := 1; -end; - procedure TmbCustomPicker.CMMouseLeave( var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); begin diff --git a/components/mbColorLib/mbColorTree.pas b/components/mbColorLib/mbColorTree.pas index 45e003db3..857f6a7a1 100644 --- a/components/mbColorLib/mbColorTree.pas +++ b/components/mbColorLib/mbColorTree.pas @@ -44,10 +44,10 @@ type FGetHint: TGetHintEvent; FOnStartDrag: TStartDragEvent; FOnEndDrag: TEndDragEvent; - procedure SetInfo1(Value: string); procedure SetInfo2(Value: string); procedure SetInfoLabel(Value: string); + protected function CanChange(Node: TTreeNode): Boolean; override; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; @@ -59,6 +59,9 @@ type procedure DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); dynamic; procedure DrawInfoItem(R: TRect; Index: integer); dynamic; procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); + {$IFDEF FPC} + procedure WMHScroll(var Msg: TLMScroll); message LM_HSCROLL; + {$ENDIF} public Colors: array of TmbColor; @@ -309,12 +312,12 @@ end; function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState; Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; begin - Result := true; - if Length(Colors) = 0 then Exit; - if Node.HasChildren then - DrawColorItem(Node.DisplayRect(false), cdsSelected in State, node.Index, node.Text, node.Expanded) - else - DrawInfoItem(Node.DisplayRect(false), node.Parent.Index); + Result := true; + if Length(Colors) = 0 then Exit; + if Node.HasChildren then + DrawColorItem(Node.DisplayRect(false), cdsSelected in State, node.Index, node.Text, node.Expanded) + else + DrawInfoItem(Node.DisplayRect(false), node.Parent.Index); end; procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); @@ -351,24 +354,25 @@ var SR, TR: TRect; begin with Canvas do - begin + begin //background Pen.Color := clWindow; if Selected then - Brush.Color := clHighlight + Brush.Color := clHighlight else - Brush.Color := clBtnFace; + Brush.Color := Color; //clBtnFace; FillRect(R); MoveTo(R.Left, R.Bottom - 1); LineTo(R.Right, R.Bottom - 1); + //swatches SR := Rect(R.Left + 6, R.Top + 6, R.Left + 42, R.Top + 42); Brush.Color := Self.Colors[Index].value; if Selected then - begin + begin {$IFDEF DELPHI_7_UP} if ThemeServices.ThemesEnabled then - begin + begin ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); InflateRect(SR, -2, -2); Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80); @@ -379,10 +383,10 @@ begin InflateRect(SR, -1, -1); Brush.Color := Self.Colors[Index].value; FillRect(SR); - end + end else //windows 9x - begin + begin {$ENDIF} Pen.Color := clBackground; Brush.Color := clWindow; @@ -399,26 +403,26 @@ begin InflateRect(SR, -1, -1); Brush.Color := Self.Colors[Index].value; FillRect(SR); - {$IFDEF DELPHI_7_UP} - end; - {$ENDIF} - end + {$IFDEF DELPHI_7_UP} + end; + {$ENDIF} + end else - //not selected - begin + //not selected + begin //windows XP {$IFDEF DELPHI_7_UP} if ThemeServices.ThemesEnabled then - begin + begin ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); InflateRect(SR, -2, -2); Brush.Color := Self.Colors[Index].value; FillRect(SR); - end + end else //windows 9x - begin - {$ENDIF} + begin + {$ENDIF} DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT); InflateRect(SR, -2, -2); Brush.Color := Self.Colors[Index].value; @@ -428,32 +432,34 @@ begin FillRect(SR); InflateRect(SR, 1, 1); {$IFDEF DELPHI_7_UP} - end; + end; {$ENDIF} - end; + end; //names Font.Style := [fsBold]; if Selected then - begin + begin Brush.Color := clHighlightText; Pen.Color := clHighlightText; - end + end else - begin + begin Brush.Color := clWindowText; Pen.Color := clWindowText; - end; + end; TR := Rect(R.Left + 48, R.Top + (48 - TextHeight(itemText)) div 2, R.Right - 15, R.Bottom); - if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, Selected); - DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS); + if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, Selected); + SetBkMode(Canvas.Handle, TRANSPARENT); + DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS); + SetBkMode(Canvas.Handle, OPAQUE); if R.Right > 60 then - begin + begin if Expanded then - DoArrow(Canvas, sdDown, Point(R.Right - 13, R.Top + 20), selected) + DoArrow(Canvas, sdDown, Point(R.Right - 13, R.Top + 20), selected) else - DoArrow(Canvas, sdRight, Point(R.Right - 10, R.Top + 18), selected); - end; - end; + DoArrow(Canvas, sdRight, Point(R.Right - 10, R.Top + 18), selected); + end; + end; end; procedure TmbColorTree.DrawInfoItem(R: TRect; Index: integer); @@ -683,4 +689,12 @@ if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then inherited; end; +{$IFDEF FPC} +procedure TmbColorTree.WMHScroll(var Msg: TLMScroll); +begin + inherited; + //Invalidate; +end; +{$ENDIF} + end. diff --git a/components/mbColorLib/mbTrackBarPicker.pas b/components/mbColorLib/mbTrackBarPicker.pas index 2713e055b..d7166ac6b 100644 --- a/components/mbColorLib/mbTrackBarPicker.pas +++ b/components/mbColorLib/mbTrackBarPicker.pas @@ -13,7 +13,7 @@ uses {$ELSE} Windows, Messages, {$ENDIF} SysUtils, Classes, Controls, Graphics, Forms, - {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils; + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils, mbBasicPicker; const TBA_Resize = 0; @@ -38,7 +38,7 @@ type TSliderPlacement = (spBefore, spAfter, spBoth); TSelIndicator = (siArrows, siRect); - TmbTrackBarPicker = class(TCustomControl) + TmbTrackBarPicker = class(TmbBasicPicker) private mx, my: integer; FOnChange: TNotifyEvent; @@ -68,7 +68,6 @@ type procedure SetPlacement(Value: TSliderPlacement); procedure DrawMarker(p: integer); procedure SetSelIndicator(Value: TSelIndicator); - procedure PaintParentBack; procedure CalcPickRect; protected FArrowPos: integer; @@ -76,18 +75,12 @@ type FChange: boolean; FPickRect: TRect; FLimit: integer; + FGradientBmp: TBitmap; + FGradientWidth: Integer; + FGradientHeight: Integer; - procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); - procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); - procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); - message {$IFDEF FPC} LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; - procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; - procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); message CN_KEYDOWN; - procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; - procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; - procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; - procedure CMGotFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF}); message CM_ENTER; - procedure CMLostFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF}); message CM_EXIT; + procedure CreateGradient; + function GetGradientColor(AValue: Integer): TColor; virtual; procedure Paint; override; procedure DrawFrames; dynamic; procedure Resize; override; @@ -96,9 +89,28 @@ type function GetArrowPos: integer; dynamic; function GetHintStr: string; function GetSelectedValue: integer; virtual; abstract; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + + procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; + procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); + procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); + {$IFDEF DELPHI} + procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN; + procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER; + procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT; + {$ELSE} + procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN; + procedure CMGotFocus(var Message: TLMessage); message CM_ENTER; + procedure CMLostFocus(var Message: TLMessage); message CM_EXIT; + {$ENDIF} + public constructor Create(AOwner: TComponent); override; + destructor Destroy; override; property Manual: boolean read FManual; + published property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone; property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvNone; @@ -115,7 +127,7 @@ type property TabStop default true; property ShowHint; property Color; - property ParentColor default true; + property ParentColor; {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} property ParentBackground default true; @@ -155,6 +167,12 @@ type implementation +uses +{$IFDEF FPC} + IntfGraphics, fpimage, +{$ENDIF} + ScanLines, HTMLColors; + const { 3D border styles } BDR_RAISEDOUTER = 1; @@ -186,117 +204,217 @@ const constructor TmbTrackBarPicker.Create(AOwner: TComponent); begin - inherited; - ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; - DoubleBuffered := true; - ParentColor := true; - {$IFDEF DELPHI_7_UP} - {$IFDEF DELPHI} - ParentBackground := true; - {$ENDIF} - {$ENDIF} - Width := 267; - Height := 22; - TabStop := true; - ParentShowHint := true; - mx := 0; - my := 0; - FIncrement := 1; - FArrowPos := GetArrowPos; - FHintFormat := ''; - OnMouseWheelUp := WheelUp; - OnMouseWheelDown := WheelDown; - FManual := false; - FChange := true; - FLayout := lyHorizontal; - FNewArrowStyle := false; - Aw := 6; - Ah := 10; - FPlacement := spAfter; - FPickRect := Rect(Aw, 0, Width - Aw, Height - Ah); - FDoChange := false; - FSelIndicator := siArrows; - FLimit := 7; - FWebSafe := false; - FBevelInner:= bvNone; - FBevelOuter:= bvNone; - FBevelWidth:= 1; - FBorderStyle:= bsNone; + inherited; + ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; + DoubleBuffered := true; + {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} + ParentBackground := true; + {$ENDIF} {$ENDIF} + Width := 267; + Height := 22; + TabStop := true; + ParentShowHint := true; + FGradientWidth := 256; + FGradientHeight := 12; + FGradientBmp := TBitmap.Create; + FGradientBmp.PixelFormat := pf32bit; + mx := 0; + my := 0; + FIncrement := 1; + FArrowPos := GetArrowPos; + FHintFormat := ''; + OnMouseWheelUp := WheelUp; + OnMouseWheelDown := WheelDown; + FManual := false; + FChange := true; + FLayout := lyHorizontal; + FNewArrowStyle := false; + Aw := 6; + Ah := 10; + FPlacement := spAfter; + FPickRect := Rect(Aw, 0, Width - Aw, Height - Ah); + FDoChange := false; + FSelIndicator := siArrows; + FLimit := 7; + FWebSafe := false; + FBevelInner:= bvNone; + FBevelOuter:= bvNone; + FBevelWidth:= 1; + FBorderStyle:= bsNone; +end; + +destructor TmbTrackbarPicker.Destroy; +begin + FGradientBmp.Free; + inherited; +end; + +function TmbTrackbarPicker.GetGradientColor(AValue: Integer): TColor; +begin + Result := clDefault; +end; + +{ AWidth and AHeight are seen for horizontal arrangement of the bar } +procedure TmbTrackbarPicker.CreateGradient; +var + i,j: integer; + row: pRGBQuadArray; + c: TColor; + {$IFDEF FPC} + intfimg: TLazIntfImage; + imgHandle, imgMaskHandle: HBitmap; + {$ENDIF} +begin + if FGradientBmp = nil then + exit; + + {$IFDEF FPC} + intfimg := TLazIntfImage.Create(0, 0); + try + {$ENDIF} + + if Layout = lyHorizontal then + begin + FGradientBmp.Width := FGradientWidth; + FGradientBmp.Height := FGradientHeight; + {$IFDEF FPC} + intfImg.LoadFromBitmap(FGradientBmp.Handle, FGradientBmp.MaskHandle); + {$ENDIF} + for i := 0 to FGradientBmp.Width-1 do + begin + c := GetGradientColor(i); + for j := 0 to FGradientBmp.Height-1 do + begin + {$IFDEF FPC} + row := intfImg.GetDataLineStart(j); + {$ELSE} + row := FGradientBmp.ScanLine[j]; + {$ENDIF} + if not WebSafe then + row[i] := RGBtoRGBQuad(c) + else + row[i] := RGBtoRGBQuad(GetWebSafe(c)); + end; + end; + end + else + begin + FGradientBmp.Width := FGradientHeight; + FGradientBmp.Height := FGradientWidth; + {$IFDEF FPC} + intfImg.LoadFromBitmap(FGradientBmp.Handle, FGradientBmp.MaskHandle); + {$ENDIF} + for i := 0 to FGradientBmp.Height-1 do + begin + {$IFDEF FPC} + row := intfImg.GetDataLineStart(i); + {$ELSE} + row := FGradientBmp.ScanLine[i]; + {$ENDIF} + c := GetGradientColor(FGradientBmp.Height - 1 - i); + for j := 0 to FGradientBmp.Width-1 do + if not WebSafe then + row[j] := RGBtoRGBQuad(c) + else + row[j] := RGBtoRGBQuad(GetWebSafe(c)); + end; + end; + + {$IFDEF FPC} + intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false); + FGradientBmp.Handle := imgHandle; + FGradientBmp.MaskHandle := imgMaskHandle; + finally + intfImg.Free; + end; + {$ENDIF} end; procedure TmbTrackBarPicker.CreateWnd; begin - inherited; - CalcPickRect; + inherited; + CalcPickRect; + CreateGradient; end; procedure TmbTrackBarPicker.CalcPickRect; var - f: integer; + f: integer; begin - case FSelIndicator of - siArrows: - if not FNewArrowStyle then - begin - f := 0; - Aw := 6; - Ah := 10; - FLimit := 7; - end - else - begin - Aw := 8; - Ah := 9; - f := 2; - FLimit := 7; - end; - siRect: - begin - f := 0; - Aw := 4; - Ah := 5; - FLimit := 3; - end - else - f := 0; - end; - case FLayout of - lyHorizontal: - case FSelIndicator of + case FSelIndicator of siArrows: - case FPlacement of - spAfter: FPickRect := Rect(Aw, 0, Width - Aw, Height - Ah - f); - spBefore: FPickRect := Rect(Aw, Ah + f, Width - Aw, Height); - spBoth: FPickRect := Rect(Aw, Ah + f, Width - Aw, Height - Ah - f); - end; - siRect: FPickRect := Rect(Aw, Ah, width - 2*Aw + 1, height - Ah); - end; - lyVertical: - case FSelIndicator of - siArrows: - case FPlacement of - spAfter: FPickRect := Rect(0, Aw, Width - Ah - f, Height - Aw); - spBefore: FPickRect := Rect(Ah + f, Aw, Width, Height - Aw); - spBoth: FPickRect := Rect(Ah + f, Aw, Width - Ah - f, Height - Aw); - end; - siRect: FPickRect := Rect(Ah, Aw, width - 5, height - 2*Aw + 1); - end; - end; + if not FNewArrowStyle then + begin + f := 0; + Aw := 6; + Ah := 10; + FLimit := 7; + end + else + begin + Aw := 8; + Ah := 9; + f := 2; + FLimit := 7; + end; + + siRect: + begin + f := 0; + Aw := 4; + Ah := 5; + FLimit := 3; + end + + else + f := 0; + end; + + case FLayout of + lyHorizontal: + case FSelIndicator of + siArrows: + case FPlacement of + spAfter: + FPickRect := Rect(Aw, 0, Width - Aw, Height - Ah - f); + spBefore: + FPickRect := Rect(Aw, Ah + f, Width - Aw, Height); + spBoth: + FPickRect := Rect(Aw, Ah + f, Width - Aw, Height - Ah - f); + end; + siRect: + FPickRect := Rect(Aw, Ah, width - 2*Aw + 1, height - Ah); + end; + lyVertical: + case FSelIndicator of + siArrows: + case FPlacement of + spAfter: + FPickRect := Rect(0, Aw, Width - Ah - f, Height - Aw); + spBefore: + FPickRect := Rect(Ah + f, Aw, Width, Height - Aw); + spBoth: + FPickRect := Rect(Ah + f, Aw, Width - Ah - f, Height - Aw); + end; + siRect: + FPickRect := Rect(Ah, Aw, width - 5, height - 2*Aw + 1); + end; + end; end; procedure TmbTrackBarPicker.Paint; begin - CalcPickRect; - PaintParentBack; - FArrowPos := GetArrowPos; - Execute(TBA_Paint); - if FBorderStyle <> bsNone then - DrawFrames; - DrawMarker(FArrowPos); - if FDoChange then + CalcPickRect; + PaintParentBack; + FArrowPos := GetArrowPos; + Execute(TBA_Paint); + if FBorderStyle <> bsNone then + DrawFrames; + DrawMarker(FArrowPos); + if FDoChange then begin - if Assigned(FOnChange) then FOnChange(Self); - FDoChange := false; + if Assigned(FOnChange) then FOnChange(Self); + FDoChange := false; end; end; @@ -330,250 +448,219 @@ end; procedure TmbTrackBarPicker.DrawMarker(p: integer); var - x, y: integer; - R: TRect; + x, y: integer; + R: TRect; begin - case FSelIndicator of - siRect: - begin - case FLayout of - lyHorizontal: + case FSelIndicator of + siRect: begin - p := p + Aw; - R := Rect(p - 2, 2, p + 3, Height - 2); + case FLayout of + lyHorizontal: + begin + p := p + Aw; + R := Rect(p - 2, 2, p + 3, Height - 2); + end; + lyVertical: + begin + p := p + Aw; + R := Rect(2, p - 2, Width - 2, p + 3); + end; + end; + Canvas.Pen.Mode := pmNot; + Canvas.Brush.Style := bsClear; + Canvas.Rectangle(R); + Canvas.Brush.Style := bsSolid; + Canvas.Pen.Mode := pmCopy; end; - lyVertical: + + siArrows: begin - p := p + Aw; - R := Rect(2, p - 2, Width - 2, p + 3); - end; - end; - Canvas.Pen.Mode := pmNot; - Canvas.Brush.Style := bsClear; - Canvas.Rectangle(R); - Canvas.Brush.Style := bsSolid; - Canvas.Pen.Mode := pmCopy; - end; - siArrows: - begin - if not FNewArrowStyle then - begin - if Focused or (csDesigning in ComponentState)then - begin - Canvas.Brush.Color := clBlack; - Canvas.Pen.Color := clBlack; - end - else - begin - Canvas.Brush.Color := clGray; - Canvas.Pen.Color := clGray; - end; - end - else - begin - Canvas.Brush.Color := clWindow; - Canvas.Pen.Color := clBtnShadow; - end; - if FLayout = lyHorizontal then - begin - x := p + Aw; - if x < Aw then x := Aw; - if x > Width - Aw then x := Width - Aw; - case FPlacement of - spAfter: + if not FNewArrowStyle then begin - y := Height - Aw - 1; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x - 4, y + 6), Point(x + 4, y + 6)]) - else - Canvas.Polygon([Point(x, y), Point(x - 4, y + 4), Point(x - 4, y + 6), - Point(x - 3, y + 7), Point(x + 3, y + 7), - Point(x + 4, y + 6), Point(x + 4, y + 4)]); - end; - spBefore: + if Focused or (csDesigning in ComponentState) then + begin + Canvas.Brush.Color := clBlack; + Canvas.Pen.Color := clBlack; + end + else + begin + Canvas.Brush.Color := clGray; + Canvas.Pen.Color := clGray; + end; + end + else begin - y := Aw; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x - 4, y - 6), Point(x +4, y - 6)]) - else - Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 4, y - 6), - Point(x + 3, y - 7), Point(x - 3, y - 7), - Point(x - 4, y - 6), Point(x - 4, y - 4)]); + Canvas.Brush.Color := clWindow; + Canvas.Pen.Color := clBtnShadow; end; - spBoth: + + if FLayout = lyHorizontal then begin - y := Height - Aw - 1; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x -4, y +6), Point(x +4, y + 6)]) - else - Canvas.Polygon([Point(x, y), Point(x - 4, y + 4), Point(x - 4, y + 6), - Point(x - 3, y + 7), Point(x + 3, y + 7), - Point(x + 4, y + 6), Point(x + 4, y + 4)]); - y := Aw; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x - 4, y - 6), Point(x +4, y - 6)]) - else - Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 4, y - 6), - Point(x + 3, y - 7), Point(x - 3, y - 7), - Point(x - 4, y - 6), Point(x - 4, y - 4)]); - end; - end; - end - else - begin - if not FNewArrowStyle then - y := p + Aw - else - y := p + Aw - 1; - if y < Aw then y := Aw; - if y > Height - Aw - 1 then y := Height - Aw - 1; - case FPlacement of - spAfter: + x := p + Aw; + if x < Aw then x := Aw; + if x > Width - Aw then x := Width - Aw; + case FPlacement of + spAfter: + begin + y := Height - Aw - 1; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x - 4, y + 6), Point(x + 4, y + 6)]) + else + Canvas.Polygon([Point(x, y), Point(x - 4, y + 4), Point(x - 4, y + 6), + Point(x - 3, y + 7), Point(x + 3, y + 7), Point(x + 4, y + 6), + Point(x + 4, y + 4)]); + end; + spBefore: + begin + y := Aw; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x - 4, y - 6), Point(x +4, y - 6) + ]) + else + Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 4, y - 6), + Point(x + 3, y - 7), Point(x - 3, y - 7), Point(x - 4, y - 6), + Point(x - 4, y - 4) ]); + end; + spBoth: + begin + y := Height - Aw - 1; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x - 4, y + 6), Point(x + 4, y + 6) ]) + else + Canvas.Polygon([Point(x, y), Point(x - 4, y + 4), Point(x - 4, y + 6), + Point(x - 3, y + 7), Point(x + 3, y + 7), Point(x + 4, y + 6), + Point(x + 4, y + 4) ]); + y := Aw; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x - 4, y - 6), Point(x +4, y - 6) ]) + else + Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 4, y - 6), + Point(x + 3, y - 7), Point(x - 3, y - 7), Point(x - 4, y - 6), + Point(x - 4, y - 4) ]); + end; + end; // case FPlacement + end // if FLayout + else begin - x := width - Aw - 1; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x + 6, y - 4), Point(x + 6, y + 4)]) - else - Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 6, y - 4), - Point(x + 7, y - 3), Point(x + 7, y + 3), - Point(x + 6, y + 4), Point(x + 4, y + 4)]); - end; - spBefore: - begin - x := Aw; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x - 6, y - 4), Point(x - 6, y + 4)]) - else - Canvas.Polygon([Point(x, y), Point(x - 4, y - 4), Point(x - 6, y - 4), - Point(x - 7, y + 1 - 4), Point(x - 7, y + 3), - Point(x - 6, y + 4), Point(x - 4, y + 4)]); - end; - spBoth: - begin - x := width - Aw - 1; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x + 6, y - 4), Point(x + 6, y + 4)]) - else - Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 6, y - 4), - Point(x + 7, y - 3), Point(x + 7, y + 3), - Point(x + 6, y + 4), Point(x + 4, y + 4)]); - x := Aw; - if not FNewArrowStyle then - Canvas.Polygon([Point(x, y), Point(x - 6, y - 4), Point(x - 6, y + 4)]) - else - Canvas.Polygon([Point(x, y), Point(x - 4, y - 4), Point(x - 6, y - 4), - Point(x - 7, y + 1 - 4), Point(x - 7, y + 3), - Point(x - 6, y + 4), Point(x - 4, y + 4)]); - end; - end; - end; - end; - end; + if not FNewArrowStyle then + y := p + Aw + else + y := p + Aw - 1; + if y < Aw then y := Aw; + if y > Height - Aw - 1 then y := Height - Aw - 1; + case FPlacement of + spAfter: + begin + x := width - Aw - 1; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x + 6, y - 4), Point(x + 6, y + 4)]) + else + Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 6, y - 4), + Point(x + 7, y - 3), Point(x + 7, y + 3), Point(x + 6, y + 4), + Point(x + 4, y + 4)]); + end; + spBefore: + begin + x := Aw; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x - 6, y - 4), Point(x - 6, y + 4)]) + else + Canvas.Polygon([Point(x, y), Point(x - 4, y - 4), Point(x - 6, y - 4), + Point(x - 7, y + 1 - 4), Point(x - 7, y + 3), Point(x - 6, y + 4), + Point(x - 4, y + 4)]); + end; + spBoth: + begin + x := width - Aw - 1; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x + 6, y - 4), Point(x + 6, y + 4)]) + else + Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 6, y - 4), + Point(x + 7, y - 3), Point(x + 7, y + 3), Point(x + 6, y + 4), + Point(x + 4, y + 4)]); + x := Aw; + if not FNewArrowStyle then + Canvas.Polygon([Point(x, y), Point(x - 6, y - 4), Point(x - 6, y + 4)]) + else + Canvas.Polygon([Point(x, y), Point(x - 4, y - 4), Point(x - 6, y - 4), + Point(x - 7, y + 1 - 4), Point(x - 7, y + 3), Point(x - 6, y + 4), + Point(x - 4, y + 4)]); + end; + end; // case FPlacement + end; // else (if FLayout) + end; // siArrow + end; // case FSelIndicator end; procedure TmbTrackBarPicker.Resize; begin - inherited; - FChange := false; - Execute(TBA_Resize); - FChange := true; -end; - -procedure TmbTrackBarPicker.PaintParentBack; -var - c: TColor; - OffScreen: TBitmap; -{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} - MemDC: HDC; - OldBMP: HBITMAP; - {$ENDIF}{$ENDIF} -begin - Offscreen := TBitmap.Create; - Offscreen.Width := Width; - Offscreen.Height := Height; - {$IFDEF FPC} - if Color = clDefault then - Offscreen.Canvas.Brush.Color := clForm else - {$ENDIF} - Offscreen.Canvas.Brush.Color := Color; - Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect); - {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} - if ParentBackground then - with ThemeServices do - if ThemesEnabled then - begin - MemDC := CreateCompatibleDC(0); - OldBMP := SelectObject(MemDC, OffScreen.Handle); - DrawParentBackground(Handle, MemDC, nil, False); - if OldBMP <> 0 then SelectObject(MemDC, OldBMP); - if MemDC <> 0 then DeleteDC(MemDC); - end; - {$ENDIF}{$ENDIF} - Canvas.Draw(0, 0, Offscreen); - Offscreen.Free; + inherited; + FChange := false; + Execute(TBA_Resize); + FChange := true; end; function TmbTrackBarPicker.XToArrowPos(p: integer): integer; var - pos: integer; + pos: integer; begin - pos := p - Aw; - if pos < 0 then pos := 0; - if pos > Width - Aw - 1 then pos := Width - Aw - 1; - Result := pos; + pos := p - Aw; + if pos < 0 then pos := 0; + if pos > Width - Aw - 1 then pos := Width - Aw - 1; + Result := pos; end; function TmbTrackBarPicker.YToArrowPos(p: integer): integer; var - pos: integer; + pos: integer; begin - pos := p - Aw; - if pos < 0 then pos := 0; - if pos > Height - Aw - 1 then pos := Height - Aw - 1; - Result := pos; + pos := p - Aw; + if pos < 0 then pos := 0; + if pos > Height - Aw - 1 then pos := Height - Aw - 1; + Result := pos; end; procedure TmbTrackBarPicker.MouseMove(Shift: TShiftState; X, Y: Integer); var R: TRect; begin - if ssLeft in shift then + if ssLeft in shift then begin - R := ClientRect; - R.TopLeft := ClientToScreen(R.TopLeft); - R.BottomRight := ClientToScreen(R.BottomRight); - {$IFDEF DELPHI} - ClipCursor(@R); - {$ENDIF} - mx := x; - my := y; - if FLayout = lyHorizontal then - FArrowPos := XToArrowPos(x) - else - FArrowPos := YToArrowPos(y); - Execute(TBA_MouseMove); - FManual := true; - FDoChange := true; - Invalidate; + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + mx := x; + my := y; + if FLayout = lyHorizontal then + FArrowPos := XToArrowPos(x) + else + FArrowPos := YToArrowPos(y); + Execute(TBA_MouseMove); + FManual := true; + FDoChange := true; + Invalidate; end; - inherited; + inherited; end; procedure TmbTrackBarPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin - if Button <> mbLeft then Exit; - mx := x; - my := y; - SetFocus; - if FLayout = lyHorizontal then - FArrowPos := XToArrowPos(x) - else - FArrowPos := YToArrowPos(y); - Execute(TBA_MouseDown); - FManual := true; - FDoChange := true; - Invalidate; - inherited; + if Button <> mbLeft then Exit; + mx := x; + my := y; + SetFocus; + if FLayout = lyHorizontal then + FArrowPos := XToArrowPos(x) + else + FArrowPos := YToArrowPos(y); + Execute(TBA_MouseDown); + FManual := true; + FDoChange := true; + Invalidate; + inherited; end; procedure TmbTrackBarPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); @@ -681,121 +768,119 @@ end; procedure TmbTrackBarPicker.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; - if FLayout = lyHorizontal then - HintPos := ClientToScreen(Point(CursorPos.X - 8, Height + 2)) - else - HintPos := ClientToScreen(Point(Width + 2, CursorPos.Y - 8)); - HintStr := GetHintStr; - end; - inherited; + with TCMHintShow(Message) do + if not ShowHint then + Message.Result := 1 + else + with HintInfo^ do + begin + Result := 0; + ReshowTimeout := 1; + HideTimeout := 5000; + if FLayout = lyHorizontal then + HintPos := ClientToScreen(Point(CursorPos.X - 8, Height + 2)) + else + HintPos := ClientToScreen(Point(Width + 2, CursorPos.Y - 8)); + HintStr := GetHintStr; + end; + inherited; end; procedure TmbTrackBarPicker.CMGotFocus( var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF}); begin - inherited; - Invalidate; + inherited; + Invalidate; end; procedure TmbTrackBarPicker.CMLostFocus( var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF}); begin - inherited; - Invalidate; -end; - -procedure TmbTrackBarPicker.WMEraseBkgnd( - var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); -begin - Message.Result := 1; + inherited; + Invalidate; end; procedure TmbTrackBarPicker.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin - Handled := true; - FChange := false; - Execute(TBA_WheelUp); - FManual := true; - FChange := true; - if Assigned(FOnChange) then FOnChange(Self); + Handled := true; + FChange := false; + Execute(TBA_WheelUp); + FManual := true; + FChange := true; + if Assigned(FOnChange) then FOnChange(Self); end; procedure TmbTrackBarPicker.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin - Handled := true; - FChange := false; - Execute(TBA_WheelDown); - FManual := true; - FChange := true; - if Assigned(FOnChange) then FOnChange(Self); + Handled := true; + FChange := false; + Execute(TBA_WheelDown); + FManual := true; + FChange := true; + if Assigned(FOnChange) then FOnChange(Self); end; procedure TmbTrackBarPicker.SetLayout(Value: TTrackBarLayout); begin - if FLayout <> Value then + if FLayout <> Value then begin - FLayout := Value; - Execute(TBA_RedoBMP); - Invalidate; + FLayout := Value; + Execute(TBA_RedoBMP); + Invalidate; end; end; procedure TmbTrackBarPicker.SetPlacement(Value: TSliderPlacement); begin - if FPlacement <> Value then + if FPlacement <> Value then begin - FPlacement := Value; - Invalidate; + FPlacement := Value; + Invalidate; end; end; procedure TmbTrackBarPicker.SetNewArrowStyle(s: boolean); begin - if FNewArrowStyle <> s then + if FNewArrowStyle <> s then begin - FNewArrowStyle := s; - Invalidate; + FNewArrowStyle := s; + Invalidate; end; end; procedure TmbTrackBarPicker.SetSelIndicator(Value: TSelIndicator); begin - if FSelIndicator <> Value then + if FSelIndicator <> Value then begin - FSelIndicator := Value; - Invalidate; + FSelIndicator := Value; + Invalidate; end; end; procedure TmbTrackBarPicker.SetWebSafe(s: boolean); begin - if FWebSafe <> s then + if FWebSafe <> s then begin - FWebSafe := s; - Execute(TBA_RedoBMP); - Invalidate; + FWebSafe := s; + Execute(TBA_RedoBMP); + Invalidate; end; end; procedure TmbTrackBarPicker.Execute(tbaAction: integer); begin - //handled in descendants + case tbaAction of + TBA_Paint : Canvas.StretchDraw(FPickRect, FGradientBmp); + TBA_RedoBMP : CreateGradient; + // Rest handled in descendants + end; end; function TmbTrackBarPicker.GetArrowPos: integer; begin - Result := 0; - //handled in descendants + Result := 0; + //handled in descendants end; function TmbTrackBarPicker.GetHintStr: string; @@ -806,37 +891,37 @@ end; procedure TmbTrackBarPicker.SetBevelInner(Value: TBevelCut); begin - if FBevelInner <> Value then + if FBevelInner <> Value then begin - FBevelInner := Value; - Invalidate; + FBevelInner := Value; + Invalidate; end; end; procedure TmbTrackBarPicker.SetBevelOuter(Value: TBevelCut); begin - if FBevelOuter <> Value then + if FBevelOuter <> Value then begin - FBevelOuter := Value; - Invalidate; + FBevelOuter := Value; + Invalidate; end; end; procedure TmbTrackBarPicker.SetBevelWidth(Value: TBevelWidth); begin - if FBevelWidth <> Value then + if FBevelWidth <> Value then begin - FBevelWidth := Value; - Invalidate; + FBevelWidth := Value; + Invalidate; end; end; procedure TmbTrackBarPicker.SetBorderStyle(Value: TBorderStyle); begin - if FBorderStyle <> Value then + if FBorderStyle <> Value then begin - FBorderStyle := Value; - Invalidate; + FBorderStyle := Value; + Invalidate; end; end; diff --git a/components/mbColorLib/mbcolorliblaz.lpk b/components/mbColorLib/mbcolorliblaz.lpk index ceedefd11..e13bceff0 100644 --- a/components/mbColorLib/mbcolorliblaz.lpk +++ b/components/mbColorLib/mbcolorliblaz.lpk @@ -15,7 +15,7 @@ - + @@ -219,6 +219,10 @@ + + + +