diff --git a/components/mbColorLib/BAxisColorPicker.dcr b/components/mbColorLib/BAxisColorPicker.dcr new file mode 100644 index 000000000..a209c7ea6 Binary files /dev/null and b/components/mbColorLib/BAxisColorPicker.dcr differ diff --git a/components/mbColorLib/BAxisColorPicker.pas b/components/mbColorLib/BAxisColorPicker.pas new file mode 100644 index 000000000..b86f7c977 --- /dev/null +++ b/components/mbColorLib/BAxisColorPicker.pas @@ -0,0 +1,381 @@ +unit BAxisColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, Forms, + HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; + +type + TBAxisColorPicker = class(TmbColorPickerControl) + private + FSelected: TColor; + FBmp: TBitmap; + FOnChange: TNotifyEvent; + FR, FG, FB: integer; + FManual: boolean; + dx, dy, mxx, myy: integer; + + procedure SetRValue(r: integer); + procedure SetGValue(g: integer); + procedure SetBValue(b: integer); + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + 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 DrawMarker(x, y: integer); + procedure Paint; override; + procedure CreateRGBGradient; + procedure Resize; override; + procedure CreateWnd; override; + procedure CorrectCoords(var x, y: integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property SelectedColor default clBlue; + property RValue: integer read FR write SetRValue default 0; + property GValue: integer read FG write SetGValue default 0; + property BValue: integer read FB write SetBValue default 255; + property MarkerStyle default msCircle; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R BAxisColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TBAxisColorPicker]); +end; + +{TBAxisColorPicker} + +constructor TBAxisColorPicker.Create(AOwner: TComponent); +begin + inherited; + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.SetSize(256, 256); + Width := 256; + Height := 256; + HintFormat := 'R: %r G: %g'#13'Hex: %hex'; + FG := 0; + FB := 255; + FR := 0; + FSelected := clBlue; + FManual := false; + dx := 0; + dy := 0; + mxx := 0; + myy := 0; + MarkerStyle := msCircle; +end; + +destructor TBAxisColorPicker.Destroy; +begin + FBmp.Free; + inherited Destroy; +end; + +procedure TBAxisColorPicker.CreateWnd; +begin + inherited; + CreateRGBGradient; +end; + +procedure TBAxisColorPicker.CreateRGBGradient; +var + r, g: integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.Width := 256; + FBmp.Height := 256; + end; + + for g := 0 to 255 do + begin + row := FBmp.ScanLine[255 - g]; + for r := 0 to 255 do + if not WebSafe then + row[r] := RGBtoRGBQuad(r, g, FB) + else + row[r] := RGBtoRGBQuad(GetWebSafe(RGB(r, g, FB))); + end; +end; + +procedure TBAxisColorPicker.CorrectCoords(var x, y: integer); +begin + if x < 0 then x := 0; + if y < 0 then y := 0; + if x > Width - 1 then x := Width - 1; + if y > Height - 1 then y := Height - 1; +end; + +procedure TBAxisColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + CorrectCoords(x, y); + FR := GetRValue(FSelected); + FG := GetGValue(FSelected); + FB := GetBValue(FSelected); + if Assigned(FOnChange) then + FOnChange(Self); + dx := x; + dy := y; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clWhite; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +function TBAxisColorPicker.GetSelectedColor: TColor; +begin + Result := FSelected; +end; + +procedure TBAxisColorPicker.SetSelectedColor(c: TColor); +begin + if WebSafe then c := GetWebSafe(c); + FR := GetRValue(c); + FG := GetGValue(c); + FB := GetBValue(c); + FSelected := c; + FManual := false; + mxx := Round(FR*(Width/255)); + myy := Round((255-FG)*(Height/255)); + CreateRGBGradient; + Invalidate; +end; + +procedure TBAxisColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FBmp); + CorrectCoords(mxx, myy); + DrawMarker(mxx, myy); +end; + +procedure TBAxisColorPicker.Resize; +begin + FManual := false; + mxx := Round(FR*(Width/255)); + myy := Round((255-FG)*(Height/255)); + inherited; +end; + +procedure TBAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + R: TRect; +begin + inherited; + mxx := x; + myy := y; + if Button = mbLeft then + begin + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; + SetFocus; +end; + +procedure TBAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; +end; + +procedure TBAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if ssLeft in Shift then + begin + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; +end; + +procedure TBAxisColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure TBAxisColorPicker.SetRValue(r: integer); +begin + if r > 255 then r := 255; + if r < 0 then r := 0; + FR := r; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +procedure TBAxisColorPicker.SetGValue(g: integer); +begin + if g > 255 then g := 255; + if g < 0 then g := 0; + FG := g; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +procedure TBAxisColorPicker.SetBValue(b: integer); +begin + if b > 255 then b := 255; + if b < 0 then b := 0; + FB := b; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +function TBAxisColorPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := Canvas.Pixels[x, y]; +end; + +procedure TBAxisColorPicker.WebSafeChanged; +begin + inherited; + CreateRGBGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/BColorPicker.dcr b/components/mbColorLib/BColorPicker.dcr new file mode 100644 index 000000000..4838dac93 Binary files /dev/null and b/components/mbColorLib/BColorPicker.dcr differ diff --git a/components/mbColorLib/BColorPicker.pas b/components/mbColorLib/BColorPicker.pas new file mode 100644 index 000000000..85b1cac27 --- /dev/null +++ b/components/mbColorLib/BColorPicker.pas @@ -0,0 +1,264 @@ +unit BColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + mbTrackBarPicker, HTMLColors, Scanlines; + +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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R BColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + 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; +end; + +procedure TBColorPicker.CreateBGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FBmp.width := 256; + FBmp.height := 12; + for i := 0 to 255 do + for j := 0 to 11 do + begin + row := FBmp.Scanline[j]; + if not WebSafe then + row[i] := RGBtoRGBQuad(FRed, FGreen, i) + else + row[i] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, FGreen, i))); + end; + end + else + begin + FBmp.width := 12; + FBmp.height := 256; + for i := 0 to 255 do + begin + row := FBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBtoRGBQuad(FRed, FGreen, 255-i) + else + row[j] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, FGreen, 255-i))); + end; + end; +end; + +procedure TBColorPicker.SetRed(r: integer); +begin + 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); + end; +end; + +procedure TBColorPicker.SetGreen(g: integer); +begin + 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); + end; +end; + +procedure TBColorPicker.SetBlue(b: integer); +begin + 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); + end; +end; + +function TBColorPicker.ArrowPosFromBlue(b: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*b); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TBColorPicker.BlueFromArrowPos(p: integer): integer; +var + 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; +end; + +function TBColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := RGB(FRed, FGreen, FBlue) + else + Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); +end; + +function TBColorPicker.GetSelectedValue: integer; +begin + Result := FBlue; +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); +end; + +function TBColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/CColorPicker.dcr b/components/mbColorLib/CColorPicker.dcr new file mode 100644 index 000000000..3a42f9d26 Binary files /dev/null and b/components/mbColorLib/CColorPicker.dcr differ diff --git a/components/mbColorLib/CColorPicker.pas b/components/mbColorLib/CColorPicker.pas new file mode 100644 index 000000000..058f8d2ce --- /dev/null +++ b/components/mbColorLib/CColorPicker.pas @@ -0,0 +1,286 @@ +unit CColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; + +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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R CColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + 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; +end; + +procedure TCColorPicker.CreateCGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FCBmp = nil then + begin + FCBmp := TBitmap.Create; + FCBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FCBmp.width := 255; + FCBmp.height := 12; + for i := 0 to 254 do + for j := 0 to 11 do + begin + row := FCBmp.Scanline[j]; + if not WebSafe then + row[i] := RGBToRGBQuad(CMYKtoTColor(i, FMagenta, FYellow, FBlack)) + else + row[i] := RGBToRGBQuad(GetWebSafe(CMYKtoTColor(i, FMagenta, FYellow, FBlack))); + end; + end + else + begin + FCBmp.width := 12; + FCBmp.height := 255; + for i := 0 to 254 do + begin + row := FCBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBtoRGBQuad(CMYKtoTColor(255-i, FMagenta, FYellow, FBlack)) + else + row[j] := RGBtoRGBQuad(GetWebSafe(CMYKtoTColor(255-i, FMagenta, FYellow, FBlack))); + end; + end; +end; + +procedure TCColorPicker.SetCyan(C: integer); +begin + 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); + end; +end; + +procedure TCColorPicker.SetMagenta(m: integer); +begin + 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); + end; +end; + +procedure TCColorPicker.SetYellow(y: integer); +begin + 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); + end; +end; + +procedure TCColorPicker.SetBlack(k: integer); +begin + 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); + end; +end; + +function TCColorPicker.ArrowPosFromCyan(c: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*c); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TCColorPicker.CyanFromArrowPos(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; +end; + +function TCColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); +end; + +function TCColorPicker.GetSelectedValue: integer; +begin + Result := FCyan; +end; + +procedure TCColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function TCColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/CIEAColorPicker.dcr b/components/mbColorLib/CIEAColorPicker.dcr new file mode 100644 index 000000000..9d7676fc5 Binary files /dev/null and b/components/mbColorLib/CIEAColorPicker.dcr differ diff --git a/components/mbColorLib/CIEAColorPicker.pas b/components/mbColorLib/CIEAColorPicker.pas new file mode 100644 index 000000000..c85240c1f --- /dev/null +++ b/components/mbColorLib/CIEAColorPicker.pas @@ -0,0 +1,381 @@ +unit CIEAColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, Forms, + HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines; + +type + TCIEAColorPicker = class(TmbColorPickerControl) + private + FSelected: TColor; + FBmp: TBitmap; + FOnChange: TNotifyEvent; + FL, FA, FB: integer; + FManual: boolean; + dx, dy, mxx, myy: integer; + + procedure SetLValue(l: integer); + procedure SetAValue(a: integer); + procedure SetBValue(b: integer); + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + 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 DrawMarker(x, y: integer); + procedure Paint; override; + procedure CreateLABGradient; + procedure Resize; override; + procedure CreateWnd; override; + procedure CorrectCoords(var x, y: integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property SelectedColor default clFuchsia; + property LValue: integer read FL write SetLValue default 100; + property AValue: integer read FA write SetAValue default 127; + property BValue: integer read FB write SetBValue default -128; + property MarkerStyle default msCircle; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R CIEAColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TCIEAColorPicker]); +end; + +{TCIEAColorPicker} + +constructor TCIEAColorPicker.Create(AOwner: TComponent); +begin + inherited; + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.SetSize(256, 256); + Width := 256; + Height := 256; + HintFormat := 'L: %cieL B: %cieB'#13'Hex: %hex'; + FSelected := clFuchsia; + FL := 100; + FA := 127; + FB := -128; + FManual := false; + dx := 0; + dy := 0; + mxx := 0; + myy := 0; + MarkerStyle := msCircle; +end; + +destructor TCIEAColorPicker.Destroy; +begin + FBmp.Free; + inherited Destroy; +end; + +procedure TCIEAColorPicker.CreateWnd; +begin + inherited; + CreateLABGradient; +end; + +procedure TCIEAColorPicker.CreateLABGradient; +var + l, b: integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.Width := 256; + FBmp.Height := 256; + end; + + for l := 255 downto 0 do + begin + row := FBmp.Scanline[l]; + for b := 0 to 255 do + if not WebSafe then + row[b] := RGBtoRGBQuad(LabToRGB(Round(100 - l*100/255), FA, b - 128)) + else + row[b] := RGBtoRGBQuad(GetWebSafe(LabToRGB(Round(100 - l*100/255), FA, b - 128))); + end; +end; + +procedure TCIEAColorPicker.CorrectCoords(var x, y: integer); +begin + if x < 0 then x := 0; + if y < 0 then y := 0; + if x > Width - 1 then x := Width - 1; + if y > Height - 1 then y := Height - 1; +end; + +procedure TCIEAColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + CorrectCoords(x, y); + FL := Round(GetCIELValue(FSelected)); + FA := Round(GetCIEAValue(FSelected)); + FB := Round(GetCIEBValue(FSelected)); + if Assigned(FOnChange) then + FOnChange(Self); + dx := x; + dy := y; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clWhite; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +function TCIEAColorPicker.GetSelectedColor: TColor; +begin + Result := FSelected; +end; + +procedure TCIEAColorPicker.SetSelectedColor(c: TColor); +begin + if WebSafe then c := GetWebSafe(c); + FL := Round(GetCIELValue(c)); + FA := Round(GetCIEAValue(c)); + FB := Round(GetCIEBValue(c)); + FSelected := c; + FManual := false; + mxx := Round((FB+128)*(Width/255)); + myy := Round(((100-FL)*255/100)*(Height/255)); + CreateLABGradient; + Invalidate; +end; + +procedure TCIEAColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FBmp); + CorrectCoords(mxx, myy); + DrawMarker(mxx, myy); +end; + +procedure TCIEAColorPicker.Resize; +begin + FManual := false; + mxx := Round((FB+128)*(Width/255)); + myy := Round(((100-FL)*255/100)*(Height/255)); + inherited; +end; + +procedure TCIEAColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + R: TRect; +begin + inherited; + mxx := x; + myy := y; + if Button = mbLeft then + begin + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; + SetFocus; +end; + +procedure TCIEAColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; +end; + +procedure TCIEAColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if ssLeft in Shift then + begin + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; +end; + +procedure TCIEAColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure TCIEAColorPicker.SetLValue(l: integer); +begin + if l > 100 then l := 100; + if l < 0 then l := 0; + FL := l; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +procedure TCIEAColorPicker.SetAValue(a: integer); +begin + if a > 127 then a := 127; + if a < -128 then a := -128; + FA := a; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +procedure TCIEAColorPicker.SetBValue(b: integer); +begin + if b > 127 then b := 127; + if b < -128 then b := -128; + FB := b; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +function TCIEAColorPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := Canvas.Pixels[x, y]; +end; + +procedure TCIEAColorPicker.WebSafeChanged; +begin + inherited; + CreateLABGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/CIEBColorPicker.dcr b/components/mbColorLib/CIEBColorPicker.dcr new file mode 100644 index 000000000..c1b7ec9b7 Binary files /dev/null and b/components/mbColorLib/CIEBColorPicker.dcr differ diff --git a/components/mbColorLib/CIEBColorPicker.pas b/components/mbColorLib/CIEBColorPicker.pas new file mode 100644 index 000000000..bed88b022 --- /dev/null +++ b/components/mbColorLib/CIEBColorPicker.pas @@ -0,0 +1,381 @@ +unit CIEBColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, Forms, + HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines; + +type + TCIEBColorPicker = class(TmbColorPickerControl) + private + FSelected: TColor; + FBmp: TBitmap; + FOnChange: TNotifyEvent; + FL, FA, FB: integer; + FManual: boolean; + dx, dy, mxx, myy: integer; + + procedure SetLValue(l: integer); + procedure SetAValue(a: integer); + procedure SetBValue(b: integer); + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + 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 DrawMarker(x, y: integer); + procedure Paint; override; + procedure CreateLABGradient; + procedure Resize; override; + procedure CreateWnd; override; + procedure CorrectCoords(var x, y: integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property SelectedColor default clLime; + property LValue: integer read FL write SetLValue default 100; + property AValue: integer read FA write SetAValue default -128; + property BValue: integer read FB write SetBValue default 127; + property MarkerStyle default msCircle; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R CIEBColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TCIEBColorPicker]); +end; + +{TCIEBColorPicker} + +constructor TCIEBColorPicker.Create(AOwner: TComponent); +begin + inherited; + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.SetSize(256, 256); + Width := 256; + Height := 256; + HintFormat := 'L: %cieL A: %cieA'#13'Hex: %hex'; + FSelected := clLime; + FL := 100; + FA := -128; + FB := 127; + FManual := false; + dx := 0; + dy := 0; + mxx := 0; + myy := 0; + MarkerStyle := msCircle; +end; + +destructor TCIEBColorPicker.Destroy; +begin + FBmp.Free; + inherited Destroy; +end; + +procedure TCIEBColorPicker.CreateWnd; +begin + inherited; + CreateLABGradient; +end; + +procedure TCIEBColorPicker.CreateLABGradient; +var + l, a: integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.Width := 256; + FBmp.Height := 256; + end; + + for l := 255 downto 0 do + begin + row := FBmp.Scanline[l]; + for a := 0 to 255 do + if not WebSafe then + row[a] := RGBtoRGBQuad(LabToRGB(Round(100 - l*100/255), a-128, FB)) + else + row[a] := RGBtoRGBQuad(GetWebSafe(LabToRGB(Round(100 - l*100/255), a-128, FB))); + end; +end; + +procedure TCIEBColorPicker.CorrectCoords(var x, y: integer); +begin + if x < 0 then x := 0; + if y < 0 then y := 0; + if x > Width - 1 then x := Width - 1; + if y > Height - 1 then y := Height - 1; +end; + +procedure TCIEBColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + CorrectCoords(x, y); + FL := Round(GetCIELValue(FSelected)); + FA := Round(GetCIEAValue(FSelected)); + FB := Round(GetCIEBValue(FSelected)); + if Assigned(FOnChange) then + FOnChange(Self); + dx := x; + dy := y; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clWhite; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +function TCIEBColorPicker.GetSelectedColor: TColor; +begin + Result := FSelected; +end; + +procedure TCIEBColorPicker.SetSelectedColor(c: TColor); +begin + if WebSafe then c := GetWebSafe(c); + FL := Round(GetCIELValue(c)); + FA := Round(GetCIEAValue(c)); + FB := Round(GetCIEBValue(c)); + FSelected := c; + FManual := false; + mxx := Round((FA+128)*(Width/255)); + myy := Round(((100-FL)*255/100)*(Height/255)); + CreateLABGradient; + Invalidate; +end; + +procedure TCIEBColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FBmp); + CorrectCoords(mxx, myy); + DrawMarker(mxx, myy); +end; + +procedure TCIEBColorPicker.Resize; +begin + FManual := false; + mxx := Round((FA+128)*(Width/255)); + myy := Round(((100-FL)*255/100)*(Height/255)); + inherited; +end; + +procedure TCIEBColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + R: TRect; +begin + inherited; + mxx := x; + myy := y; + if Button = mbLeft then + begin + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; + SetFocus; +end; + +procedure TCIEBColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; +end; + +procedure TCIEBColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if ssLeft in Shift then + begin + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; +end; + +procedure TCIEBColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure TCIEBColorPicker.SetLValue(l: integer); +begin + if l > 100 then l := 100; + if l < 0 then l := 0; + FL := l; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +procedure TCIEBColorPicker.SetAValue(a: integer); +begin + if a > 127 then a := 127; + if a < -128 then a := -128; + FA := a; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +procedure TCIEBColorPicker.SetBValue(b: integer); +begin + if b > 127 then b := 127; + if b < -128 then b := -128; + FB := b; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +function TCIEBColorPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := Canvas.Pixels[x, y]; +end; + +procedure TCIEBColorPicker.WebSafeChanged; +begin + inherited; + CreateLABGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/CIELColorPicker.dcr b/components/mbColorLib/CIELColorPicker.dcr new file mode 100644 index 000000000..8f399a7fc Binary files /dev/null and b/components/mbColorLib/CIELColorPicker.dcr differ diff --git a/components/mbColorLib/CIELColorPicker.pas b/components/mbColorLib/CIELColorPicker.pas new file mode 100644 index 000000000..bb98c0cc9 --- /dev/null +++ b/components/mbColorLib/CIELColorPicker.pas @@ -0,0 +1,383 @@ +unit CIELColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, Forms, + HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines; + +type + TCIELColorPicker = class(TmbColorPickerControl) + private + FSelected: TColor; + FBmp: TBitmap; + FOnChange: TNotifyEvent; + FL, FA, FB: integer; + FManual: boolean; + dx, dy, mxx, myy: integer; + + procedure SetLValue(l: integer); + procedure SetAValue(a: integer); + procedure SetBValue(b: integer); + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + 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 DrawMarker(x, y: integer); + procedure Paint; override; + procedure CreateLABGradient; + procedure Resize; override; + procedure CreateWnd; override; + procedure CorrectCoords(var x, y: integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property SelectedColor default clAqua; + property LValue: integer read FL write SetLValue default 100; + property AValue: integer read FA write SetAValue default -128; + property BValue: integer read FB write SetBValue default 127; + property MarkerStyle default msCircle; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R CIELColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TCIELColorPicker]); +end; + +{TCIELColorPicker} + +constructor TCIELColorPicker.Create(AOwner: TComponent); +begin + inherited; + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.SetSize(256, 256); + Width := 256; + Height := 256; + HintFormat := 'A: %cieA B: %cieB'#13'Hex: %hex'; + FSelected := clAqua; + FL := 100; + FA := -128; + FB := 127; + FManual := false; + dx := 0; + dy := 0; + mxx := 0; + myy := 0; + MarkerStyle := msCircle; +end; + +destructor TCIELColorPicker.Destroy; +begin + FBmp.Free; + inherited Destroy; +end; + +procedure TCIELColorPicker.CreateWnd; +begin + inherited; + CreateLABGradient; +end; + +procedure TCIELColorPicker.CreateLABGradient; +var + a, b: integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.Width := 256; + FBmp.Height := 256; + end; + + for a := 0 to 255 do + for b := 255 downto 0 do + begin + row := FBmp.Scanline[255 - b]; + if not WebSafe then + row[a] := RGBToRGBQuad(LabToRGB(FL, a - 128, b - 128)) +// FBmp.Canvas.Pixels[a, 255 - b] := LabToRGB(FL, a - 128, b - 128) + else + row[a] := RGBToRGBQuad(GetWebSafe(LabToRGB(FL, a - 128, b - 128))); +// FBmp.Canvas.Pixels[a, 255 - b] := GetWebSafe(LabToRGB(FL, a - 128, b - 128)); + end; +end; + +procedure TCIELColorPicker.CorrectCoords(var x, y: integer); +begin + if x < 0 then x := 0; + if y < 0 then y := 0; + if x > Width - 1 then x := Width - 1; + if y > Height - 1 then y := Height - 1; +end; + +procedure TCIELColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + CorrectCoords(x, y); + FL := Round(GetCIELValue(FSelected)); + FA := Round(GetCIEAValue(FSelected)); + FB := Round(GetCIEBValue(FSelected)); + if Assigned(FOnChange) then + FOnChange(Self); + dx := x; + dy := y; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clWhite; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +function TCIELColorPicker.GetSelectedColor: TColor; +begin + Result := FSelected; +end; + +procedure TCIELColorPicker.SetSelectedColor(c: TColor); +begin + if WebSafe then c := GetWebSafe(c); + FL := Round(GetCIELValue(c)); + FA := Round(GetCIEAValue(c)); + FB := Round(GetCIEBValue(c)); + FSelected := c; + FManual := false; + mxx := Round((FA+128)*(Width/255)); + myy := Round((255-(FB+128))*(Height/255)); + CreateLABGradient; + Invalidate; +end; + +procedure TCIELColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FBmp); + CorrectCoords(mxx, myy); + DrawMarker(mxx, myy); +end; + +procedure TCIELColorPicker.Resize; +begin + FManual := false; + mxx := Round((FA+128)*(Width/255)); + myy := Round((255-(FB+128))*(Height/255)); + inherited; +end; + +procedure TCIELColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + R: TRect; +begin + inherited; + mxx := x; + myy := y; + if Button = mbLeft then + begin + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; + SetFocus; +end; + +procedure TCIELColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; +end; + +procedure TCIELColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if ssLeft in Shift then + begin + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; +end; + +procedure TCIELColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure TCIELColorPicker.SetLValue(l: integer); +begin + if l > 100 then l := 100; + if l < 0 then l := 0; + FL := l; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +procedure TCIELColorPicker.SetAValue(a: integer); +begin + if a > 127 then a := 127; + if a < -128 then a := -128; + FA := a; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +procedure TCIELColorPicker.SetBValue(b: integer); +begin + if b > 127 then b := 127; + if b < -128 then b := -128; + FB := b; + SetSelectedColor(LabToRGB(FL, FA, FB)); +end; + +function TCIELColorPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := Canvas.Pixels[x, y]; +end; + +procedure TCIELColorPicker.WebSafeChanged; +begin + inherited; + CreateLABGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/Demo/Demo.ico b/components/mbColorLib/Demo/Demo.ico new file mode 100644 index 000000000..0341321b5 Binary files /dev/null and b/components/mbColorLib/Demo/Demo.ico differ diff --git a/components/mbColorLib/Demo/Demo.lpi b/components/mbColorLib/Demo/Demo.lpi new file mode 100644 index 000000000..33e1ffed0 --- /dev/null +++ b/components/mbColorLib/Demo/Demo.lpi @@ -0,0 +1,82 @@ + + + + + + + + + + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <TextName Value="CompanyName.ProductName.AppName"/> + <TextDesc Value="Your application description."/> + </XPManifest> + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="mbColorLibLaz"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="Demo.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="main.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="Demo"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/mbColorLib/Demo/Demo.lpr b/components/mbColorLib/Demo/Demo.lpr new file mode 100644 index 000000000..21f19b07e --- /dev/null +++ b/components/mbColorLib/Demo/Demo.lpr @@ -0,0 +1,17 @@ +program Demo; + +{$mode objfpc}{$H+} + +uses + Interfaces, // this includes the LCL widgetset + Forms, + main in 'main.pas' {Form1}; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/components/mbColorLib/Demo/MXS Website.url b/components/mbColorLib/Demo/MXS Website.url new file mode 100644 index 000000000..2eac68223 --- /dev/null +++ b/components/mbColorLib/Demo/MXS Website.url @@ -0,0 +1,4 @@ +[InternetShortcut] +URL=http://mxs.bergsoft.net +IconIndex=1 +IconFile="D:\Prog_Lazarus\svn\lazarus-ccr\components\mbColorLib\Demo\Demo.exe" diff --git a/components/mbColorLib/Demo/clr.ico b/components/mbColorLib/Demo/clr.ico new file mode 100644 index 000000000..f31b60547 Binary files /dev/null and b/components/mbColorLib/Demo/clr.ico differ diff --git a/components/mbColorLib/Demo/main.lfm b/components/mbColorLib/Demo/main.lfm new file mode 100644 index 000000000..7f51e68fe --- /dev/null +++ b/components/mbColorLib/Demo/main.lfm @@ -0,0 +1,1125 @@ +object Form1: TForm1 + Left = 222 + Height = 338 + Top = 89 + Width = 541 + Caption = 'mbColor Lib v2.0.1 Demo' + ClientHeight = 338 + ClientWidth = 541 + Color = clBtnFace + 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 + Top = 8 + Width = 66 + Anchors = [akTop, akRight] + Caption = 'SelectedColor' + ParentColor = False + end + object Label2: TLabel + Left = 410 + Height = 13 + Top = 112 + Width = 86 + Anchors = [akTop, akRight] + Caption = 'ColorUnderCursor' + ParentColor = False + end + object Label5: TLabel + Left = 410 + Height = 65 + Top = 238 + Width = 92 + 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 + Top = 6 + Width = 397 + ActivePage = TabSheet8 + Anchors = [akTop, akLeft, akRight, akBottom] + TabIndex = 8 + TabOrder = 0 + object TabSheet1: TTabSheet + Caption = 'HSLColorPicker' + ClientHeight = 0 + ClientWidth = 0 + object HSLColorPicker1: THSLColorPicker + Left = 8 + Height = 283 + Top = 8 + Width = 375 + SelectedColor = 639239 + HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex' + LPickerHintFormat = 'Luminance: %l' + Anchors = [akTop, akLeft, akRight, akBottom] + TabOrder = 0 + OnChange = HSLColorPicker1Change + OnMouseMove = HSLColorPicker1MouseMove + end + end + object TabSheet2: TTabSheet + Caption = 'HexaColorPicker' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 1 + object Label4: TLabel + Left = 82 + Height = 13 + Top = 278 + Width = 37 + Anchors = [akLeft, akBottom] + Caption = 'Marker:' + ParentColor = False + end + object HexaColorPicker1: THexaColorPicker + Left = 48 + Height = 267 + Top = 4 + Width = 283 + Anchors = [akTop, akLeft, akRight, akBottom] + HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' + IntensityText = 'Intensity' + TabOrder = 0 + Constraints.MinHeight = 85 + Constraints.MinWidth = 93 + OnChange = HexaColorPicker1Change + OnMouseMove = HexaColorPicker1MouseMove + end + object CheckBox1: TCheckBox + Left = 4 + Height = 17 + Top = 274 + Width = 75 + Anchors = [akLeft, akBottom] + Caption = 'SliderVisible' + Checked = True + OnClick = CheckBox1Click + State = cbChecked + TabOrder = 1 + end + object ComboBox1: TComboBox + Left = 124 + Height = 21 + Top = 274 + Width = 71 + Anchors = [akLeft, akBottom] + ItemHeight = 13 + ItemIndex = 0 + Items.Strings = ( + 'smArrow' + 'smRect' + ) + OnChange = ComboBox1Change + Style = csDropDownList + TabOrder = 2 + Text = 'smArrow' + end + object CheckBox2: TCheckBox + Left = 200 + Height = 17 + Top = 276 + Width = 97 + Anchors = [akLeft, akBottom] + Caption = 'NewArrowStyle' + OnClick = CheckBox2Click + TabOrder = 3 + end + end + object TabSheet3: TTabSheet + Caption = 'mbColorPalette' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 2 + object Label3: TLabel + Left = 6 + Height = 13 + Top = 272 + Width = 24 + Anchors = [akLeft, akBottom] + Caption = 'Sort:' + ParentColor = False + end + object Label6: TLabel + Left = 214 + Height = 13 + Top = 272 + Width = 28 + Anchors = [akLeft, akBottom] + Caption = 'Style:' + ParentColor = False + end + object Label7: TLabel + Left = 320 + Height = 13 + Top = 272 + Width = 23 + Anchors = [akLeft, akBottom] + Caption = 'Size:' + ParentColor = False + end + object Button1: TButton + Left = 6 + Height = 25 + Top = 232 + Width = 107 + Anchors = [akLeft, akBottom] + Caption = 'Generate blue pal' + OnClick = Button1Click + TabOrder = 0 + end + object Button2: TButton + Left = 120 + Height = 25 + Top = 232 + Width = 135 + Anchors = [akLeft, akBottom] + Caption = 'Generate gradient pal' + OnClick = Button2Click + TabOrder = 1 + end + object Button4: TButton + Left = 262 + Height = 25 + Top = 232 + Width = 121 + Anchors = [akLeft, akBottom] + Caption = 'Load palette from file' + OnClick = Button4Click + TabOrder = 2 + end + object ScrollBox1: TScrollBox + Left = 6 + Height = 217 + Top = 8 + Width = 379 + HorzScrollBar.Page = 75 + VertScrollBar.Page = 217 + Anchors = [akTop, akLeft, akRight, akBottom] + BorderStyle = bsNone + ClientHeight = 217 + ClientWidth = 362 + TabOrder = 3 + object mbColorPalette1: TmbColorPalette + Left = 0 + Height = 234 + Top = 0 + Width = 360 + Align = alTop + Colors.Strings = ( + 'clBlack' + '$00330000' + '$00660000' + '$00990000' + '$00CC0000' + 'clBlue' + '$00FF3300' + '$00CC3300' + '$00993300' + '$00663300' + '$00333300' + '$00003300' + '$00000033' + '$00330033' + '$00660033' + '$00990033' + '$00CC0033' + '$00FF0033' + '$00FF3333' + '$00CC3333' + '$00993333' + '$00663333' + '$00333333' + '$00003333' + '$00000066' + '$00330066' + '$00660066' + '$00990066' + '$00CC0066' + '$00FF0066' + '$00FF3366' + '$00CC3366' + '$00993366' + '$00663366' + '$00333366' + '$00003366' + '$00000099' + '$00330099' + '$00660099' + '$00990099' + '$00CC0099' + '$00FF0099' + '$00FF3399' + '$00CC3399' + '$00993399' + '$00663399' + '$00333399' + '$00003399' + '$000000CC' + '$003300CC' + '$006600CC' + '$009900CC' + '$00CC00CC' + '$00FF00CC' + '$00FF33CC' + '$00CC33CC' + '$009933CC' + '$006633CC' + '$003333CC' + '$000033CC' + 'clRed' + '$003300FF' + '$006600FF' + '$009900FF' + '$00CC00FF' + 'clFuchsia' + '$00FF33FF' + '$00CC33FF' + '$009933FF' + '$006633FF' + '$003333FF' + '$000033FF' + '$000066FF' + '$003366FF' + '$006666FF' + '$009966FF' + '$00CC66FF' + '$00FF66FF' + '$00FF99FF' + '$00CC99FF' + '$009999FF' + '$006699FF' + '$003399FF' + '$000099FF' + '$000066CC' + '$003366CC' + '$006666CC' + '$009966CC' + '$00CC66CC' + '$00FF66CC' + '$00FF99CC' + '$00CC99CC' + '$009999CC' + '$006699CC' + '$003399CC' + '$000099CC' + '$00006699' + '$00336699' + '$00666699' + '$00996699' + '$00CC6699' + '$00FF6699' + '$00FF9999' + '$00CC9999' + '$00999999' + '$00669999' + '$00339999' + '$00009999' + '$00006666' + '$00336666' + '$00666666' + '$00996666' + '$00CC6666' + '$00FF6666' + '$00FF9966' + '$00CC9966' + '$00999966' + '$00669966' + '$00339966' + '$00009966' + '$00006633' + '$00336633' + '$00666633' + '$00996633' + '$00CC6633' + '$00FF6633' + '$00FF9933' + '$00CC9933' + '$00999933' + '$00669933' + '$00339933' + '$00009933' + '$00006600' + '$00336600' + '$00666600' + '$00996600' + '$00CC6600' + '$00FF6600' + '$00FF9900' + '$00CC9900' + '$00999900' + '$00669900' + '$00339900' + '$00009900' + '$0000CC00' + '$0033CC00' + '$0066CC00' + '$0099CC00' + '$00CCCC00' + '$00FFCC00' + 'clAqua' + '$00CCFF00' + '$0099FF00' + '$0066FF00' + '$0033FF00' + 'clLime' + '$0000CC33' + '$0033CC33' + '$0066CC33' + '$0099CC33' + '$00CCCC33' + '$00FFCC33' + '$00FFFF33' + '$00CCFF33' + '$0099FF33' + '$0066FF33' + '$0033FF33' + '$0000FF33' + '$0000CC66' + '$0033CC66' + '$0066CC66' + '$0099CC66' + '$00CCCC66' + '$00FFCC66' + '$00FFFF66' + '$00CCFF66' + '$0099FF66' + '$0066FF66' + '$0033FF66' + '$0000FF66' + '$0000CC99' + '$0033CC99' + '$0066CC99' + '$0099CC99' + '$00CCCC99' + '$00FFCC99' + '$00FFFF99' + '$00CCFF99' + '$0099FF99' + '$0066FF99' + '$0033FF99' + '$0000FF99' + '$0000CCCC' + '$0033CCCC' + '$0066CCCC' + '$0099CCCC' + '$00CCCCCC' + '$00FFCCCC' + '$00FFFFCC' + '$00CCFFCC' + '$0099FFCC' + '$0066FFCC' + '$0033FFCC' + '$0000FFCC' + '$0000CCFF' + '$0033CCFF' + '$0066CCFF' + '$0099CCFF' + '$00CCCCFF' + '$00FFCCFF' + 'clWhite' + '$00CCFFFF' + '$0099FFFF' + '$0066FFFF' + '$0033FFFF' + 'clYellow' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + '$00000099' + '$00009999' + '$00009900' + '$00999900' + '$00990000' + '$00990099' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clRed' + 'clYellow' + 'clLime' + 'clAqua' + 'clBlue' + 'clFuchsia' + 'clWhite' + '$00CCCCCC' + '$00999999' + '$00666666' + '$00333333' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + 'clBlack' + ) + HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' + AutoHeight = True + TabOrder = 0 + OnSelColorChange = mbColorPalette1SelColorChange + OnMouseMove = mbColorPalette1MouseMove + end + end + object ComboBox2: TComboBox + Left = 34 + Height = 21 + Top = 266 + Width = 87 + Anchors = [akLeft, akBottom] + ItemHeight = 13 + ItemIndex = 0 + Items.Strings = ( + 'soAscending' + 'soDescending' + ) + OnChange = ComboBox2Change + Style = csDropDownList + TabOrder = 4 + Text = 'soAscending' + end + object ComboBox3: TComboBox + Left = 124 + Height = 21 + Top = 266 + Width = 87 + Anchors = [akLeft, akBottom] + ItemHeight = 13 + ItemIndex = 7 + Items.Strings = ( + 'smRed' + 'smGreen' + 'smBlue' + 'smHue' + 'smSaturation' + 'smLuminance' + 'smValue' + 'smNone' + 'smCyan' + 'smMagenta' + 'smYellow' + 'smBlacK' + 'smCIEx' + 'smCIEy' + 'smCIEz' + 'smCIEl' + 'smCIEa' + 'smCIEb' + ) + OnChange = ComboBox3Change + Style = csDropDownList + TabOrder = 5 + Text = 'smNone' + end + object ComboBox4: TComboBox + Left = 244 + Height = 21 + Top = 266 + Width = 71 + Anchors = [akLeft, akBottom] + ItemHeight = 13 + ItemIndex = 0 + Items.Strings = ( + 'csDefault' + 'csCorel' + ) + OnChange = ComboBox4Change + Style = csDropDownList + TabOrder = 6 + Text = 'csDefault' + end + object UpDown1: TUpDown + Left = 348 + Height = 21 + Top = 266 + Width = 31 + Anchors = [akLeft, akBottom] + Min = 0 + OnChanging = UpDown1Changing + Position = 18 + TabOrder = 7 + Thousands = False + Wrap = True + end + end + object TabSheet4: TTabSheet + Caption = 'HSLRingPicker' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 3 + object HSLRingPicker1: THSLRingPicker + Left = 50 + Height = 285 + Top = 6 + Width = 291 + RingPickerHintFormat = 'Hue: %h' + SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex' + Anchors = [akTop, akLeft, akRight, akBottom] + TabOrder = 0 + OnChange = HSLRingPicker1Change + OnMouseMove = HSLRingPicker1MouseMove + end + end + object TabSheet5: TTabSheet + Caption = 'HSVColorPicker' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 4 + object HSVColorPicker1: THSVColorPicker + Left = 24 + Height = 285 + Top = 6 + Width = 297 + HintFormat = 'H: %h S: %s V: %v'#13'Hex: %hex' + Anchors = [akTop, akLeft, akRight, akBottom] + TabOrder = 0 + OnMouseMove = HSVColorPicker1MouseMove + OnChange = HSVColorPicker1Change + end + object VColorPicker2: TVColorPicker + Left = 332 + Height = 293 + Top = 2 + Width = 22 + HintFormat = 'Value: %v' + NewArrowStyle = True + Anchors = [akTop, akRight, akBottom] + TabOrder = 1 + OnChange = VColorPicker2Change + SelectedColor = clWhite + end + end + object TabSheet6: TTabSheet + Caption = 'SLHColorPicker' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 5 + object SLHColorPicker1: TSLHColorPicker + Left = 6 + Height = 287 + Top = 6 + Width = 379 + HPickerHintFormat = 'Hue: %h' + SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex' + Anchors = [akTop, akLeft, akRight, akBottom] + TabOrder = 0 + OnChange = SLHColorPicker1Change + OnMouseMove = SLHColorPicker1MouseMove + end + end + object TabSheet11: TTabSheet + Caption = 'Lists && Trees' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 10 + object mbColorList1: TmbColorList + Left = 192 + Height = 244 + Top = 12 + Width = 183 + TabOrder = 0 + end + object mbColorTree1: TmbColorTree + Left = 8 + Height = 247 + Top = 10 + Width = 171 + InfoLabelText = 'Color Values:' + InfoDisplay1 = 'RGB: %r.%g.%b' + InfoDisplay2 = 'HEX: #%hex' + Indent = 51 + TabOrder = 1 + end + object Button5: TButton + Left = 120 + Height = 25 + Top = 264 + Width = 137 + Caption = 'Add colors from palette' + OnClick = Button5Click + TabOrder = 2 + end + end + object TabSheet7: TTabSheet + Caption = 'More' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 6 + object Label9: TLabel + Left = 118 + Height = 13 + Top = 8 + Width = 103 + Caption = 'HintFormat variables:' + ParentColor = False + end + object mbDeskPickerButton1: TmbDeskPickerButton + Left = 8 + Height = 25 + Top = 8 + Width = 93 + Caption = 'Pick from screen' + TabOrder = 0 + OnSelColorChange = mbDeskPickerButton1SelColorChange + ScreenHintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' + end + object Button3: TButton + Left = 8 + Height = 25 + Top = 40 + Width = 93 + Caption = 'OfficeColorDialog' + OnClick = Button3Click + TabOrder = 1 + end + object LColorPicker1: TLColorPicker + Left = 36 + Height = 25 + Top = 148 + Width = 329 + HintFormat = 'Luminance: %l' + Layout = lyHorizontal + SelectionIndicator = siRect + TabOrder = 2 + Saturation = 238 + Luminance = 60 + SelectedColor = 263284 + end + object VColorPicker1: TVColorPicker + Left = 34 + Height = 21 + Top = 116 + Width = 335 + HintFormat = 'Value: %v' + Layout = lyHorizontal + ArrowPlacement = spBefore + NewArrowStyle = True + SelectionIndicator = siRect + TabOrder = 3 + Hue = 240 + Saturation = 255 + Value = 40 + SelectedColor = 2621440 + end + object HColorPicker1: THColorPicker + Left = 36 + Height = 61 + Top = 178 + Width = 335 + HintFormat = 'Hue: %h' + Increment = 5 + ArrowPlacement = spBoth + SelectionIndicator = siRect + TabOrder = 4 + Saturation = 120 + SelectedColor = 8882175 + end + object SColorPicker1: TSColorPicker + Left = 8 + Height = 214 + Top = 70 + Width = 19 + HintFormat = 'Saturation: %s' + Layout = lyVertical + ArrowPlacement = spBefore + NewArrowStyle = True + SelectionIndicator = siRect + TabOrder = 5 + Hue = 60 + Saturation = 80 + SelectedColor = 11534335 + end + object Memo1: TMemo + Left = 118 + Height = 75 + Top = 24 + Width = 247 + Lines.Strings = ( + 'The following variables will be replaced in the ' + 'hint at runtime:' + '' + '%hex = HTML HEX color value' + '' + '%cieL = CIE L*a*b* Luminance value' + '%cieA = CIE L*a*b* A-Chrominance value' + '%cieB = CIE L*a*b* B-Chrominance value' + '' + '%cieX = CIE XYZ X value' + '%cieY = CIE XYZ Y value' + '%cieZ = CIE XYZ Z value' + '' + '%cieC = CIE LCH Chrominance value' + '%cieH = CIE LCH Hue value' + '' + '%hslH = HSL Hue value' + '%hslS = HSL Saturation value' + '%hslL = HSL Luminance value' + '' + '%hsvH = HSV Hue value' + '%hsvS = HSV Saturation value' + '%hsvV = HSV Value value' + '' + '%r = RGB Red value' + '%g = RGB Green value' + '%b = RGB Blue value' + '' + '%c = CMYK Cyan value' + '%m = CMYK Magenta value' + '%y = CMYK Yellow value' + '%k = CMYK blacK value' + '' + '%h = HSL Hue value' + '%l = HSL Luminance value' + '%v = HSV Value value' + ) + ScrollBars = ssVertical + TabOrder = 6 + end + end + object TabSheet8: TTabSheet + Caption = 'Other' + ClientHeight = 299 + ClientWidth = 389 + ImageIndex = 7 + object HSColorPicker1: THSColorPicker + Left = 6 + Height = 155 + Top = 6 + Width = 211 + SelectedColor = 518633 + HintFormat = 'H: %h S: %s'#13'Hex: %hex' + TabOrder = 0 + OnMouseMove = HSColorPicker1MouseMove + HueValue = 60 + MarkerStyle = msSquare + OnChange = HSColorPicker1Change + end + object SLColorPicker1: TSLColorPicker + Left = 222 + Height = 147 + Top = 144 + Width = 161 + HintFormat = 'H: %h S: %s L: %l'#13'Hex: %hex' + TabOrder = 1 + OnMouseMove = SLColorPicker1MouseMove + MarkerStyle = msCross + OnChange = SLColorPicker1Change + end + object HRingPicker1: THRingPicker + Left = 4 + Height = 130 + Top = 164 + Width = 133 + HintFormat = 'Hue: %h' + TabOrder = 2 + OnMouseMove = HRingPicker1MouseMove + OnChange = HRingPicker1Change + end + end + object TabSheet9: TTabSheet + Caption = 'Even more' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 8 + object Label8: TLabel + Left = 6 + Height = 13 + Top = 4 + Width = 128 + Caption = 'New: border styles added.' + ParentColor = False + end + object CColorPicker1: TCColorPicker + Left = 4 + Height = 267 + Top = 18 + Width = 22 + HintFormat = 'Cyan: %c' + TabOrder = 0 + SelectedColor = clAqua + end + object MColorPicker1: TMColorPicker + Left = 34 + Height = 267 + Top = 18 + Width = 22 + HintFormat = 'Magenta: %m' + ArrowPlacement = spBefore + TabOrder = 1 + SelectedColor = clFuchsia + end + object YColorPicker1: TYColorPicker + Left = 68 + Height = 267 + Top = 18 + Width = 31 + HintFormat = 'Yellow: %y' + ArrowPlacement = spBoth + TabOrder = 2 + SelectedColor = clYellow + end + object KColorPicker1: TKColorPicker + Left = 120 + Height = 267 + Top = 18 + Width = 22 + HintFormat = 'Black: %k' + NewArrowStyle = True + TabOrder = 3 + Cyan = 0 + Black = 255 + SelectedColor = clBlack + end + object RColorPicker1: TRColorPicker + Left = 150 + Height = 268 + Top = 18 + Width = 22 + HintFormat = 'Red: %r' + ArrowPlacement = spBefore + NewArrowStyle = True + TabOrder = 4 + SelectedColor = 8026879 + end + object GColorPicker1: TGColorPicker + Left = 182 + Height = 268 + Top = 18 + Width = 34 + HintFormat = 'Green: %g' + ArrowPlacement = spBoth + NewArrowStyle = True + TabOrder = 5 + SelectedColor = 8060794 + end + object BColorPicker1: TBColorPicker + Left = 224 + Height = 268 + Top = 18 + Width = 22 + HintFormat = 'Blue: %b' + SelectionIndicator = siRect + TabOrder = 6 + SelectedColor = 16743034 + end + object KColorPicker2: TKColorPicker + Left = 274 + Height = 71 + Top = 22 + Width = 69 + BevelInner = bvRaised + BevelOuter = bvRaised + BorderStyle = bsSingle + HintFormat = 'Black: %k' + ArrowPlacement = spBoth + NewArrowStyle = True + TabOrder = 7 + Cyan = 0 + Black = 255 + SelectedColor = clBlack + end + object MColorPicker2: TMColorPicker + Left = 272 + Height = 55 + Top = 96 + Width = 91 + BevelInner = bvLowered + BevelOuter = bvRaised + BorderStyle = bsSingle + HintFormat = 'Magenta: %m' + Layout = lyHorizontal + ArrowPlacement = spBoth + NewArrowStyle = True + TabOrder = 8 + SelectedColor = clFuchsia + end + object CColorPicker2: TCColorPicker + Left = 274 + Height = 67 + Top = 152 + Width = 61 + BevelInner = bvRaised + BevelOuter = bvLowered + BorderStyle = bsSingle + HintFormat = 'Cyan: %c' + ArrowPlacement = spBoth + NewArrowStyle = True + TabOrder = 9 + SelectedColor = clAqua + end + object YColorPicker2: TYColorPicker + Left = 272 + Height = 57 + Top = 228 + Width = 81 + BevelInner = bvLowered + BevelOuter = bvLowered + BorderStyle = bsSingle + HintFormat = 'Yellow: %y' + ArrowPlacement = spBoth + NewArrowStyle = True + TabOrder = 10 + SelectedColor = clYellow + end + end + object TabSheet10: TTabSheet + Caption = 'Yet even more' + ClientHeight = 0 + ClientWidth = 0 + ImageIndex = 9 + object RAxisColorPicker1: TRAxisColorPicker + Left = 10 + Height = 100 + Top = 8 + Width = 100 + HintFormat = 'G: %g B: %b'#13'Hex: %hex' + TabOrder = 0 + end + object GAxisColorPicker1: TGAxisColorPicker + Left = 130 + Height = 100 + Top = 10 + Width = 100 + HintFormat = 'R: %r B: %b'#13'Hex: %hex' + TabOrder = 1 + MarkerStyle = msCross + end + object BAxisColorPicker1: TBAxisColorPicker + Left = 252 + Height = 100 + Top = 10 + Width = 100 + HintFormat = 'R: %r G: %g'#13'Hex: %hex' + TabOrder = 2 + MarkerStyle = msCrossCirc + end + object CIELColorPicker1: TCIELColorPicker + Left = 8 + Height = 100 + Top = 130 + Width = 100 + SelectedColor = 16119089 + HintFormat = 'A: %cieA B: %cieB'#13'Hex: %hex' + TabOrder = 3 + LValue = 88 + AValue = -47 + BValue = -32 + end + object CIEAColorPicker1: TCIEAColorPicker + Left = 128 + Height = 100 + Top = 130 + Width = 100 + SelectedColor = 16515327 + HintFormat = 'L: %cieL B: %cieB'#13'Hex: %hex' + TabOrder = 4 + LValue = 60 + AValue = 96 + BValue = -78 + MarkerStyle = msSquare + end + object CIEBColorPicker1: TCIEBColorPicker + Left = 250 + Height = 100 + Top = 130 + Width = 100 + SelectedColor = 130823 + HintFormat = 'L: %cieL A: %cieA'#13'Hex: %hex' + TabOrder = 5 + LValue = 88 + AValue = -88 + BValue = 74 + end + end + end + object sc: TmbColorPreview + Left = 410 + Height = 62 + Top = 24 + Width = 108 + Color = clNone + Anchors = [akTop, akRight] + end + object uc: TmbColorPreview + Left = 410 + Height = 62 + Top = 130 + Width = 108 + Color = clNone + Anchors = [akTop, akRight] + end + object tb1: TTrackBar + Left = 410 + Height = 20 + Hint = 'Opacity' + Top = 90 + Width = 108 + Max = 100 + OnChange = tb1Change + Position = 100 + TickStyle = tsNone + Anchors = [akTop, akRight] + TabOrder = 3 + end + object tb2: TTrackBar + Left = 410 + Height = 20 + Top = 196 + Width = 108 + Max = 100 + OnChange = tb2Change + Position = 100 + TickStyle = tsNone + Anchors = [akTop, akRight] + TabOrder = 4 + end + object CheckBox3: TCheckBox + Left = 443 + Height = 19 + Top = 308 + Width = 64 + Anchors = [akTop, akRight] + Caption = 'WebSafe' + OnClick = CheckBox3Click + TabOrder = 5 + end + object CheckBox4: TCheckBox + Left = 428 + Height = 19 + Top = 218 + Width = 79 + Anchors = [akTop, akRight] + Caption = 'SwatchStyle' + OnClick = CheckBox4Click + TabOrder = 6 + end + object mbOfficeColorDialog1: TmbOfficeColorDialog + UseHints = True + left = 472 + top = 302 + end + object OpenDialog1: TOpenDialog + Filter = 'JASC PAL (*.pal)|*.pal|Photoshop (*.act; *.aco)|*.act;*.aco' + left = 440 + top = 304 + end +end diff --git a/components/mbColorLib/Demo/main.pas b/components/mbColorLib/Demo/main.pas new file mode 100644 index 000000000..5a23bf02f --- /dev/null +++ b/components/mbColorLib/Demo/main.pas @@ -0,0 +1,381 @@ +unit main; + +interface + + +uses + LCLIntf, LCLType, LMessages, SysUtils, Variants,Classes, Graphics, Controls, + Forms, Dialogs, HSLColorPicker, ComCtrls, StdCtrls, mbColorPreview, + HexaColorPicker, mbColorPalette, HSLRingPicker, HSVColorPicker, PalUtils, + SLHColorPicker, mbDeskPickerButton, mbOfficeColorDialog, SColorPicker, + HColorPicker, VColorPicker, mbTrackBarPicker, LColorPicker, HRingPicker, + SLColorPicker, HSColorPicker, IniFiles, mbColorPickerControl, + BColorPicker, GColorPicker, RColorPicker, KColorPicker, YColorPicker, + MColorPicker, CColorPicker, CIEBColorPicker, CIEAColorPicker, Typinfo, + CIELColorPicker, BAxisColorPicker, GAxisColorPicker, RAxisColorPicker, + mbColorTree, mbColorList {for internet shortcuts}; + +type + TForm1 = class(TForm) + PageControl1: TPageControl; + TabSheet1: TTabSheet; + TabSheet2: TTabSheet; + TabSheet3: TTabSheet; + TabSheet4: TTabSheet; + HSLColorPicker1: THSLColorPicker; + sc: TmbColorPreview; + uc: TmbColorPreview; + Label1: TLabel; + tb1: TTrackBar; + tb2: TTrackBar; + Label2: TLabel; + HexaColorPicker1: THexaColorPicker; + mbColorPalette1: TmbColorPalette; + Button1: TButton; + Button2: TButton; + HSLRingPicker1: THSLRingPicker; + TabSheet5: TTabSheet; + TabSheet6: TTabSheet; + HSVColorPicker1: THSVColorPicker; + SLHColorPicker1: TSLHColorPicker; + TabSheet7: TTabSheet; + TabSheet8: TTabSheet; + mbDeskPickerButton1: TmbDeskPickerButton; + mbOfficeColorDialog1: TmbOfficeColorDialog; + Button3: TButton; + LColorPicker1: TLColorPicker; + VColorPicker1: TVColorPicker; + HColorPicker1: THColorPicker; + SColorPicker1: TSColorPicker; + HSColorPicker1: THSColorPicker; + SLColorPicker1: TSLColorPicker; + HRingPicker1: THRingPicker; + VColorPicker2: TVColorPicker; + CheckBox1: TCheckBox; + ComboBox1: TComboBox; + Label4: TLabel; + CheckBox2: TCheckBox; + Label5: TLabel; + Button4: TButton; + OpenDialog1: TOpenDialog; + ScrollBox1: TScrollBox; + Label3: TLabel; + ComboBox2: TComboBox; + ComboBox3: TComboBox; + Label6: TLabel; + ComboBox4: TComboBox; + Label7: TLabel; + UpDown1: TUpDown; + TabSheet9: TTabSheet; + CColorPicker1: TCColorPicker; + MColorPicker1: TMColorPicker; + YColorPicker1: TYColorPicker; + KColorPicker1: TKColorPicker; + Label8: TLabel; + RColorPicker1: TRColorPicker; + GColorPicker1: TGColorPicker; + BColorPicker1: TBColorPicker; + KColorPicker2: TKColorPicker; + MColorPicker2: TMColorPicker; + CColorPicker2: TCColorPicker; + YColorPicker2: TYColorPicker; + TabSheet10: TTabSheet; + RAxisColorPicker1: TRAxisColorPicker; + GAxisColorPicker1: TGAxisColorPicker; + BAxisColorPicker1: TBAxisColorPicker; + CIELColorPicker1: TCIELColorPicker; + CIEAColorPicker1: TCIEAColorPicker; + CIEBColorPicker1: TCIEBColorPicker; + CheckBox3: TCheckBox; + TabSheet11: TTabSheet; + mbColorList1: TmbColorList; + mbColorTree1: TmbColorTree; + Button5: TButton; + Memo1: TMemo; + Label9: TLabel; + CheckBox4: TCheckBox; + procedure tb1Change(Sender: TObject); + procedure tb2Change(Sender: TObject); + procedure HSLColorPicker1Change(Sender: TObject); + procedure HSLColorPicker1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure HexaColorPicker1Change(Sender: TObject); + procedure HexaColorPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure mbColorPalette1SelColorChange(Sender: TObject); + procedure mbColorPalette1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure HSLRingPicker1Change(Sender: TObject); + procedure HSLRingPicker1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure HSVColorPicker1Change(Sender: TObject); + procedure HSVColorPicker1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure SLHColorPicker1Change(Sender: TObject); + procedure SLHColorPicker1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure mbDeskPickerButton1SelColorChange(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure HSColorPicker1Change(Sender: TObject); + procedure HSColorPicker1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure SLColorPicker1Change(Sender: TObject); + procedure SLColorPicker1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure HRingPicker1Change(Sender: TObject); + procedure HRingPicker1MouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure VColorPicker2Change(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure CheckBox1Click(Sender: TObject); + procedure ComboBox1Change(Sender: TObject); + procedure CheckBox2Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure ComboBox2Change(Sender: TObject); + procedure ComboBox3Change(Sender: TObject); + procedure ComboBox4Change(Sender: TObject); + procedure UpDown1Changing(Sender: TObject; var AllowChange: Boolean); + procedure CheckBox3Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure CheckBox4Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} +{$R mxico.res} //MXS icon resource file, for internet shortcut only + +procedure TForm1.tb1Change(Sender: TObject); +begin +sc.opacity := tb1.position; +end; + +procedure TForm1.tb2Change(Sender: TObject); +begin +uc.opacity := tb2.position; +end; + +procedure TForm1.HSLColorPicker1Change(Sender: TObject); +begin +sc.color := HSLColorPicker1.SelectedColor; +end; + +procedure TForm1.HSLColorPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.color := HSLColorPicker1.ColorUnderCursor; +end; + +procedure TForm1.HexaColorPicker1Change(Sender: TObject); +begin +sc.color := hexacolorpicker1.selectedcolor; +end; + +procedure TForm1.HexaColorPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.color := hexacolorpicker1.ColorUnderCursor; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin +mbColorPalette1.GeneratePalette(clblue); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin +mbColorpalette1.GenerateGradientPalette([clblue, clred]); +end; + +procedure TForm1.mbColorPalette1SelColorChange(Sender: TObject); +begin +sc.color := mbcolorpalette1.selectedcolor; +end; + +procedure TForm1.mbColorPalette1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.color := mbcolorpalette1.ColorUnderCursor; +end; + +procedure TForm1.HSLRingPicker1Change(Sender: TObject); +begin +sc.color := HSLRingPicker1.SelectedColor; +end; + +procedure TForm1.HSLRingPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.color := HSLRingPicker1.ColorUnderCursor; +end; + +procedure TForm1.HSVColorPicker1Change(Sender: TObject); +begin +sc.color := HSVColorPicker1.SelectedColor; +VColorPicker2.Saturation := HSVColorPicker1.Saturation; +VColorPicker2.Hue := HSVColorPicker1.Hue; +end; + +procedure TForm1.HSVColorPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.Color := HSVColorPicker1.ColorUnderCursor; +end; + +procedure TForm1.SLHColorPicker1Change(Sender: TObject); +begin +sc.color := SLHColorPicker1.SelectedColor; +end; + +procedure TForm1.SLHColorPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.color := SLHColorPicker1.ColorUnderCursor; +end; + +procedure TForm1.mbDeskPickerButton1SelColorChange(Sender: TObject); +begin +sc.color := mbDeskPickerButton1.SelectedColor; +uc.color := mbDeskPickerButton1.SelectedColor; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + if mbOfficeColorDialog1.Execute then + sc.color := mbOfficeColorDialog1.SelectedColor; +end; + +procedure TForm1.HSColorPicker1Change(Sender: TObject); +begin +sc.color := HSColorPicker1.SelectedColor; +end; + +procedure TForm1.HSColorPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.color := HSColorpicker1.ColorUnderCursor; +end; + +procedure TForm1.SLColorPicker1Change(Sender: TObject); +begin +sc.color := SLColorPicker1.SelectedColor; +end; + +procedure TForm1.SLColorPicker1MouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +uc.color := slcolorpicker1.ColorUnderCursor; +end; + +procedure TForm1.HRingPicker1Change(Sender: TObject); +begin +sc.color := hringpicker1.SelectedColor; +end; + +procedure TForm1.HRingPicker1MouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); +begin +uc.color := hringpicker1.ColorUnderCursor; +end; + +procedure TForm1.VColorPicker2Change(Sender: TObject); +begin +HSVColorPicker1.Value := VColorPicker2.Value; +end; + +// only for internet shortcuts +procedure TForm1.FormCreate(Sender: TObject); +begin + with TIniFile.Create(ExtractFilePath(Application.ExeName) + '\MXS Website.url') do + try + WriteString('InternetShortcut','URL', 'http://mxs.bergsoft.net'); + WriteInteger('InternetShortcut','IconIndex', 1); + WriteString('InternetShortcut','IconFile', '"' + Application.ExeName + '"'); + finally + Free; + end; +end; + +procedure TForm1.CheckBox1Click(Sender: TObject); +begin +HexaColorPicker1.SliderVisible := checkbox1.Checked; +end; + +procedure TForm1.ComboBox1Change(Sender: TObject); +begin +hexacolorpicker1.SliderMarker := TMArker(ComboBox1.ItemIndex); +end; + +procedure TForm1.CheckBox2Click(Sender: TObject); +begin +hexacolorpicker1.NewArrowStyle := checkbox2.checked; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + if opendialog1.Execute then + mbcolorpalette1.Palette := opendialog1.FileName; +end; + +procedure TForm1.ComboBox2Change(Sender: TObject); +begin +mbcolorpalette1.SortOrder := tsortorder(combobox2.itemindex); +end; + +procedure TForm1.ComboBox3Change(Sender: TObject); +begin +mbcolorpalette1.Sortmode := tsortmode(combobox3.ItemIndex); +end; + +procedure TForm1.ComboBox4Change(Sender: TObject); +begin +mbcolorpalette1.CellStyle := tcellstyle(combobox4.ItemIndex); +end; + +procedure TForm1.UpDown1Changing(Sender: TObject; + var AllowChange: Boolean); +begin +allowchange := true; +mbcolorpalette1.CellSize := abs(updown1.Position); +end; + +procedure TForm1.CheckBox3Click(Sender: TObject); +var + i: integer; +begin + for i := 0 to ComponentCount - 1 do + if IsPublishedProp(components[i], 'WebSafe') = true then + SetOrdProp(components[i], 'WebSafe', integer(checkbox3.checked)); +end; + +procedure TForm1.Button5Click(Sender: TObject); +var + i: integer; +begin + mbcolortree1.ClearColors; + mbcolorlist1.ClearColors; + for i := 0 to mbcolorpalette1.Colors.Count - 1 do + begin + mbcolortree1.AddColor('Color '+inttostr(i), StringtoColor(mbcolorpalette1.colors.Strings[i]), false); + mbcolorlist1.AddColor('Color '+inttostr(i), StringtoColor(mbcolorpalette1.colors.Strings[i]), false); + end; + mbcolortree1.UpdateColors; + mbcolorlist1.UpdateColors; +end; + +procedure TForm1.CheckBox4Click(Sender: TObject); +begin + sc.swatchstyle := checkbox4.Checked; + uc.swatchstyle := checkbox4.checked; +end; + +end. diff --git a/components/mbColorLib/Demo/mxico.res b/components/mbColorLib/Demo/mxico.res new file mode 100644 index 000000000..5b0aa7b37 Binary files /dev/null and b/components/mbColorLib/Demo/mxico.res differ diff --git a/components/mbColorLib/GAxisColorPicker.dcr b/components/mbColorLib/GAxisColorPicker.dcr new file mode 100644 index 000000000..494305741 Binary files /dev/null and b/components/mbColorLib/GAxisColorPicker.dcr differ diff --git a/components/mbColorLib/GAxisColorPicker.pas b/components/mbColorLib/GAxisColorPicker.pas new file mode 100644 index 000000000..dfd3f9137 --- /dev/null +++ b/components/mbColorLib/GAxisColorPicker.pas @@ -0,0 +1,380 @@ +unit GAxisColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLType, LCLIntf, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, Forms, + HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; + +type + TGAxisColorPicker = class(TmbColorPickerControl) + private + FSelected: TColor; + FBmp: TBitmap; + FOnChange: TNotifyEvent; + FR, FG, FB: integer; + FManual: boolean; + dx, dy, mxx, myy: integer; + + procedure SetRValue(r: integer); + procedure SetGValue(g: integer); + procedure SetBValue(b: integer); + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + 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 DrawMarker(x, y: integer); + procedure Paint; override; + procedure CreateRGBGradient; + procedure Resize; override; + procedure CreateWnd; override; + procedure CorrectCoords(var x, y: integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property SelectedColor default clLime; + property RValue: integer read FR write SetRValue default 0; + property GValue: integer read FG write SetGValue default 255; + property BValue: integer read FB write SetBValue default 0; + property MarkerStyle default msCircle; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R GAxisColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TGAxisColorPicker]); +end; + +{TGAxisColorPicker} + +constructor TGAxisColorPicker.Create(AOwner: TComponent); +begin + inherited; + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.SetSize(256, 256); + Width := 256; + Height := 256; + HintFormat := 'R: %r B: %b'#13'Hex: %hex'; + FG := 255; + FB := 0; + FR := 0; + FSelected := clLime; + FManual := false; + dx := 0; + dy := 0; + mxx := 0; + myy := 0; + MarkerStyle := msCircle; +end; + +destructor TGAxisColorPicker.Destroy; +begin + FBmp.Free; + inherited Destroy; +end; + +procedure TGAxisColorPicker.CreateWnd; +begin + inherited; + CreateRGBGradient; +end; + +procedure TGAxisColorPicker.CreateRGBGradient; +var + r, b : integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.Width := 256; + FBmp.Height := 256; + end; + for r := 255 downto 0 do + begin + row := FBmp.Scanline[255-r]; + for b := 0 to 255 do + if not WebSafe then + row[b] := RGBtoRGBQuad(r, FG, b) + else + row[b] := RGBtoRGBQuad(GetWebSafe(RGB(r, FG, b))); + end; +end; + +procedure TGAxisColorPicker.CorrectCoords(var x, y: integer); +begin + if x < 0 then x := 0; + if y < 0 then y := 0; + if x > Width - 1 then x := Width - 1; + if y > Height - 1 then y := Height - 1; +end; + +procedure TGAxisColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + CorrectCoords(x, y); + FR := GetRValue(FSelected); + FG := GetGValue(FSelected); + FB := GetBValue(FSelected); + if Assigned(FOnChange) then + FOnChange(Self); + dx := x; + dy := y; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clWhite; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +function TGAxisColorPicker.GetSelectedColor: TColor; +begin + Result := FSelected; +end; + +procedure TGAxisColorPicker.SetSelectedColor(c: TColor); +begin + if WebSafe then c := GetWebSafe(c); + FR := GetRValue(c); + FG := GetGValue(c); + FB := GetBValue(c); + FSelected := c; + FManual := false; + myy := Round((255-FR)*(Height/255)); + mxx := Round(FB*(Width/255)); + CreateRGBGradient; + Invalidate; +end; + +procedure TGAxisColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FBmp); + CorrectCoords(mxx, myy); + DrawMarker(mxx, myy); +end; + +procedure TGAxisColorPicker.Resize; +begin + FManual := false; + myy := Round((255-FR)*(Height/255)); + mxx := Round(FB*(Width/255)); + inherited; +end; + +procedure TGAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + R: TRect; +begin + inherited; + mxx := x; + myy := y; + if Button = mbLeft then + begin + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; + SetFocus; +end; + +procedure TGAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; +end; + +procedure TGAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if ssLeft in Shift then + begin + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; +end; + +procedure TGAxisColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure TGAxisColorPicker.SetRValue(r: integer); +begin + if r > 255 then r := 255; + if r < 0 then r := 0; + FR := r; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +procedure TGAxisColorPicker.SetGValue(g: integer); +begin + if g > 255 then g := 255; + if g < 0 then g := 0; + FG := g; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +procedure TGAxisColorPicker.SetBValue(b: integer); +begin + if b > 255 then b := 255; + if b < 0 then b := 0; + FB := b; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +function TGAxisColorPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := Canvas.Pixels[x, y]; +end; + +procedure TGAxisColorPicker.WebSafeChanged; +begin + inherited; + CreateRGBGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/GColorPicker.dcr b/components/mbColorLib/GColorPicker.dcr new file mode 100644 index 000000000..85fedc12f Binary files /dev/null and b/components/mbColorLib/GColorPicker.dcr differ diff --git a/components/mbColorLib/GColorPicker.pas b/components/mbColorLib/GColorPicker.pas new file mode 100644 index 000000000..ec410051f --- /dev/null +++ b/components/mbColorLib/GColorPicker.pas @@ -0,0 +1,264 @@ +unit GColorPicker; + +{$IFDEF FPC}{$MODE DELPHI}{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + mbTrackBarPicker, HTMLColors, Scanlines; + +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; + +procedure Register; + +implementation + +{$IFDEF FPC} +{$R GColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + 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; +end; + +procedure TGColorPicker.CreateGGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FBmp.width := 256; + FBmp.height := 12; + for i := 0 to 255 do + for j := 0 to 11 do + begin + row := FBmp.ScanLine[j]; + if not WebSafe then + row[i] := RGBtoRGBQuad(FRed, i, FBlue) +// FBmp.Canvas.Pixels[i, j] := RGB(FRed, i, FBlue) + else + row[i] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, i, FBlue))); +// FBmp.Canvas.Pixels[i, j] := GetWebSafe(RGB(FRed, i, FBlue)); + end; + end + else + begin + FBmp.width := 12; + FBmp.height := 256; + for i := 0 to 255 do + begin + row := FBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBtoRGBQuad(FRed, 255-i, FBlue) + else + row[j] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, 255-i, FBlue))); + end; + end; +end; + +procedure TGColorPicker.SetRed(r: integer); +begin + 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); + end; +end; + +procedure TGColorPicker.SetGreen(g: integer); +begin + 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); + end; +end; + +procedure TGColorPicker.SetBlue(b: integer); +begin + 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); + end; +end; + +function TGColorPicker.ArrowPosFromGreen(g: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*g); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TGColorPicker.GreenFromArrowPos(p: integer): integer; +var + 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; +end; + +function TGColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := RGB(FRed, FGreen, FBlue) + else + Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); +end; + +function TGColorPicker.GetSelectedValue: integer; +begin + Result := FGreen; +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); +end; + +function TGColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/HColorPicker.dcr b/components/mbColorLib/HColorPicker.dcr new file mode 100644 index 000000000..28e897bc1 Binary files /dev/null and b/components/mbColorLib/HColorPicker.dcr differ diff --git a/components/mbColorLib/HColorPicker.pas b/components/mbColorLib/HColorPicker.pas new file mode 100644 index 000000000..4abcc1278 --- /dev/null +++ b/components/mbColorLib/HColorPicker.pas @@ -0,0 +1,264 @@ +unit HColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; + +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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R HColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + 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; +end; + +procedure THColorPicker.CreateHGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FHBmp = nil then + begin + FHBmp := TBitmap.Create; + FHBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FHBmp.width := 360; + FHBmp.height := 12; + for i := 0 to 359 do + for j := 0 to 11 do + begin + row := FHBmp.ScanLine[j]; + if not WebSafe then + row[i] := RGBtoRGBQuad(HSVtoColor(i, FSat, FVal)) +// FHBmp.Canvas.Pixels[i, j] := HSVtoColor(i, FSat, FVal) + else + row[i] := RGBtoRGBQuad(GetWebSafe(HSVtoColor(i, FSat, FVal))); +// FHBmp.Canvas.Pixels[i, j] := GetWebSafe(HSVtoColor(i, FSat, FVal)); + end; + end + else + begin + FHBmp.width := 12; + FHBmp.height := 360; + for i := 0 to 359 do + begin + row := FHBmp.ScanLine[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBtoRGBQuad(HSVtoColor(i, FSat, FVal)) + else + row[j] := RGBtoRGBQuad(GetWebSafe(HSVtoColor(i, FSat, FVal))); + end; + end; +end; + +procedure THColorPicker.SetValue(v: integer); +begin + 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); + end; +end; + +procedure THColorPicker.SetHue(h: integer); +begin + 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); + end; +end; + +procedure THColorPicker.SetSat(s: integer); +begin + 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); + end; +end; + +function THColorPicker.ArrowPosFromHue(h: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/360)*h); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + a := Round(((Height - 12)/360)*h); + if a > Height - FLimit then a := Height - FLimit; + end; + if a < 0 then a := 0; + Result := a; +end; + +function THColorPicker.HueFromArrowPos(p: integer): integer; +var + 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; +end; + +function THColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FVal) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); +end; + +function THColorPicker.GetSelectedValue: integer; +begin + Result := FHue; +end; + +procedure THColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function THColorPicker.GetArrowPos: integer; +begin + 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; + end; +end; + +end. diff --git a/components/mbColorLib/HRingPicker.dcr b/components/mbColorLib/HRingPicker.dcr new file mode 100644 index 000000000..44649eb3a Binary files /dev/null and b/components/mbColorLib/HRingPicker.dcr differ diff --git a/components/mbColorLib/HRingPicker.pas b/components/mbColorLib/HRingPicker.pas new file mode 100644 index 000000000..2d5ccf126 --- /dev/null +++ b/components/mbColorLib/HRingPicker.pas @@ -0,0 +1,511 @@ +unit HRingPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, + Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, mbColorPickerControl, + Scanlines; + +type + THRingPicker = class(TmbColorPickerControl) + private + FHue, FSat, FValue: integer; + FHueLineColor: TColor; + FSelectedColor: TColor; + FOnChange: TNotifyEvent; + FManual: boolean; + mx, my, mdx, mdy: integer; + Fchange: boolean; + FRadius: integer; + FBMP: TBitmap; + FDoChange: boolean; + + procedure CreateHSVCircle; + function RadHue(New: integer): integer; + procedure SetRadius(r: integer); + procedure SetValue(v: integer); + procedure SetHue(h: integer); + procedure SetSat(s: integer); + procedure SetHueLineColor(c: TColor); + procedure DrawHueLine; + procedure SelectionChanged(x, y: integer); + procedure UpdateCoords; + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure Paint; override; + procedure Resize; override; + procedure CreateWnd; override; + 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 CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property Hue: integer read FHue write SetHue default 0; + property Saturation: integer read FSat write SetSat default 0; + property Value: integer read FValue write SetValue default 255; + property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray; + property SelectedColor default clNone; + property Radius: integer read FRadius write SetRadius default 30; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R HRingPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [THRingPicker]); +end; + +function PointInCirc(p: TPoint; size : integer): boolean; +var + r: integer; +begin + r := size div 2; + Result := (SQR(p.x - r) + SQR(p.y - r) <= SQR(r)); +end; + +constructor THRingPicker.Create(AOwner: TComponent); +begin + inherited; + FBMP := TBitmap.Create; + FBMP.PixelFormat := pf32bit; + Width := 204; + Height := 204; + FValue := 255; + FHue := 0; + FSat := 0; + FHueLineColor := clGray; + FSelectedColor := clNone; + FManual := false; + Fchange := true; + FRadius := 30; + FDoChange := false; +end; + +destructor THRingPicker.Destroy; +begin + FBMP.Free; + inherited; +end; + +procedure THRingPicker.CreateHSVCircle; +var + dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; + row: pRGBQuadArray; + tc: TColor; +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 + 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; + end; +end; + +procedure THRingPicker.Resize; +begin + inherited; + CreateHSVCircle; + UpdateCoords; +end; + +procedure THRingPicker.CreateWnd; +begin + inherited; + CreateHSVCircle; + UpdateCoords; +end; + +procedure THRingPicker.UpdateCoords; +var + r, angle: real; + radius: integer; +begin + radius := Min(Width, Height) div 2; + r := -MulDiv(radius, FSat, 255); + angle := -FHue*PI/180 - PI; + mdx := ROUND(COS(angle)*ROUND(r)) + radius; + mdy := ROUND(SIN(angle)*ROUND(r)) + radius; +end; + +procedure THRingPicker.SetHue(h: integer); +begin + if h > 360 then h := 360; + if h < 0 then h := 0; + if FHue <> h then + begin + FHue := h; + FManual := false; + UpdateCoords; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure THRingPicker.SetSat(s: integer); +begin + if s > 255 then s := 255; + if s < 0 then s := 0; + if FSat <> s then + begin + FSat := s; + FManual := false; + UpdateCoords; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure THRingPicker.SetValue(v: integer); +begin + if V > 255 then V := 255; + if V < 0 then V := 0; + if FValue <> V then + begin + FValue := V; + FManual := false; + CreateHSVCircle; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure THRingPicker.SetHueLineColor(c: TColor); +begin + if FHueLineColor <> c then + begin + FHueLineColor := c; + Invalidate; + end; +end; + +procedure THRingPicker.SetRadius(r: integer); +begin + if FRadius <> r then + begin + FRadius := r; + Invalidate; + end; +end; + +procedure THRingPicker.DrawHueLine; +var + angle: double; + radius: integer; +begin + Radius := Min(Width, Height) div 2; + if (FHue >= 0) and (FHue <= 360) then + begin + Angle := -FHue*PI/180; + Canvas.Pen.Color := FHueLineColor; + Canvas.MoveTo(Radius,Radius); + Canvas.LineTo(Radius + Round(Radius*COS(angle)), Radius + Round(Radius*SIN(angle))); + end; +end; + +procedure THRingPicker.Paint; +var + rgn, r1, r2: HRGN; + r: TRect; +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 + begin + if Assigned(FOnChange) then FOnChange(Self); + FDoChange := false; + end; +end; + +procedure THRingPicker.SelectionChanged(x, y: integer); +var + Angle, Distance, xDelta, yDelta, Radius: integer; +begin + if not PointInCirc(Point(x, y), Min(Width, Height)) then + begin + FChange := false; + SetSelectedColor(clNone); + FChange := true; + Exit; + end + else + FSelectedColor := clWhite; + Radius := Min(Width, Height) div 2; + xDelta := x - Radius; + yDelta := y - Radius; + Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); + if Angle < 0 then Inc(Angle, 360) + else if Angle > 360 then + Dec(Angle, 360); + Fchange := false; + SetHue(Angle); + Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); + if Distance >= Radius then SetSat(255) + else SetSat(MulDiv(Distance, 255, Radius)); + Fchange := true; +end; + +procedure THRingPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + if csDesigning in ComponentState then Exit; + if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then + begin + mdx := x; + mdy := y; + FDoChange := true; + SelectionChanged(X, Y); + FManual := true; + end; +end; + +procedure THRingPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + R: TRect; +begin + inherited; + if csDesigning in ComponentState then Exit; + if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then + begin + mdx := x; + mdy := y; + R := ClientRect; + InflateRect(R, 1, 1); + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FDoChange := true; + SelectionChanged(X, Y); + FManual := true; + end; + SetFocus; +end; + +procedure THRingPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if csDesigning in ComponentState then Exit; + if (ssLeft in Shift) and PointInCirc(Point(x, y), Min(Width, Height)) then + begin + mdx := x; + mdy := y; + FDoChange := true; + SelectionChanged(X, Y); + FManual := true; + end; +end; + +function THRingPicker.GetSelectedColor: TColor; +begin + if FSelectedColor <> clNone then + begin + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FValue) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FValue)); + end + else + Result := clNone; +end; + +function THRingPicker.GetColorAtPoint(x, y: integer): TColor; +var + Angle, Distance, xDelta, yDelta, Radius: integer; + h, s: integer; +begin + Radius := Min(Width, Height) div 2; + xDelta := x - Radius; + yDelta := y - Radius; + Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); + if Angle < 0 then Inc(Angle, 360) + else if Angle > 360 then + Dec(Angle, 360); + h := Angle; + Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); + if Distance >= Radius then s := 255 + else s := MulDiv(Distance, 255, Radius); + if PointInCirc(Point(mx, my), Min(Width, Height)) then + begin + if not WebSafe then + Result := HSVtoColor(h, s, FValue) + else + Result := GetWebSafe(HSVtoColor(h, s, FValue)); + end + else + Result := clNone; +end; + +procedure THRingPicker.SetSelectedColor(c: TColor); +var + changeSave: boolean; +begin + if WebSafe then c := GetWebSafe(c); + changeSave := FChange; + FManual := false; + Fchange := false; + SetValue(GetVValue(c)); + SetHue(GetHValue(c)); + SetSat(GetSValue(c)); + FSelectedColor := c; + Fchange := changeSave; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + FChange := true; +end; + +function THRingPicker.RadHue(New: integer): integer; +begin + if New < 0 then New := New + 360; + if New > 360 then New := New - 360; + Result := New; +end; + +procedure THRingPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + FChange := false; + SetHue(RadHue(FHue + 1)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_RIGHT: + begin + FChange := false; + SetHue(RadHue(FHue - 1)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + FChange := false; + SetHue(RadHue(FHue + 10)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_RIGHT: + begin + FChange := false; + SetHue(RadHue(FHue - 10)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure THRingPicker.WebSafeChanged; +begin + inherited; + CreateHSVCircle; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/HSColorPicker.dcr b/components/mbColorLib/HSColorPicker.dcr new file mode 100644 index 000000000..08cc2270d Binary files /dev/null and b/components/mbColorLib/HSColorPicker.dcr differ diff --git a/components/mbColorLib/HSColorPicker.pas b/components/mbColorLib/HSColorPicker.pas new file mode 100644 index 000000000..9f64d6f60 --- /dev/null +++ b/components/mbColorLib/HSColorPicker.pas @@ -0,0 +1,377 @@ +unit HSColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, Forms, + RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; + +type + THSColorPicker = class(TmbColorPickerControl) + private + FSelected: TColor; + FHSLBmp: TBitmap; + FOnChange: TNotifyEvent; + FHue, FSaturation, FLuminance: integer; + FLum: integer; + FManual: boolean; + dx, dy, mxx, myy: integer; + + procedure SetHValue(h: integer); + procedure SetSValue(s: integer); + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + 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 DrawMarker(x, y: integer); + procedure Paint; override; + procedure CreateHSLGradient; + procedure Resize; override; + procedure CreateWnd; override; + procedure CorrectCoords(var x, y: integer); + function PredictColor: TColor; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Lum: integer read FLum write FLum default 120; + property Manual: boolean read FManual; + published + property SelectedColor default clRed; + property HueValue: integer read FHue write SetHValue default 0; + property SaturationValue: integer read FSaturation write SetSValue default 240; + property MarkerStyle default msCross; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R HSColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [THSColorPicker]); +end; + +{THSColorPicker} + +constructor THSColorPicker.Create(AOwner: TComponent); +begin + inherited; + FHSLBmp := TBitmap.Create; + FHSLBmp.PixelFormat := pf32bit; + FHSLBmp.SetSize(240, 241); + Width := 239; + Height := 240; + HintFormat := 'H: %h S: %hslS'#13'Hex: %hex'; + FHue := 0; + FSaturation := 240; + FLuminance := 120; + FSelected := clRed; + FLum := 120; + FManual := false; + dx := 0; + dy := 0; + mxx := 0; + myy := 0; + MarkerStyle := msCross; +end; + +destructor THSColorPicker.Destroy; +begin + FHSLBmp.Free; + inherited Destroy; +end; + +procedure THSColorPicker.CreateWnd; +begin + inherited; + CreateHSLGradient; +end; + +procedure THSColorPicker.CreateHSLGradient; +var + Hue, Sat : integer; + row: pRGBQuadArray; +begin + if FHSLBmp = nil then + begin + FHSLBmp := TBitmap.Create; + FHSLBmp.PixelFormat := pf32bit; + FHSLBmp.Width := 240; + FHSLBmp.Height := 241; + end; + for Hue := 0 to 239 do + for Sat := 0 to 240 do + begin + row := FHSLBmp.ScanLine[240 - Sat]; + if not WebSafe then + row[Hue] := RGBToRGBQuad(HSLRangeToRGB(Hue, Sat, 120)) +// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := HSLRangeToRGB(Hue, Sat, 120) + else + row[Hue] := RGBToRGBQuad(GetWebSafe(HSLRangeToRGB(Hue, Sat, 120))); +// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120)); + end; +end; + +procedure THSColorPicker.CorrectCoords(var x, y: integer); +begin + if x < 0 then x := 0; + if y < 0 then y := 0; + if x > Width - 1 then x := Width - 1; + if y > Height - 1 then y := Height - 1; +end; + +procedure THSColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + CorrectCoords(x, y); + RGBtoHSLRange(FSelected, FHue, FSaturation, FLuminance); + if Assigned(FOnChange) then + FOnChange(Self); + dx := x; + dy := y; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clWhite; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +function THSColorPicker.GetSelectedColor: TColor; +begin + Result := FSelected; +end; + +procedure THSColorPicker.SetSelectedColor(c: TColor); +begin + if WebSafe then c := GetWebSafe(c); + RGBtoHSLRange(c, FHue, FSaturation, FLuminance); + FSelected := c; + FManual := false; + mxx := Round(FHue*(Width/239)); + myy := Round((240-FSaturation)*(Height/240)); + Invalidate; +end; + +procedure THSColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FHSLBmp); + CorrectCoords(mxx, myy); + DrawMarker(mxx, myy); +end; + +procedure THSColorPicker.Resize; +begin + SetSelectedColor(FSelected); + inherited; +end; + +procedure THSColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + R: TRect; +begin + inherited; + mxx := x; + myy := y; + if Button = mbLeft then + begin + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; + SetFocus; +end; + +procedure THSColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; +end; + +procedure THSColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if ssLeft in Shift then + begin + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; +end; + +function THSColorPicker.PredictColor: TColor; +var + FTHue, FTSat, FTLum: integer; +begin + RGBtoHSLRange(GetColorUnderCursor, FTHue, FTSat, FTLum); + Result := HSLRangeToRGB(FTHue, FTSat, FLum); +end; + +procedure THSColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure THSColorPicker.SetHValue(h: integer); +begin + if h > 239 then h := 239; + if h < 0 then h := 0; + FHue := h; + SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120)); +end; + +procedure THSColorPicker.SetSValue(s: integer); +begin + if s > 240 then s := 240; + if s < 0 then s := 0; + FSaturation := s; + SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120)); +end; + +function THSColorPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := Canvas.Pixels[x, y]; +end; + +procedure THSColorPicker.WebSafeChanged; +begin + inherited; + CreateHSLGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/HSLColorPicker.dcr b/components/mbColorLib/HSLColorPicker.dcr new file mode 100644 index 000000000..f193bf4d5 Binary files /dev/null and b/components/mbColorLib/HSLColorPicker.dcr differ diff --git a/components/mbColorLib/HSLColorPicker.pas b/components/mbColorLib/HSLColorPicker.pas new file mode 100644 index 000000000..d6aa64a76 --- /dev/null +++ b/components/mbColorLib/HSLColorPicker.pas @@ -0,0 +1,399 @@ +unit HSLColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, Menus, + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} + RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors; + +type + THSLColorPicker = class(TCustomControl) + private + FOnChange: TNotifyEvent; + FHSPicker: THSColorPicker; + FLPicker: TLColorPicker; + FSelectedColor: TColor; + FHValue, FSValue, FLValue: integer; + FRValue, FGValue, FBValue: integer; + FHSHint, FLHint: string; + FLMenu, FHSMenu: TPopupMenu; + FLumIncrement: integer; + FHSCursor, FLCursor: TCursor; + PBack: TBitmap; + + function GetManual: boolean; + procedure SetLumIncrement(i: integer); + procedure SelectColor(c: TColor); + procedure SetH(v: integer); + procedure SetS(v: integer); + procedure SetL(v: integer); + procedure SetR(v: integer); + procedure SetG(v: integer); + procedure SetB(v: integer); + procedure SetHSHint(h: string); + procedure SetLHint(h: string); + procedure SetLMenu(m: TPopupMenu); + 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 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); + procedure HSPickerChange(Sender: TObject); + procedure LPickerChange(Sender: TObject); + procedure DoChange; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorUnderCursor: TColor; + function GetHexColorUnderCursor: string; + function GetSelectedHexColor: string; + property ColorUnderCursor: TColor read GetColorUnderCursor; + property HValue: integer read FHValue write SetH default 0; + property SValue: integer read FSValue write SetS default 240; + property LValue: integer read FLValue write SetL default 120; + property RValue: integer read FRValue write SetR default 255; + property GValue: integer read FGValue write SetG default 0; + property BValue: integer read FBValue write SetB default 0; + property Manual: boolean read GetManual; + published + property LuminanceIncrement: integer read FLumIncrement write SetLumIncrement default 1; + property SelectedColor: TColor read FSelectedColor write SetSelectedColor default clRed; + property HSPickerPopupMenu: TPopupMenu read FHSMenu write SetHSMenu; + property LPickerPopupMenu: TPopupMenu read FLMenu write SetLMenu; + property HSPickerHintFormat: string read FHSHint write SetHSHint; + property LPickerHintFormat: string read FLHint write SetLHint; + property HSPickerCursor: TCursor read FHSCursor write SetHSCursor default crDefault; + property LPickerCursor: TCursor read FLCursor write SetLCursor default crDefault; + property TabStop default true; + property ShowHint; + property ParentShowHint; + property Anchors; + property Align; + property Visible; + property Enabled; + property TabOrder; + property Color; + property ParentColor default true; + {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} + property ParentBackground default true; + {$ENDIF}{$ENDIF} + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnMouseMove; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R HSLColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [THSLColorPicker]); +end; + +{THSLColorPicker} + +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 + begin + 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 + begin + 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'; +end; + +destructor THSLColorPicker.Destroy; +begin + PBack.Free; + FHSPicker.Free; + FLPicker.Free; + inherited Destroy; +end; + +procedure THSLColorPicker.HSPickerChange(Sender: TObject); +begin + FLPicker.Hue := FHSPicker.HueValue; + FLPicker.Saturation := FHSPicker.SaturationValue; + DoChange; +end; + +procedure THSLColorPicker.LPickerChange(Sender: TObject); +begin + FHSPicker.Lum := FLPicker.Luminance; + FSelectedColor := FLPicker.SelectedColor; + DoChange; +end; + +procedure THSLColorPicker.DoChange; +begin + FHValue := FLPicker.Hue; + FSValue := FLPicker.Saturation; + FLValue := FLPicker.Luminance; + FRValue := GetRValue(FLPicker.SelectedColor); + FGValue := GetGValue(FLPicker.SelectedColor); + FBValue := GetBValue(FLPicker.SelectedColor); + if Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure THSLColorPicker.SelectColor(c: TColor); +begin + FSelectedColor := c; + FHSPicker.SelectedColor := c; + FLPicker.SelectedColor := c; +end; + +procedure THSLColorPicker.SetH(v: integer); +begin + FHValue := v; + FHSPicker.HueValue := v; + FLPicker.Hue := v; +end; + +procedure THSLColorPicker.SetS(v: integer); +begin + FSValue := v; + FHSPicker.SaturationValue := v; + FLPicker.Saturation := v; +end; + +procedure THSLColorPicker.SetL(v: integer); +begin + FLValue := v; + FLPicker.Luminance := v; +end; + +procedure THSLColorPicker.SetR(v: integer); +begin + FRValue := v; + SetSelectedColor(RGB(FRValue, FGValue, FBValue)); +end; + +procedure THSLColorPicker.SetG(v: integer); +begin + FGValue := v; + SetSelectedColor(RGB(FRValue, FGValue, FBValue)); +end; + +procedure THSLColorPicker.SetB(v: integer); +begin + FBValue := v; + SetSelectedColor(RGB(FRValue, FGValue, FBValue)); +end; + +function THSLColorPicker.GetSelectedHexColor: string; +begin + Result := ColorToHex(FSelectedColor); +end; + +procedure THSLColorPicker.SetHSHint(h: string); +begin + FHSHint := h; + FHSPicker.HintFormat := h; +end; + +procedure THSLColorPicker.SetLHint(h: string); +begin + FLHint := h; + FLPicker.HintFormat := h; +end; + +procedure THSLColorPicker.SetLMenu(m: TPopupMenu); +begin + FLMenu := m; + FLPicker.PopupMenu := m; +end; + +procedure THSLColorPicker.SetHSMenu(m: TPopupMenu); +begin + FHSMenu := m; + FHSPicker.PopupMenu := m; +end; + +procedure THSLColorPicker.SetLumIncrement(i: integer); +begin + FLumIncrement := i; + FLPicker.Increment := i; +end; + +procedure THSLColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +begin + if Assigned(OnMouseMove) then + OnMouseMove(Self, Shift, x, y); + inherited; +end; + +function THSLColorPicker.GetColorUnderCursor: TColor; +begin + Result := FHSPicker.GetColorUnderCursor; +end; + +function THSLColorPicker.GetHexColorUnderCursor: string; +begin + Result := FHSPicker.GetHexColorUnderCursor; +end; + +procedure THSLColorPicker.SetHSCursor(c: TCursor); +begin + FHSCursor := c; + FHSPicker.Cursor := c; +end; + +procedure THSLColorPicker.SetLCursor(c: TCursor); +begin + FLCursor := c; + FLPicker.Cursor := c; +end; + +procedure THSLColorPicker.WMSetFocus( + var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF} ); +begin + FHSPicker.SetFocus; + Message.Result := 1; +end; + +function THSLColorPicker.GetManual:boolean; +begin + Result := FHSPicker.Manual or FLPicker.Manual; +end; + +procedure THSLColorPicker.PaintParentBack; +{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} +var + MemDC: HDC; + OldBMP: HBITMAP; + {$ENDIF} {$ENDIF} +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 THSLColorPicker.Resize; +begin + inherited; + PaintParentBack; +end; + +procedure THSLColorPicker.CreateWnd; +begin + inherited; + PaintParentBack; +end; + +procedure THSLColorPicker.Paint; +begin + PaintParentBack; + 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 + begin + SelectColor(Value); + //FLPicker.Hue := FHSPicker.HueValue; + //FLPicker.Saturation := FHSPicker.SaturationValue; + end; +end; + +end. diff --git a/components/mbColorLib/HSLRingPicker.dcr b/components/mbColorLib/HSLRingPicker.dcr new file mode 100644 index 000000000..1386d4c03 Binary files /dev/null and b/components/mbColorLib/HSLRingPicker.dcr differ diff --git a/components/mbColorLib/HSLRingPicker.pas b/components/mbColorLib/HSLRingPicker.pas new file mode 100644 index 000000000..fc1a4f958 --- /dev/null +++ b/components/mbColorLib/HSLRingPicker.pas @@ -0,0 +1,405 @@ +unit HSLRingPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, Menus, Math, + {$IFDEF DELPHI_7_UP}Themes,{$ENDIF} + RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors; + +type + THSLRingPicker = class(TCustomControl) + private + FOnChange: TNotifyEvent; + FRingPicker: THRingPicker; + FSLPicker: TSLColorPicker; + FSelectedColor: TColor; + FHValue, FSValue, FLValue: integer; + FRValue, FGValue, FBValue: integer; + FRingHint, FSLHint: string; + FSLMenu, FRingMenu: TPopupMenu; + FSLCursor, FRingCursor: TCursor; + PBack: TBitmap; + + function GetManual: boolean; + procedure SelectColor(c: TColor); + procedure SetH(v: integer); + procedure SetS(v: integer); + procedure SetL(v: integer); + procedure SetR(v: integer); + procedure SetG(v: integer); + procedure SetB(v: integer); + procedure SetRingHint(h: string); + procedure SetSLHint(h: string); + procedure SetSLMenu(m: TPopupMenu); + procedure SetRingMenu(m: TPopupMenu); + procedure SetRingCursor(c: TCursor); + procedure SetSLCursor(c: TCursor); + procedure PaintParentBack; + protected + procedure CreateWnd; override; + procedure Paint; override; + procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); + procedure RingPickerChange(Sender: TObject); + procedure SLPickerChange(Sender: TObject); + 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 + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorUnderCursor: TColor; + function GetHexColorUnderCursor: string; + function GetSelectedHexColor: string; + property ColorUnderCursor: TColor read GetColorUnderCursor; + property HValue: integer read FHValue write SetH default 0; + property SValue: integer read FSValue write SetS default 240; + property LValue: integer read FLValue write SetL default 120; + property RValue: integer read FRValue write SetR default 255; + property GValue: integer read FGValue write SetG default 0; + property BValue: integer read FBValue write SetB default 0; + property Manual: boolean read GetManual; + published + property SelectedColor: TColor read FSelectedColor write SelectColor default clRed; + property RingPickerPopupMenu: TPopupMenu read FRingMenu write SetRingMenu; + property SLPickerPopupMenu: TPopupMenu read FSLMenu write SetSLMenu; + property RingPickerHintFormat: string read FRingHint write SetRingHint; + property SLPickerHintFormat: string read FSLHint write SetSLHint; + property RingPickerCursor: TCursor read FRingCursor write SetRingCursor default crDefault; + property SLPickerCursor: TCursor read FSLCursor write SetSLCursor default crDefault; + property TabStop default true; + property ShowHint; + property ParentShowHint; + property Anchors; + property Align; + property Visible; + property Enabled; + property TabOrder; + property Color; + property ParentColor default true; + {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} + property ParentBackground default true; + {$ENDIF} {$ENDIF} + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnMouseMove; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R HSLRingPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [THSLRingPicker]); +end; + +{THSLRingPicker} + +constructor THSLRingPicker.Create(AOwner: TComponent); +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} + ParentBackground := true; + {$ENDIF} {$ENDIF} + Width := 245; + Height := 245; + TabStop := true; + FSelectedColor := clRed; + FRingPicker := THRingPicker.Create(Self); + InsertControl(FRingPicker); + FRingCursor := crDefault; + FSLCursor := crDefault; + with FRingPicker do + begin + Height := 246; + Width := 246; + Top := 0; + Left := 0; + Align := alClient; + Visible := true; + Saturation := 255; + Value := 255; + Hue := 0; + OnChange := RingPickerChange; + OnMouseMove := DoMouseMove; + end; + FSLPicker := TSLColorPicker.Create(Self); + InsertControl(FSLPicker); + with FSLPicker do + begin + Height := 120; + Width := 120; + Left := 63; + Top := 63; + Visible := true; + OnChange := SLPickerChange; + OnMouseMove := DoMouseMove; + end; + FHValue := 0; + FSValue := 255; + FLValue := 255; + FRValue := 255; + FGValue := 0; + FBValue := 0; + FRingHint := 'Hue: %h'; + FSLHint := 'S: %hslS L: %l'#13'Hex: %hex'; +end; + +destructor THSLRingPicker.Destroy; +begin + PBack.Free; + FRingPicker.Free; + FSLPicker.Free; + inherited Destroy; +end; + +procedure THSLRingPicker.Resize; +begin + inherited; + if (FRingPicker = nil) or (FSLPicker = nil) then + exit; + 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; +end; + +procedure THSLRingPicker.RingPickerChange(Sender: TObject); +begin + if (FRingPicker = nil) or (FSLPicker = nil) then + exit; + FSLPicker.Hue := FRingPicker.Hue; + DoChange; +end; + +procedure THSLRingPicker.SLPickerChange(Sender: TObject); +begin + if FSLPicker = nil then + exit; + FSelectedColor := FSLPicker.SelectedColor; + DoChange; +end; + +procedure THSLRingPicker.DoChange; +begin + if (FRingPicker = nil) or (FSLPicker = nil) then + exit; + + FHValue := FRingPicker.Hue; + FSValue := FSLPicker.Saturation; + FLValue := FSLPicker.Luminance; + FRValue := GetRValue(FSLPicker.SelectedColor); + FGValue := GetGValue(FSLPicker.SelectedColor); + FBValue := GetBValue(FSLPicker.SelectedColor); + if Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure THSLRingPicker.SelectColor(c: TColor); +begin + if (FRingPicker = nil) or (FSLPicker = nil) then + exit; + + FRingPicker.Hue := GetHValue(c); + FRingPicker.Saturation := 255; + FRingPicker.Value := 255; + FSLPicker.SelectedColor := c; + FSelectedColor := c; +end; + +procedure THSLRingPicker.SetH(v: integer); +begin + if (FRingPicker = nil) or (FSLPicker = nil) then + exit; + + FHValue := v; + FRingPicker.Hue := v; + FSLPicker.Hue := v; +end; + +procedure THSLRingPicker.SetS(v: integer); +begin + if (FSLPicker = nil) then + exit; + FSValue := v; + FSLPicker.Saturation := v; +end; + +procedure THSLRingPicker.SetL(v: integer); +begin + if (FSLPicker = nil) then + exit; + FLValue := v; + FSLPicker.Luminance := v; +end; + +procedure THSLRingPicker.SetR(v: integer); +begin + FRValue := v; + SelectColor(RGB(FRValue, FGValue, FBValue)); +end; + +procedure THSLRingPicker.SetG(v: integer); +begin + FGValue := v; + SelectColor(RGB(FRValue, FGValue, FBValue)); +end; + +procedure THSLRingPicker.SetB(v: integer); +begin + FBValue := v; + SelectColor(RGB(FRValue, FGValue, FBValue)); +end; + +function THSLRingPicker.GetSelectedHexColor: string; +begin + Result := ColorToHex(FSelectedColor); +end; + +procedure THSLRingPicker.SetRingHint(h: string); +begin + FRingHint := h; + FRingPicker.HintFormat := h; +end; + +procedure THSLRingPicker.SetSLHint(h: string); +begin + FSLHint := h; + FSLPicker.HintFormat := h; +end; + +procedure THSLRingPicker.SetRingMenu(m: TPopupMenu); +begin + FRingMenu := m; + FRingPicker.PopupMenu := m; +end; + +procedure THSLRingPicker.SetSLMenu(m: TPopupMenu); +begin + FSLMenu := m; + FSLPicker.PopupMenu := m; +end; + +procedure THSLRingPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +begin + if Assigned(OnMouseMove) then + OnMouseMove(Self, Shift, x, y); + inherited; +end; + +function THSLRingPicker.GetColorUnderCursor: TColor; +begin + Result := FSLPicker.GetColorUnderCursor; +end; + +function THSLRingPicker.GetHexColorUnderCursor: string; +begin + Result := FSLPicker.GetHexColorUnderCursor; +end; + +procedure THSLRingPicker.SetRingCursor(c: TCursor); +begin + FRingCursor := c; + FRingPicker.Cursor := c; +end; + +procedure THSLRingPicker.SetSLCursor(c: TCursor); +begin + FSLCursor := c; + FSLPicker.Cursor := c; +end; + +procedure THSLRingPicker.WMSetFocus( + var Message: {$IFDEF DELPHI}TWMSetFocus{$ELSE}TLMSetFocus{$ENDIF} ); +begin + FRingPicker.SetFocus; + Message.Result := 1; +end; + +function THSLRingPicker.GetManual:boolean; +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; + 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; +end; + +end. diff --git a/components/mbColorLib/HSVColorPicker.dcr b/components/mbColorLib/HSVColorPicker.dcr new file mode 100644 index 000000000..6cd61feb4 Binary files /dev/null and b/components/mbColorLib/HSVColorPicker.dcr differ diff --git a/components/mbColorLib/HSVColorPicker.pas b/components/mbColorLib/HSVColorPicker.pas new file mode 100644 index 000000000..8828a8295 --- /dev/null +++ b/components/mbColorLib/HSVColorPicker.pas @@ -0,0 +1,622 @@ +unit HSVColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, Scanlines, + Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, SelPropUtils, + mbColorPickerControl; + +type + THSVColorPicker = class(TmbColorPickerControl) + private + FHue, FSat, FValue: integer; + FSatCircColor, FHueLineColor: TColor; + FSelectedColor: TColor; + FOnChange: TNotifyEvent; + FManual: boolean; + FShowSatCirc: boolean; + FShowHueLine: boolean; + FShowSelCirc: boolean; + Fchange: boolean; + FHSVBmp: TBitmap; + FDoChange: boolean; + + procedure CreateHSVCircle; + function RadHue(New: integer): integer; + procedure SetValue(V: integer); + procedure SetHue(h: integer); + procedure SetSat(s: integer); + procedure SetSatCircColor(c: TColor); + procedure SetHueLineColor(c: TColor); + procedure DrawSatCirc; + procedure DrawHueLine; + procedure DrawMarker(x, y: integer); + procedure SelectionChanged(x, y: integer); + procedure SetShowSatCirc(s: boolean); + procedure SetShowSelCirc(s: boolean); + procedure SetShowHueLine(s: boolean); + procedure UpdateCoords; + protected + function GetSelectedColor: TColor; override; + procedure SetSelectedColor(c: TColor); override; + procedure WebSafeChanged; override; + procedure Paint; override; + procedure Resize; override; + procedure CreateWnd; override; + 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 CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property Hue: integer read FHue write SetHue default 0; + property Saturation: integer read FSat write SetSat default 0; + property Value: integer read FValue write SetValue default 255; + property SaturationCircleColor: TColor read FSatCircColor write SetSatCircColor default clSilver; + property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray; + property SelectedColor default clNone; + property ShowSaturationCircle: boolean read FShowSatCirc write SetShowSatCirc default true; + property ShowHueLine: boolean read FShowHueLine write SetShowHueLine default true; + property ShowSelectionCircle: boolean read FShowSelCirc write SetShowSelCirc default true; + property MarkerStyle default msCrossCirc; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R HSVColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [THSVColorPicker]); +end; + +function PointInCirc(p: TPoint; size : integer): boolean; +var + r: integer; +begin + r := size div 2; + Result := (SQR(p.x - r) + SQR(p.y - r) <= SQR(r)); +end; + +constructor THSVColorPicker.Create(AOwner: TComponent); +begin + inherited; + FHSVBmp := TBitmap.Create; + FHSVBmp.PixelFormat := pf32bit; + Width := 204; + Height := 204; + FValue := 255; + FHue := 0; + FSat := 0; + FSatCircColor := clSilver; + FHueLineColor := clGray; + FSelectedColor := clNone; + FManual := false; + FShowSatCirc := true; + FShowHueLine := true; + FShowSelCirc := true; + Fchange := true; + FDoChange := false; + MarkerStyle := msCrossCirc; +end; + +destructor THSVColorPicker.Destroy; +begin + FHSVBmp.Free; + inherited; +end; + +procedure THSVColorPicker.Paint; +var + rgn: HRGN; + R: TRect; +begin + PaintParentBack(Canvas); + R := ClientRect; + R.Right := R.Left + Min(Width, Height); + R.Bottom := R.Top + Min(Width, Height); + rgn := CreateEllipticRgnIndirect(R); + SelectClipRgn(Canvas.Handle, rgn); + Canvas.Draw(0, 0, FHSVBmp); + DeleteObject(rgn); + DrawSatCirc; + DrawHueLine; + DrawMarker(mdx, mdy); + if FDoChange then + begin + if Assigned(FOnChange) then FOnChange(Self); + FDoChange := false; + end; +end; + +procedure THSVColorPicker.CreateHSVCircle; +var + dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; + row: pRGBQuadArray; + tc: TColor; +begin + if FHSVBmp = nil then + begin + 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); + + 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 + 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; + end; +end; + +procedure THSVColorPicker.Resize; +begin + inherited; + CreateHSVCircle; + UpdateCoords; +end; + +procedure THSVColorPicker.CreateWnd; +begin + inherited; + CreateHSVCircle; + UpdateCoords; +end; + +procedure THSVColorPicker.UpdateCoords; +var + r, angle: real; + radius: integer; +begin + radius := Min(Width, Height) div 2; + r := -MulDiv(radius, FSat, 255); + angle := -FHue*PI/180 - PI; + mdx := ROUND(COS(angle)*ROUND(r)) + radius; + mdy := ROUND(SIN(angle)*ROUND(r)) + radius; +end; + +procedure THSVColorPicker.SetHue(h: integer); +begin + if h > 360 then h := 360; + if h < 0 then h := 0; + if FHue <> h then + begin + FHue := h; + FManual := false; + UpdateCoords; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure THSVColorPicker.SetSat(s: integer); +begin + if s > 255 then s := 255; + if s < 0 then s := 0; + if FSat <> s then + begin + FSat := s; + FManual := false; + UpdateCoords; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure THSVColorPicker.SetValue(V: integer); +begin + if V > 255 then V := 255; + if V < 0 then V := 0; + if FValue <> V then + begin + FValue := V; + FManual := false; + CreateHSVCircle; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure THSVColorPicker.SetSatCircColor(c: TColor); +begin + if FSatCircColor <> c then + begin + FSatCircColor := c; + Invalidate; + end; +end; + +procedure THSVColorPicker.SetHueLineColor(c: TColor); +begin + if FHueLineColor <> c then + begin + FHueLineColor := c; + Invalidate; + end; +end; + +procedure THSVColorPicker.SetShowSatCirc(s: boolean); +begin + if FShowSatCirc <> s then + begin + FShowSatCirc := s; + Invalidate; + end; +end; + +procedure THSVColorPicker.SetShowSelCirc(s: boolean); +begin + if FShowSelCirc <> s then + begin + FShowSelCirc := s; + Invalidate; + end; +end; + +procedure THSVColorPicker.SetShowHueLine(s: boolean); +begin + if FShowHueLine <> s then + begin + FShowHueLine := s; + Invalidate; + end; +end; + +procedure THSVColorPicker.DrawSatCirc; +var + delta: integer; + Radius: integer; +begin + if not FShowSatCirc then Exit; + if FSat in [1..254] then + begin + Radius:= Min(Width, Height) div 2; + Canvas.Pen.Color := FSatCircColor; + Canvas.Brush.Style := bsClear; + delta := MulDiv(Radius, FSat, 255); + Canvas.Ellipse(Radius - delta, Radius - delta, Radius + delta, Radius + delta); + end; +end; + +procedure THSVColorPicker.DrawHueLine; +var + angle: double; + radius: integer; +begin + if not FShowHueLine then Exit; + Radius := Min(Width, Height) div 2; + if (FHue >= 0) and (FHue <= 360) then + begin + Angle := -FHue*PI/180; + Canvas.Pen.Color := FHueLineColor; + Canvas.MoveTo(Radius,Radius); + Canvas.LineTo(Radius + Round(Radius*COS(angle)), Radius + Round(Radius*SIN(angle))); + end; +end; + +procedure THSVColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + if not FShowSelCirc then Exit; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clGray; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +procedure THSVColorPicker.SelectionChanged(x, y: integer); +var + Angle, Distance, xDelta, yDelta, Radius: integer; +begin + if not PointInCirc(Point(x, y), Min(Width, Height)) then + begin + FChange := false; + SetSelectedColor(clNone); + FChange := true; + Exit; + end + else + FSelectedColor := clWhite; + Radius := Min(Width, Height) div 2; + xDelta := x - Radius; + yDelta := y - Radius; + Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); + if Angle < 0 then Inc(Angle, 360) + else if Angle > 360 then + Dec(Angle, 360); + Fchange := false; + SetHue(Angle); + Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); + if Distance >= Radius then SetSat(255) + else SetSat(MulDiv(Distance, 255, Radius)); + Fchange := true; +end; + +procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + if csDesigning in ComponentState then Exit; + if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then + begin + mdx := x; + mdy := y; + FDoChange := true; + SelectionChanged(X, Y); + FManual := true; + end; +end; + +procedure THSVColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + R: TRect; +begin + inherited; + if csDesigning in ComponentState then Exit; + if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then + begin + mdx := x; + mdy := y; + R := ClientRect; + InflateRect(R, 1, 1); + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FDoChange := true; + SelectionChanged(X, Y); + FManual := true; + end; + SetFocus; +end; + +procedure THSVColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if csDesigning in ComponentState then Exit; + if (ssLeft in Shift) and PointInCirc(Point(x, y), Min(Width, Height)) then + begin + mdx := x; + mdy := y; + FDoChange := true; + SelectionChanged(X, Y); + FManual := true; + end; +end; + +function THSVColorPicker.GetSelectedColor: TColor; +begin + if FSelectedColor <> clNone then + begin + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FValue) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FValue)); + end + else + Result := clNone; +end; + +function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor; +var + Angle, Distance, xDelta, yDelta, Radius: integer; + h, s: integer; +begin + Radius := Min(Width, Height) div 2; + xDelta := x - Radius; + yDelta := y - Radius; + Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); + if Angle < 0 then Inc(Angle, 360) + else if Angle > 360 then + Dec(Angle, 360); + h := Angle; + Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); + if Distance >= Radius then s := 255 + else s := MulDiv(Distance, 255, Radius); + if PointInCirc(Point(mx, my), Min(Width, Height)) then + begin + if not WebSafe then + Result := HSVtoColor(h, s, FValue) + else + Result := GetWebSafe(HSVtoColor(h, s, FValue)); + end + else + Result := clNone; +end; + +procedure THSVColorPicker.SetSelectedColor(c: TColor); +var + changeSave: boolean; +begin + if WebSafe then c := GetWebSafe(c); + changeSave := FChange; + FManual := false; + Fchange := false; + SetValue(GetVValue(c)); + SetHue(GetHValue(c)); + SetSat(GetSValue(c)); + FSelectedColor := c; + Fchange := changeSave; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + FChange := true; +end; + +function THSVColorPicker.RadHue(New: integer): integer; +begin + if New < 0 then New := New + 360; + if New > 360 then New := New - 360; + Result := New; +end; + +procedure THSVColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + FChange := false; + SetHue(RadHue(FHue + 1)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_RIGHT: + begin + FChange := false; + SetHue(RadHue(FHue - 1)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_UP: + begin + FChange := false; + if FSat + 1 <= 255 then + SetSat(FSat + 1); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_DOWN: + begin + FChange := false; + if FSat - 1 >= 0 then + SetSat(FSat - 1); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + FChange := false; + SetHue(RadHue(FHue + 10)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_RIGHT: + begin + FChange := false; + SetHue(RadHue(FHue - 10)); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_UP: + begin + FChange := false; + if FSat + 10 <= 255 then + SetSat(FSat + 10); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_DOWN: + begin + FChange := false; + if FSat - 10 >= 0 then + SetSat(FSat - 10); + FChange := true; + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure THSVColorPicker.WebSafeChanged; +begin + inherited; + CreateHSVCircle; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/HTMLColors.pas b/components/mbColorLib/HTMLColors.pas new file mode 100644 index 000000000..a5a8bf5af --- /dev/null +++ b/components/mbColorLib/HTMLColors.pas @@ -0,0 +1,346 @@ +unit HTMLColors; + +interface + +{$I mxs.inc} + +uses + SysUtils, + {$IFDEF FPC} + LCLIntf, + {$ELSE} + Windows, + {$ENDIF} + Graphics{$IFDEF DELPHI_6_UP}, Variants{$ENDIF}; + +const + SPECIAL_COUNT = 140; + WEBSAFE_COUNT = 216; + SYSTEM_COUNT = 28; + BASIC_COUNT = 16; + SPECIAL_HEX: array [0..139] of string = ('000000', 'FAEBD7', '00FFFF', '7FFFD4', 'F0FFFF', 'F5F5DC', 'FFE4C4', + 'F0F8FF', 'FFEBCD', '0000FF', '8A2BE2', 'A52A2A', 'DEB887', '5F9EA0', + '7FFF00', 'D2691E', 'FF7F50', '6495ED', 'FFF8DC', 'DC143C', '00FFFF', + '00008B', '008B8B', 'B8860B', 'A9A9A9', '006400', 'BDB76B', '8B008B', + '556B2F', 'FF8C00', '9932CC', '8B0000', 'E9967A', '8FBC8B', '483D8B', + '2F4F4F', '00CED1', '9400D3', 'FF1493', '00BFFF', '696969', '1E90FF', + 'B22222', 'FFFAF0', '228B22', 'FF00FF', 'DCDCDC', 'F8F8FF', 'FFD700', + 'DAA520', '808080', '008000', 'ADFF2F', 'F0FFF0', 'FF69B4', 'CD5C5C', + '4B0082', 'FFFFF0', 'F0E68C', 'E6E6FA', 'FFF0F5', '7CFC00', 'FFFACD', + 'ADD8E6', 'F08080', 'E0FFFF', 'FAFAD2', '90EE90', 'D3D3D3', 'FFB6C1', + 'FFA07A', '20B2AA', '87CEFA', '778899', 'B0C4DE', 'FFFFE0', '00FF00', + '32CD32', 'FAF0E6', 'FF00FF', '800000', '66CDAA', '0000CD', 'BA55D3', + '9370DB', '3CB371', '7B68EE', '00FA9A', '48D1CC', 'C71585', '191970', + 'F5FFFA', 'FFE4E1', 'FFE4B5', 'FFDEAD', '000080', 'FDF5E6', '808000', + '6B8E23', 'FFA500', 'FF4500', 'DA70D6', 'EEE8AA', '98FB98', 'AFEEEE', + 'DB7093', 'FFEFD5', 'FFDAB9', 'CD853F', 'FFC0CB', 'DDA0DD', 'B0E0E6', + '800080', 'FF0000', 'BC8F8F', '4169E1', '8B4513', 'FA8072', 'F4A460', + '2E8B57', 'FFF5EE', 'A0522D', 'C0C0C0', '87CEEB', '6A5ACD', '708090', + 'FFFAFA', '00FF7F', '4682B4', 'D2B48C', '008080', 'D8BFD8', 'FF6347', + '40E0D0', 'EE82EE', 'F5DEB3', 'FFFFFF', 'F5F5F5', 'FFFF00', '9ACD32'); + SPECIAL_NAMES: array [0..139] of string = ('black', 'antiquewhite', 'aqua', 'aquamarine', 'azure', 'beige', + 'bisque', 'aliceblue', 'blanchedalmond', 'blue', 'blueviolet', 'brown', + 'burlywood', 'cadetblue', 'chartreuse', 'chocolate', 'coral', + 'cornflower', 'cornsilk', 'crimson', 'cyan', 'darkblue', 'darkcyan', + 'darkgoldenrod', 'darkgray', 'darkgreen', 'darkkhaki', 'darkmagenta', + 'darkolivegreen', 'darkorange', 'darkorchid', 'darkred', 'darksalmon', + 'darkseagreen', 'darkslateblue', 'darkslategray', 'darkturquoise', + 'darkviolet', 'deeppink', 'deepskyblue', 'dimgray', 'dodgerblue', + 'firebrick', 'floralwhite', 'forestgreen', 'fuchsia', 'gainsboro', + 'ghostwhite', 'gold', 'goldenrod', 'gray', 'green', 'greenyellow', + 'honeydew', 'hotpink', 'indianred', 'indigo', 'ivory', 'khaki', 'lavender', + 'lavenderblush', 'lawngreen', 'lemonchiffon', 'lightblue', 'lightcoral', + 'lightcyan', 'lightgoldenrodyellow', 'lightgreen', 'lightgray', 'lightpink', + 'lightsalmon', 'lightseagreen', 'lightskyblue', 'lightslategray', + 'lightsteelblue', 'lightyellow', 'lime', 'limegreen', 'linen', 'magenta', + 'maroon', 'mediumaquamarine', 'mediumblue', 'mediumorchid', 'mediumpurple', + 'mediumseagreen', 'mediumslateblue', 'mediumspringgreen', 'mediumturquoise', + 'mediumvioletred', 'midnightblue', 'mintcream', 'mistyrose', 'moccasin', + 'navajowhite', 'navy', 'oldlace', 'olive', 'olivedrab', 'orange', 'orangered', + 'orchid', 'palegoldenrod', 'palegreen', 'paleturquoise', 'palevioletred', + 'papayawhip', 'peachpuff', 'peru', 'pink', 'plum', 'powderblue', 'purple', + 'red', 'rosybrown', 'royalblue', 'saddlebrown', 'salmon', 'sandybrown', + 'seagreen', 'seashell', 'sienna', 'silver', 'skyblue', 'slateblue', + 'slategray', 'snow', 'springgreen', 'steelblue', 'tan', 'teal', 'thistle', + 'tomato', 'turquoise', 'violet', 'wheat', 'white', 'whitesmoke', 'yellow', + 'yellowgreen'); + WEBSAFE_HEX: array [0..215] of string = ('000000' ,'000033' ,'000066' ,'000099' ,'0000cc' ,'0000ff', + '003300' ,'003333' ,'003366' ,'003399' ,'0033cc' ,'0033ff', + '006600' ,'006633' ,'006666' ,'006699' ,'0066cc' ,'0066ff', + '009900' ,'009933' ,'009966' ,'009999' ,'0099cc' ,'0099ff', + '00cc00' ,'00cc33' ,'00cc66' ,'00cc99' ,'00cccc' ,'00ccff', + '00ff00' ,'00ff33' ,'00ff66' ,'00ff99' ,'00ffcc' ,'00ffff', + '330000' ,'330033' ,'330066' ,'330099' ,'3300cc' ,'3300ff', + '333300' ,'333333' ,'333366' ,'333399' ,'3333cc' ,'3333ff', + '336600' ,'336633' ,'336666' ,'336699' ,'3366cc' ,'3366ff', + '339900' ,'339933' ,'339966' ,'339999' ,'3399cc' ,'3399ff', + '33cc00' ,'33cc33' ,'33cc66' ,'33cc99' ,'33cccc' ,'33ccff', + '33ff00' ,'33ff33' ,'33ff66' ,'33ff99' ,'33ffcc' ,'33ffff', + '660000' ,'660033' ,'660066' ,'660099' ,'6600cc' ,'6600ff', + '663300' ,'663333' ,'663366' ,'663399' ,'6633cc' ,'6633ff', + '666600' ,'666633' ,'666666' ,'666699' ,'6666cc' ,'6666ff', + '669900' ,'669933' ,'669966' ,'669999' ,'6699cc' ,'6699ff', + '66cc00' ,'66cc33' ,'66cc66' ,'66cc99' ,'66cccc' ,'66ccff', + '66ff00' ,'66ff33' ,'66ff66' ,'66ff99' ,'66ffcc' ,'66ffff', + '990000' ,'990033' ,'990066' ,'990099' ,'9900cc' ,'9900ff', + '993300' ,'993333' ,'993366' ,'993399' ,'9933cc' ,'9933ff', + '996600' ,'996633' ,'996666' ,'996699' ,'9966cc' ,'9966ff', + '999900' ,'999933' ,'999966' ,'999999' ,'9999cc' ,'9999ff', + '99cc00' ,'99cc33' ,'99cc66' ,'99cc99' ,'99cccc' ,'99ccff', + '99ff00' ,'99ff33' ,'99ff66' ,'99ff99' ,'99ffcc' ,'99ffff', + 'cc0000' ,'cc0033' ,'cc0066' ,'cc0099' ,'cc00cc' ,'cc00ff', + 'cc3300' ,'cc3333' ,'cc3366' ,'cc3399' ,'cc33cc' ,'cc33ff', + 'cc6600' ,'cc6633' ,'cc6666' ,'cc6699' ,'cc66cc' ,'cc66ff', + 'cc9900' ,'cc9933' ,'cc9966' ,'cc9999' ,'cc99cc' ,'cc99ff', + 'cccc00' ,'cccc33' ,'cccc66' ,'cccc99' ,'cccccc' ,'ccccff', + 'ccff00' ,'ccff33' ,'CCFF66' ,'ccff99' ,'ccffcc' ,'ccffff', + 'ff0000' ,'ff0033' ,'ff0066' ,'ff0099' ,'ff00cc' ,'ff00ff', + 'ff3300' ,'ff3333' ,'ff3366' ,'ff3399' ,'ff33cc' ,'ff33ff', + 'ff6600' ,'ff6633' ,'ff6666' ,'ff6699' ,'ff66cc' ,'ff66ff', + 'ff9900' ,'ff9933' ,'ff9966' ,'ff9999' ,'ff99cc' ,'ff99ff', + 'ffcc00' ,'ffcc33' ,'ffcc66' ,'ffcc99' ,'ffcccc' ,'ffccff', + 'ffff00' ,'ffff33' ,'ffff66' ,'ffff99' ,'ffffcc' ,'ffffff'); + SYSTEM_VALUES: array [0..27] of TColor = (clActiveBorder, clActiveCaption, clAppWorkspace, clBackground, + clBtnFace, clBtnHighlight, clBtnShadow, clBtnText, clCaptionText, + clGrayText, clHighlight, clHighlightText, clInactiveBorder, + clInactiveCaption, clInactiveCaptionText, clInfoBk, clInfoText, + clMenu, clMenuText, clScrollbar, cl3dDkShadow, cl3dLight, + clBtnHighlight, clActiveBorder, clBtnShadow, clWindow, + clWindowFrame, clWindowText); + SYSTEM_NAMES: array [0..27] of string = ('activeborder', 'activecaption', 'appworkspace', 'background', + 'buttonface', 'buttonhighlight', 'buttonshadow', 'buttontext', + 'captiontext', 'graytext', 'highlight', 'highlighttext', + 'inactiveborder', 'inactivecaption', 'inactivecaptiontext', + 'infobackground', 'infotext', 'menu', 'menutext', 'scrollbar', + 'threeddarkshadow', 'threedface', 'threedhighlight', + 'threedlightshadow', 'threedshadow', 'window', 'windowframe', + 'windowtext'); + BASIC_VALUES: array [0..15] of TColor = (clBlack, clAqua, clBlue, clFuchsia, clGray, clGreen, clLime, + clMaroon, clNavy, clOlive, clPurple, clRed, clSilver, clTeal, + clWhite, clYellow); + BASIC_NAMES: array [0..15] of string = ('black', 'aqua', 'blue', 'fuchsia', 'gray', 'green', 'lime', + 'maroon', 'navy', 'olive', 'purple', 'red', 'silver', 'teal', + 'white', 'yellow'); + +procedure MakeIntoHex(var s: string); +function IsMember(a: array of string; n: integer; s: string): boolean; +function IsSpecialColor(s: string): boolean; +function FormatHexColor(S: string): string; +function ColorToHex(Color: TColor): string; +function HexToTColor(s: OleVariant): TColor; +function GetHexFromName(s: string): string; +function GetValueFromName(s: string): TColor; +function IsWebSafe(s: string): boolean; overload; +function IsWebSafe(c: TColor): boolean; overload; +function GetWebSafe(C: TColor): TColor; + +implementation + +var + WS: array [0..255] of byte; + +//------------------------------------------------------------------------------ + +//checks membership of a string array +function IsMember(a: array of string; n: integer; s: string): boolean; +var + i: integer; +begin + Result := false; + for i := 0 to n - 1 do + if SameText(s, a[i]) then + Result := true; +end; + +//------------------------------------------------------------------------------ + +//checks if the color's nam was used instead of hex +function IsSpecialColor(s: string): boolean; +begin + Result := IsMember(BASIC_NAMES, BASIC_COUNT, s) or IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) or IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s); +end; + +//------------------------------------------------------------------------------ + +//is hex was used then remove the wrong characters +procedure MakeIntoHex(var s: string); +var + i: integer; +begin +if s <> '' then + for i := 1 to Length(s) do + if not (s[i] in ['0'..'9', 'A'..'F', 'a'..'f']) then + s[i] := '0'; +end; + +//------------------------------------------------------------------------------ + +//formats entered text into a true hex value +function FormatHexColor(S: string): string; +var + c: string; + i: integer; +begin + c := ''; + if not IsSpecialColor(s) then + begin + if (s <> '') and (s[1] = '#') then + Delete(s, 1, 1); + + if s <> '' then + begin + MakeIntoHex(c); + if Length(c) = 6 then + Result := c + else + begin + if Length(c) > 6 then + c := Copy(c, 1, 6); + if Length(c) < 6 then + for i := 0 to 6 - Length(c) - 1 do + c := '0' + c; + Result := c; + end; + end + else + Result := '000000'; + end + else + Result := s; +end; + +//------------------------------------------------------------------------------ + +//gets a hex value from a color name from special colors +function GetHexFromName(s: string): string; +var + i, k: integer; +begin + k := 0; + for i := 0 to SPECIAL_COUNT - 1 do + if SameText(s, SPECIAL_NAMES[i]) then + begin + k := i; + Break; + end; + Result := SPECIAL_HEX[k]; +end; + +//------------------------------------------------------------------------------ + +// gets a TColor value from a color name from basic or system colors +function GetValueFromName(s: string): TColor; +var + i, k: integer; +begin + k := 0; + s := LowerCase(s); + if IsMember(BASIC_NAMES, BASIC_COUNT, s) then + begin + for i := 0 to BASIC_COUNT - 1 do + if SameText(s, BASIC_NAMES[i]) then + begin + k := i; + Break; + end; + Result := BASIC_VALUES[k]; + end + else + if IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s) then + begin + for i := 0 to SYSTEM_COUNT - 1 do + if SameText(s, SYSTEM_NAMES[i]) then + begin + k := i; + Break; + end; + Result := SYSTEM_VALUES[k]; + end + else + Result := clNone; +end; + +//------------------------------------------------------------------------------ + +//converts a TColor value to a hex value +function ColorToHex(Color: TColor): string; +begin +// if Color <> $ then + Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2) +// else +// Result := '000000'; +end; + +//------------------------------------------------------------------------------ + +//converts a hex value to a TColor +function HexToTColor(s: OleVariant): TColor; +begin + if s <> null then + begin + if not IsSpecialColor(s) then + begin + s := FormatHexColor(s); + if s <> '' then + Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2))) + else + Result := clNone; + end + else + if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then + begin + s := GetHexFromName(s); + Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2))); + end + else + Result := GetValueFromName(s); + end + else + Result := clNone; +end; + +//------------------------------------------------------------------------------ + +//checks if a hex value belongs to the websafe palette +function IsWebSafe(s: string): boolean; +begin + s := FormatHexColor(s); + Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s); +end; + +//------------------------------------------------------------------------------ + +//checks if a color belongs to the websafe palette +function IsWebSafe(c: TColor): boolean; +var + s: string; +begin + s := ColorToHex(c); + Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s); +end; + +//------------------------------------------------------------------------------ + +//initializes the websafe comparison array +procedure InitializeWS; + var + i: integer; + begin + for i := 0 to 255 do + WS[I] := ((i + $19) div $33) * $33; + end; + +//------------------------------------------------------------------------------ + +//returns the closest web safe color to the one given +function GetWebSafe(C: TColor): TColor; +begin + Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]); +end; + +//------------------------------------------------------------------------------ + +initialization + InitializeWS; + +end. diff --git a/components/mbColorLib/HexaColorPicker.dcr b/components/mbColorLib/HexaColorPicker.dcr new file mode 100644 index 000000000..c3a880c5b Binary files /dev/null and b/components/mbColorLib/HexaColorPicker.dcr differ diff --git a/components/mbColorLib/HexaColorPicker.pas b/components/mbColorLib/HexaColorPicker.pas new file mode 100644 index 000000000..55a853a7d --- /dev/null +++ b/components/mbColorLib/HexaColorPicker.pas @@ -0,0 +1,1531 @@ +unit HexaColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, StdCtrls, Forms, + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math, + RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils; + +const + CustomCell = -2; + NoCell = -1; + +type + TMarker = (smArrow, smRect); + + TCombEntry = record + Position: TPoint; + Color: COLORREF; + TabIndex: integer; + end; + + TCombArray = array of TCombEntry; + + TFloatPoint = record + X, Y: Extended; + end; + + TRGBrec = record + Red, Green, Blue: Single; + end; + + TSelectionMode = (smNone, smColor, smBW, smRamp); + + THexaColorPicker = class(TCustomControl) + private + FIncrement: integer; + FSelectedCombIndex: integer; + mX, mY: integer; + FHintFormat: string; + FUnderCursor: TColor; + FOnChange, FOnIntensityChange: TNotifyEvent; + FCurrentColor: TColor; + FSelectedIndex: Integer; + FColorCombRect, FBWCombRect, FSliderRect, FCustomColorRect: TRect; + FCombSize, FLevels: Integer; + FBWCombs, FColorCombs: TCombArray; + FCombCorners: array[0..5] of TFloatPoint; + FCenterColor: TRGBrec; + FCenterIntensity: Single; + FSliderWidth: integer; + FCustomIndex, // 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 + // 1 to use index 0 to show no selection. + FRadius: Integer; + FSelectionMode: TSelectionMode; + FSliderVisible: boolean; + FMarker: TMarker; + FNewArrowStyle: boolean; + FIntensityText: string; + + procedure SetNewArrowStyle(Value: boolean); + procedure SetMarker(Value: TMarker); + procedure SetSliderVisible(Value: boolean); + procedure SetRadius(r: integer); + procedure SetSliderWidth(w: integer); + procedure SetIntensity(v: integer); + procedure ChangeIntensity(increase: boolean); + procedure SelectColor(Color: TColor); + procedure Initialise; + 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; + procedure EndSelection; + procedure EnumerateCombs; + function SelectAvailableColor(Color: TColor): boolean; + function GetIntensity: integer; + function HandleBWArea(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; + function HandleColorComb(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; + function HandleSlider(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; + function PtInComb(Comb: TCombEntry; P: TPoint; Scale: Integer): Boolean; + function FindBWArea(X, Y: Integer): Integer; + function FindColorArea(X, Y: Integer): Integer; + function GetNextCombIndex(i: integer): integer; + function GetPreviousCombIndex(i: integer): integer; + protected + 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; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure SelectCombIndex(i: integer); + function GetSelectedCombIndex: integer; + function GetColorUnderCursor: TColor; + function GetHexColorUnderCursor: string; + function GetColorAtPoint(X, Y: integer): TColor; + function GetHexColorAtPoint(X, Y: integer): string; + property ColorUnderCursor: TColor read GetColorUnderCursor; + published + property Align; + property Anchors; + property HintFormat: string read FHintFormat write FHintFormat; + property SelectedColor: TColor read FCurrentColor write SetSelectedColor default clBlack; + property Intensity: integer read GetIntensity write SetIntensity default 100; + property IntensityIncrement: integer read FIncrement write FIncrement default 1; + property SliderVisible: boolean read FSliderVisible write SetSliderVisible default true; + property SliderMarker: TMarker read FMarker write SetMarker default smArrow; + property NewArrowStyle: boolean read FNewArrowStyle write SetNewArrowStyle default false; + property IntensityText: string read FIntensityText write FIntensityText; + property ShowHint default true; + property TabStop default true; + 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 SliderWidth: integer read FSliderWidth write SetSliderWidth default 12; + property DragCursor; + property DragMode; + property DragKind; + property Constraints; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnIntensityChange: TNotifyEvent read FOnIntensityChange write FOnIntensityChange; + property OnDblClick; + property OnContextPopup; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelUp; + property OnMouseWheelDown; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnResize; + property OnStartDrag; + end; + + const + DefCenterColor: TRGBrec =(Red: 1; Green: 1; Blue: 1); // White + DefColors: array[0..5] of TRGBrec = ( + (Red: 1; Green: 0; Blue: 1), // Magenta + (Red: 1; Green: 0; Blue: 0), // Red + (Red: 1; Green: 1; Blue: 0), // Yellow + (Red: 0; Green: 1; Blue: 0), // Green + (Red: 0; Green: 1; Blue: 1), // Cyan + (Red: 0; Green: 0; Blue: 1) // Blue + ); + DefCenter: TFloatPoint = (X: 0; Y: 0); + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R HexaColorPicker.dcr} +{$ENDIF} + +uses + PalUtils; + +procedure Register; +begin + RegisterComponents('mbColor Lib', [THexaColorPicker]); +end; + +constructor THexaColorPicker.Create(AOwner: TComponent); +begin + inherited; + ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; + FRadius := 90; + FSliderWidth := 12; + DoubleBuffered := true; + ParentColor := true; + {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} + ParentBackground := true; + {$ENDIF}{$ENDIF} + Width := 204; + Height := 206; + Constraints.MinHeight := 85; + Constraints.MinWidth := 93; + TabStop := true; + FSelectedCombIndex := 0; + FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: #%hex'; + ShowHint := True; + FSliderVisible := true; + FMarker := smArrow; + FNewArrowStyle := false; + Initialise; + DrawAll; + OnMouseWheelUp := WheelUp; + OnMouseWheelDown := WheelDown; + FIntensityText := 'Intensity'; + MaxHue := 360; + MaxLum := 255; + MaxSat := 255; +end; + +procedure THexaColorPicker.CreateWnd; +var + rw, rh: integer; +begin + inherited; + SetSelectedColor(clBlack); + if (Width >= 93) and (Height >= 85) then + begin + if FSliderVisible then + rw := Round((Width - 10 - FSliderWidth)/2) + else + rw := Round(Width/2 - 5); + rh := Round((24/53)*(Height - 6)); + SetRadius(Min(rw, rh)); + end; +end; + +procedure THexaColorPicker.Initialise; +var + I: Integer; +begin + FSelectedIndex := NoCell; + for I := 0 to 5 do + begin + FCombCorners[I].X := 0.5 * cos(Pi * (90 - I * 60) / 180); + FCombCorners[I].Y := 0.5 * sin(Pi * (90 - I * 60) / 180); + end; + FLevels := 7; + FCombSize := Round(FRadius / (FLevels - 1)); + FCenterColor := DefCenterColor; + FIncrement := 1; + FCenterIntensity := 1; +end; + +destructor THexaColorPicker.Destroy; +begin + FBWCombs := nil; + FColorCombs := nil; + inherited; +end; + +procedure THexaColorPicker.DrawComb(Canvas: TCanvas; X, Y: Integer; Size: Integer); +var + I: Integer; + P: array[0..5] of TPoint; +begin + for I := 0 to 5 do + begin + P[I].X := Round(FCombCorners[I].X * Size + X); + P[I].Y := Round(FCombCorners[I].Y * Size + Y); + end; + Canvas.Polygon(P); +end; + +procedure THexaColorPicker.DrawCombControls; +var + I, Index: Integer; + XOffs, YOffs, Count: Integer; + dColor: Single; + OffScreen: TBitmap; + {$IFDEF DELPHI_7_UP} + MemDC: HDC; + OldBMP: HBITMAP; + {$ENDIF} +begin + OffScreen := TBitmap.Create; + try + OffScreen.PixelFormat := pf32bit; + OffScreen.Width := Width; + OffScreen.Height := FColorCombRect.Bottom - FColorCombRect.Top + FBWCombRect.Bottom - FBWCombRect.Top; + //Parent background + {$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} + with OffScreen.Canvas do + begin + Pen.Style := psClear; + // draw color comb from FColorCombs array + XOffs := FRadius + FColorCombRect.Left; + YOffs := FRadius + FColorCombRect.Top; + // draw the combs + for I := 0 to High(FColorCombs) do + begin + Brush.Color := FColorCombs[I].Color; + Pen.mode := pmCopy; // the pen is set here so there are no gaps between the combs + Pen.style := psSolid; + Pen.color := FColorCombs[I].Color; + DrawComb(OffScreen.Canvas, FColorCombs[I].Position.X + XOffs, FColorCombs[I].Position.Y + YOffs, FCombSize); + end; + // mark selected comb + if FCustomIndex > 0 then + begin + Index := FCustomIndex - 1; + FSelectedCombIndex := index; + Pen.Style := psSolid; + Pen.Mode := pmXOR; + Pen.Color := clWhite; + Pen.Width := 2; + Brush.Style := bsClear; + DrawComb(OffScreen.Canvas, FColorCombs[Index].Position.X + XOffs, FColorCombs[Index].Position.Y + YOffs, FCombSize); + Pen.Style := psClear; + Pen.Mode := pmCopy; + Pen.Width := 1; + end; + // draw white-to-black combs + XOffs := FColorCombRect.Left; + YOffs := FColorCombRect.Bottom - 4; + // brush is automatically reset to bsSolid + for I := 0 to High(FBWCombs) do + begin + Pen.Mode := pmCopy; // the pen is set here so there are no gaps between the combs + Pen.Style := psSolid; + Pen.Color := FBWCombs[I].Color; + Brush.Color := FBWCombs[I].Color; + if I in [0, High(FBWCombs)] then + DrawComb(OffScreen.Canvas, FBWCombs[I].Position.X + XOffs, FBWCombs[I].Position.Y + YOffs, 2 * FCombSize) + else + DrawComb(OffScreen.Canvas, FBWCombs[I].Position.X + XOffs, FBWCombs[I].Position.Y + YOffs, FCombSize); + end; + // mark selected comb + if FCustomIndex < 0 then + begin + Index := -(FCustomIndex + 1); + if index < 0 then + FSelectedCombIndex := Index + else + FSelectedCombIndex := -index; + Pen.Style := psSolid; + Pen.Mode := pmXOR; + Pen.Color := clWhite; + Pen.Width := 2; + Brush.Style := bsClear; + if Index in [0, High(FBWCombs)] then + begin + if ((FColorCombs[0].Color = Cardinal(clWhite)) and (Index = 0)) or ((FColorCombs[0].Color = Cardinal(clBlack)) and (Index = High(FBWCombs))) then + DrawComb(OffScreen.Canvas, FRadius + FColorCombRect.Left, FRadius + FColorCombRect.Top, FCombSize); // mark white or black center + DrawComb(OffScreen.Canvas, FBWCombs[Index].Position.X + XOffs, FBWCombs[Index].Position.Y + YOffs, 2 * FCombSize); + end + else + DrawComb(OffScreen.Canvas, FBWCombs[Index].Position.X + XOffs, FBWCombs[Index].Position.Y + YOffs, FCombSize); + Pen.Style := psClear; + Pen.Mode := pmCopy; + Pen.Width := 1; + end; + if FSliderVisible then + begin + // center-color trackbar + XOffs := FSliderRect.Left; + YOffs := FSliderRect.Top; + Count := FSliderRect.Bottom - FSliderRect.Top - 1; + dColor := 255 / Count; + Pen.Style := psSolid; + // b&w ramp + for I := 0 to Count do + begin + Pen.Color := RGB(Round((Count - I) * dColor), Round((Count - I) * dColor), Round((Count - I) * dColor)); + MoveTo(XOffs, YOffs + I); + LineTo(XOffs + FSliderWidth, YOffs + I); + end; + // draw marker + Inc(XOffs, FSliderWidth + 1); + Inc(YOffs, Round(Count * (1 - FCenterIntensity))); + case FMarker of + smArrow: + begin + if not FNewArrowStyle then + begin + Brush.Color := clBlack; + Polygon([Point(XOffs, YOffs), Point(XOffs + 6, YOffs - 4), Point(XOffs + 6, YOffs + 4)]) + end + else + begin + Brush.Color := clWhite; + Pen.Color := clBtnShadow; + Polygon([Point(XOffs, YOffs), Point(XOffs + 4, YOffs - 4), Point(XOffs + 6, YOffs - 4), + Point(XOffs + 7, YOffs - 3), Point(XOffs + 7, YOffs + 3), + Point(XOffs + 6, YOffs + 4), Point(XOffs + 4, YOffs + 4)]); + end; + end; + smRect: + begin + Brush.Style := bsClear; + Pen.Mode := pmNot; + Rectangle(XOffs - FSliderWidth - 4, YOffs - 3, XOffs + 2, YOffs + 3); + Pen.Mode := pmCopy; + Brush.Style := bsSolid; + end; + end; + Pen.Style := psClear; + end; + end; + Canvas.Draw(0, 0, OffScreen); + finally + Offscreen.Free; + end; + 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; + if FColorCombs = nil then + CalculateCombLayout; + DrawCombControls; +end; + +// determines whether the mouse position is within the slider area and acts accordingly +function THexaColorPicker.HandleSlider( + const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; +var + Shift: TShiftState; + dY: Integer; + R: TRect; +begin + if not FSliderVisible then + begin + Result := false; + Exit; + end; + Result := PtInRect(FSliderRect, Point(Message.XPos, Message.YPos)) and (FSelectionMode = smNone) or + ((Message.XPos >= FSliderRect.Left) and (Message.XPos <= FSliderRect.Right) and (FSelectionMode = smRamp)); + if Result then + begin + Shift := KeysToShiftState(Message.Keys); + if ssLeft in Shift then + begin + FSelectionMode := smRamp; + dY := FSliderRect.Bottom - FSliderRect.Top; + FCenterIntensity := 1 - (Message.YPos - FSliderRect.Top) / dY; + if FCenterIntensity < 0 then FCenterIntensity := 0; + if FCenterIntensity > 1 then FCenterIntensity := 1; + FCenterColor.Red := DefCenterColor.Red * FCenterIntensity; + FCenterColor.Green := DefCenterColor.Green * FCenterIntensity; + FCenterColor.Blue := DefCenterColor.Blue * FCenterIntensity; + R := FSliderRect; + Dec(R.Top, 3); + Inc(R.Bottom, 3); + Inc(R.Left, 10); + InvalidateRect(Handle, @R, False); + FColorCombs := nil; + InvalidateRect(Handle, @FColorCombRect, False); + InvalidateRect(Handle, @FCustomColorRect, False); + CalculateCombLayout; + EndSelection; + if Assigned(FOnIntensityChange) then + FOnIntensityChange(Self); + end; + end; +end; + +function THexaColorPicker.PtInComb(Comb: TCombEntry; P: TPoint; Scale: Integer): Boolean; +begin + Result := (Sqr(Comb.Position.X - P.X) + Sqr(Comb.Position.Y - P.Y)) <= (Scale * Scale); +end; + +// Looks for a comb at position (X, Y) in the black&white area. +// Result is -1 if nothing could be found else the index of the particular comb +// into FBWCombs. +function THexaColorPicker.FindBWArea(X, Y: Integer): Integer; +var + I, Scale: Integer; + Pt: TPoint; +begin + Result := -1; + Pt := Point(X - FBWCombRect.Left, Y - FBWCombRect.Top); + for I := 0 to High(FBWCombs) do + begin + if I in [0, High(FBWCombs)] then + Scale := FCombSize + else + Scale := FCombSize div 2; + if PtInComb(FBWCombs[I], Pt, Scale) then + begin + Result := I; + Break; + end; + end; +end; + +// determines whether the mouse position is within the B&W comb area and acts accordingly +function THexaColorPicker.HandleBWArea( + const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; +var + Index: Integer; + Shift: TShiftState; +begin + Result := PtInRect(FBWCombRect, Point(Message.XPos, Message.YPos)) and (FSelectionMode in [smNone, smBW]); + if Result then + begin + Shift := KeysToShiftState(Message.Keys); + if ssLeft in Shift then + begin + FSelectionMode := smBW; + Index := FindBWArea(Message.XPos, Message.YPos); + if Index > -1 then + begin + // remove selection comb if it was previously in color comb + if FCustomIndex > 0 then InvalidateRect(Handle, @FColorCombRect, False); + if FCustomIndex <> -(Index + 1) then + begin + FCustomIndex := -(Index + 1); + InvalidateRect(Handle, @FBWCombRect, False); + InvalidateRect(Handle, @FCustomColorRect, False); + EndSelection; + end; + end + else + Result := False; + end; + end; +end; + +// Looks for a comb at position (X, Y) in the custom color area. +// Result is -1 if nothing could be found else the index of the particular comb +// into FColorCombs. +function THexaColorPicker.FindColorArea(X, Y: Integer): Integer; +var + I: Integer; + Pt: TPoint; +begin + Result := -1; + Pt := Point(X - (FRadius + FColorCombRect.Left), Y - (FRadius + FColorCombRect.Top)); + for I := 0 to High(FColorCombs) do + begin + if PtInComb(FColorCombs[I], Pt, FCombSize div 2) then + begin + Result := I; + Break; + end; + end; +end; + +// determines whether the mouse position is within the color comb area and acts accordingly +function THexaColorPicker.HandleColorComb( + const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; +var + Index: Integer; + Shift: TShiftState; +begin + Result := PtInRect(FColorCombRect, Point(Message.XPos, Message.YPos)) and (FSelectionMode in [smNone, smColor]); + if Result then + begin + Shift := KeysToShiftState(Message.Keys); + if ssLeft in Shift then + begin + FSelectionMode := smColor; + Index := FindColorArea(Message.XPos, Message.YPos); + if Index > -1 then + begin + // remove selection comb if it was previously in b&w comb + if FCustomIndex < 0 then InvalidateRect(Handle, @FBWCombRect, False); + if FCustomIndex <> (Index + 1) then + begin + FCustomIndex := Index + 1; + InvalidateRect(Handle, @FColorCombRect, False); + InvalidateRect(Handle, @FCustomColorRect, False); + EndSelection; + end; + end + else + Result := False; + end; + end; +end; + +procedure THexaColorPicker.HandleCustomColors( + var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}); +begin + if not HandleSlider(Message) then + if not HandleBWArea(Message) then + HandleColorComb(Message); +end; + +procedure THexaColorPicker.WMMouseMove( + var Message: {$IFDEF FPC}TLMMouseMove{$ELSE}TWMMouseMove{$ENDIF} ); +var + Shift: TShiftState; + Index: Integer; + Colors: TCombArray; +begin + inherited; + mX := Message.XPos; + mY := Message.YPos; + //get color under cursor + Colors := nil; + FUnderCursor := clNone; + if PtInRect(FBWCombRect, Point(Message.XPos, Message.YPos)) then + begin + Index := FindBWArea(Message.XPos, Message.YPos); + Colors := FBWCombs; + if (Index > -1) and (Colors <> nil) then + FUnderCursor := Colors[Index].Color; + end + else + if PtInRect(FColorCombRect, Point(Message.XPos, Message.YPos)) then + begin + Index := FindColorArea(Message.XPos, Message.YPos); + Colors := FColorCombs; + if (Index > -1) and (Colors <> nil) then + FUnderCursor := Colors[Index].Color; + end + else + FUnderCursor := clNone; + // further process message + Shift := KeysToShiftState(Message.Keys); + if ssLeft in Shift then + HandleCustomColors(Message); +end; + +procedure THexaColorPicker.WMLButtonDown( + var Message: {$IFDEF FPC}TLMLButtonDown{$ELSE}TWMLButtonDown{$ENDIF} ); +begin + inherited; + SetFocus; // needed so the key events work + if PtInRect(ClientRect, Point(Message.XPos, Message.YPos)) then + HandleCustomColors(Message); +end; + +procedure THexaColorPicker.WMLButtonUp( + var Message: {$IFDEF FPC}TLMLButtonUp{$ELSE}TWMLButtonUp{$ENDIF} ); +var + LastMode: TSelectionMode; +begin + inherited; + LastMode := FSelectionMode; + FSelectionMode := smNone; + if (FSelectedIndex = CustomCell) and (FCustomIndex <> 0) then + begin + if ((FSelectedIndex = CustomCell) and (LastMode in [smColor, smBW])) or + (FSelectedIndex <> NoCell) and (FSelectedIndex <> CustomCell) then + EndSelection + end; +end; + +procedure THexaColorPicker.DrawAll; +var + WinTop: integer; +begin + WinTop := - FRadius div 8; // use 10 instead of 8 if the top has been cut + FCombSize := Round(1 + FRadius / (FLevels - 1)); + FColorCombRect := Rect(0, WinTop, 2 * FRadius, 2 * FRadius + WinTop); + FBWCombRect := Rect(FColorCombRect.Left, FColorCombRect.Bottom - 4, + Round(17 * FCombSize * cos(Pi / 6) / 2) + 6 * FCombSize, + FColorCombRect.Bottom + 2 * FCombSize); + if FSliderVisible then + FSliderRect := Rect(FColorCombRect.Right, FCombSize, FColorCombRect.Right + 10 + FSliderWidth, FColorCombRect.Bottom - FCombSize) + else + FSliderRect := Rect(-1, -1, -1, -1); +end; + +// fills arrays with centers and colors for the custom color and black & white combs, +// these arrays are used to quickly draw the combx and do hit tests + +function RGBFromFloat(Color: TRGBrec): COLORREF; +begin + Result := RGB(Round(255 * Color.Red), Round(255 * Color.Green), Round(255 * Color.Blue)); +end; + +{function TRGBrecFromTColor(Color: TColor): TRGBrec; +begin + Result.Red := GetRValue(Color)/255; + Result.Green := GetGValue(Color)/255; + Result.Blue := GetBValue(Color)/255; +end;} + +procedure THexaColorPicker.CalculateCombLayout; + + function GrayFromIntensity(Intensity: Byte): COLORREF; + begin + Result := RGB(Intensity, Intensity, Intensity); + end; + +var + I, J, Level, CurrentIndex, CombCount: Cardinal; + CurrentColor: TRGBrec; + CurrentPos: TFloatPoint; + Scale: Extended; + // triangle vars + Pos1, Pos2, dPos1, dPos2, dPos: TFloatPoint; + Color1, Color2, dColor1, dColor2, dColor: TRGBrec; +begin + // this ensures the radius and comb size is set correctly + HandleNeeded; + if FLevels < 1 then FLevels := 1; + // To draw perfectly aligned combs we split the final comb into six triangles (sextants) + // and calculate each separately. The center comb is stored as first entry in the array + // and will not considered twice (as with the other shared combs too). + // + // The way used here for calculation of the layout seems a bit complicated, but works + // correctly for all cases (even if the comb corners are rotated). + // initialization + CurrentIndex := 0; + CurrentColor := FCenterColor; + // number of combs can be calculated by: + // 1 level: 1 comb (the center) + // 2 levels: 1 comb + 6 combs + // 3 levels: 1 comb + 1 * 6 combs + 2 * 6 combs + // n levels: 1 combs + 1 * 6 combs + 2 * 6 combs + .. + (n-1) * 6 combs + // this equals to 1 + 6 * (1 + 2 + 3 + .. + (n-1)), by using Gauss' famous formula we get: + // Count = 1 + 6 * (((n-1) * n) / 2) + // Because there's always an even number involved (either n or n-1) we can use an integer div + // instead of a float div here... + CombCount := 1 + 6 * (((FLevels - 1) * FLevels) div 2); + SetLength(FColorCombs, CombCount); + // store center values + FColorCombs[CurrentIndex].Position := Point(0, 0); + FColorCombs[CurrentIndex].Color := RGBFromFloat(CurrentColor); + Inc(CurrentIndex); + // go out off here if there are not further levels to draw + if FLevels < 2 then Exit; + // now go for each sextant, the generic corners have been calculated already at creation + // time for a comb with diameter 1 + // ------ + // /\ 1 /\ + // / \ / \ + // / 2 \/ 0 \ + // ----------- + // \ 3 /\ 5 / + // \ / \ / + // \/ 4 \/ + // ------ + for I := 0 to 5 do + begin + // initialize triangle corner values + // + // center (always at 0,0) + // /\ + // dPos1 / \ dPos2 + // dColor1 / \ dColor2 + // / dPos \ + // /--------\ (span) + // / dColor \ + // /____________\ + // comb corner 1 comb corner 2 + // + // Pos1, Pos2, Color1, Color2 are running terms for both sides of the triangle + // incremented by dPos1/2 and dColor1/2. + // dPos and dColor are used to interpolate a span between the values just mentioned. + // + // The small combs are actually oriented with corner 0 at top (i.e. mirrored at y = x, + // compared with the values in FCombCorners), we can achieve that by simply exchanging + // X and Y values. + Scale := 2 * FRadius * cos(Pi / 6); + Pos1.X := FCombCorners[I].Y * Scale; + Pos1.Y := FCombCorners[I].X * Scale; + Color1 := DefColors[I]; + if I = 5 then + begin + Pos2.X := FCombCorners[0].Y * Scale; + Pos2.Y := FCombCorners[0].X * Scale; + Color2 := DefColors[0]; + end + else + begin + Pos2.X := FCombCorners[I + 1].Y * Scale; + Pos2.Y := FCombCorners[I + 1].X * Scale; + Color2 := DefColors[I + 1]; + end; + dPos1.X := Pos1.X / (FLevels - 1); + dPos1.Y := Pos1.Y / (FLevels - 1); + dPos2.X := Pos2.X / (FLevels - 1); + dPos2.Y := Pos2.Y / (FLevels - 1); + dColor1.Red := (Color1.Red - FCenterColor.Red) / (FLevels - 1); + dColor1.Green := (Color1.Green - FCenterColor.Green) / (FLevels - 1); + dColor1.Blue := (Color1.Blue - FCenterColor.Blue) / (FLevels - 1); + + dColor2.Red := (Color2.Red - FCenterColor.Red) / (FLevels - 1); + dColor2.Green := (Color2.Green - FCenterColor.Green) / (FLevels - 1); + dColor2.Blue := (Color2.Blue - FCenterColor.Blue) / (FLevels - 1); + + Pos1 := DefCenter; + Pos2 := DefCenter; + Color1 := FCenterColor; + Color2 := FCenterColor; + + // Now that we have finished the initialization for this step we'll go + // through a loop for each level to calculate the spans. + // We can ignore level 0 (as this is the center we already have determined) as well + // as the last step of each span (as this is the start value in the next triangle and will + // be calculated there). We have, though, take them into the calculation of the running terms. + for Level := 0 to FLevels - 1 do + begin + if Level > 0 then + begin + // initialize span values + dPos.X := (Pos2.X - Pos1.X) / Level; + dPos.Y := (Pos2.Y - Pos1.Y) / Level; + dColor.Red := (Color2.Red - Color1.Red) / Level; + dColor.Green := (Color2.Green - Color1.Green) / Level; + dColor.Blue := (Color2.Blue - Color1.Blue) / Level; + CurrentPos := Pos1; + CurrentColor := Color1; + for J := 0 to Level - 1 do + begin + // store current values in the array + FColorCombs[CurrentIndex].Position.X := Round(CurrentPos.X); + FColorCombs[CurrentIndex].Position.Y := Round(CurrentPos.Y); + FColorCombs[CurrentIndex].Color := RGBFromFloat(CurrentColor); + Inc(CurrentIndex); + + // advance in span + CurrentPos.X := CurrentPos.X + dPos.X; + CurrentPos.Y := CurrentPos.Y + dPos.Y; + + CurrentColor.Red := CurrentColor.Red + dColor.Red; + CurrentColor.Green := CurrentColor.Green + dColor.Green; + CurrentColor.Blue := CurrentColor.Blue + dColor.Blue; + end; + end; + // advance running terms + Pos1.X := Pos1.X + dPos1.X; + Pos1.Y := Pos1.Y + dPos1.Y; + Pos2.X := Pos2.X + dPos2.X; + Pos2.Y := Pos2.Y + dPos2.Y; + + Color1.Red := Color1.Red + dColor1.Red; + Color1.Green := Color1.Green + dColor1.Green; + Color1.Blue := Color1.Blue + dColor1.Blue; + + Color2.Red := Color2.Red + dColor2.Red; + Color2.Green := Color2.Green + dColor2.Green; + Color2.Blue := Color2.Blue + dColor2.Blue; + end; + end; + + // second step is to build a list for the black & white area + // 17 entries from pure white to pure black + // the first and last are implicitely of double comb size + SetLength(FBWCombs, 17); + CurrentIndex := 0; + FBWCombs[CurrentIndex].Color := GrayFromIntensity(255); + FBWCombs[CurrentIndex].Position := Point(FCombSize, FCombSize); + Inc(CurrentIndex); + + CurrentPos.X := 3 * FCombSize; + CurrentPos.Y := 3 * (FCombSize div 4); + dPos.X := Round(FCombSize * cos(Pi / 6) / 2); + dPos.Y := Round(FCombSize * (1 + sin(Pi / 6)) / 2); + for I := 0 to 14 do + begin + FBWCombs[CurrentIndex].Color := GrayFromIntensity((16 - CurrentIndex) * 15); + if Odd(I) then + FBWCombs[CurrentIndex].Position := Point(Round(CurrentPos.X + I * dPos.X), Round(CurrentPos.Y + dPos.Y)) + else + FBWCombs[CurrentIndex].Position := Point(Round(CurrentPos.X + I * dPos.X), Round(CurrentPos.Y)); + Inc(CurrentIndex); + end; + FBWCombs[CurrentIndex].Color := 0; + FBWCombs[CurrentIndex].Position := Point(Round(CurrentPos.X + 16 * dPos.X + FCombSize), FCombSize); + EnumerateCombs; +end; + +// determine hint message and out-of-hint rect +procedure THexaColorPicker.CMHintShow( + var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF} ); +var + Index: Integer; + Colors: TCombArray; +begin + Colors := nil; +if (GetColorUnderCursor <> clNone) or PtInRect(FSliderRect, Point(mX, mY)) then + with TCMHintShow(Message) do + begin + if not ShowHint then + Message.Result := 1 + else + begin + with HintInfo^ do + begin + // show that we want a hint + Result := 0; + ReshowTimeout := 1; + HideTimeout := 5000; + if PtInRect(FSliderRect, Point(CursorPos.X, CursorPos.Y)) and FSliderVisible then + begin + // in case of the intensity slider we show the current intensity + HintStr := FIntensityText + Format(': %d%%', [Round(100 * FCenterIntensity)]); + HintPos := ClientToScreen(Point(FSliderRect.Right, CursorPos.Y - 8)); + end + else + begin + Index := -1; + if PtInRect(FBWCombRect, Point(CursorPos.X, CursorPos.Y)) then + begin + // considering black&white area... + if csLButtonDown in ControlState then + Index := -(FCustomIndex + 1) + else + Index := FindBWArea(CursorPos.X, CursorPos.Y); + Colors := FBWCombs; + end + else + if PtInRect(FColorCombRect, Point(CursorPos.X, CursorPos.Y)) then + begin + // considering color comb area... + if csLButtonDown in ControlState then + Index := FCustomIndex - 1 + else + Index := FindColorArea(CursorPos.X, CursorPos.Y); + Colors := FColorCombs; + end; + if (Index > -1) and (Colors <> nil) then + HintStr := FormatHint(FHintFormat, Colors[Index].Color); + end; + end; + end; + end; +end; + +procedure THexaColorPicker.SetSelectedColor(const Value: TColor); +begin + FCurrentColor := Value; + SelectColor(Value); + Invalidate; +end; + +procedure THexaColorPicker.EndSelection; +begin + if FCustomIndex < 0 then + SetSelectedColor(FBWCombs[-(FCustomIndex + 1)].Color) + else + if FCustomIndex > 0 then + SetSelectedColor(FColorCombs[FCustomIndex - 1].Color) + else + SetSelectedColor(clNone); +end; + +function THexaColorPicker.GetColorUnderCursor: TColor; +begin + Result := FUnderCursor; +end; + +function THexaColorPicker.GetColorAtPoint(X, Y: integer): TColor; +var + Index: Integer; + Colors: TCombArray; +begin + Colors := nil; + Index := -1; + if PtInRect(FBWCombRect, Point(X, Y)) then + begin + Index := FindBWArea(X, Y); + Colors := FBWCombs; + end + else + if PtInRect(FColorCombRect, Point(X, Y)) then + begin + Index := FindColorArea(X, Y); + Colors := FColorCombs; + end; + if (Index > -1) and (Colors <> nil) then + Result := Colors[Index].Color + else + Result := clNone; +end; + +function THexaColorPicker.GetHexColorUnderCursor: string; +begin + Result := ColorToHex(GetColorUnderCursor); +end; + +function THexaColorPicker.GetHexColorAtPoint(X, Y: integer): string; +begin + Result := ColorToHex(GetColorAtPoint(X, Y)); +end; + +procedure THexaColorPicker.EnumerateCombs; +var + i, k: integer; +begin + k := 0; + if FBWCombs <> nil then + for i := 1 to High(FBWCombs) do + begin + case i of + // b & w comb indices + 1: k := -1; + 2: k := -9; + 3: k := -2; + 4: k := -10; + 5: k := -3; + 6: k := -11; + 7: k := -4; + 8: k := -12; + 9: k := -5; + 10: k := -13; + 11: k := -6; + 12: k := -14; + 13: k := -7; + 14: k := -15; + 15: k := -8; + // big black comb index (match center comb) + 16: K := 64; + end; + FBWCombs[i].TabIndex := k; + end; + if FColorCombs <> nil then + for i := 0 to High(FColorCombs) do + begin + case i of + // center comb index + 0: k := 64; + // color comb indices + 1: k := 65; + 2: k := 66; + 3: k := 78; + 4: k := 67; + 5: k := 79; + 6: k := 90; + 7: k := 68; + 8: k := 80; + 9: k := 91; + 10: k := 101; + 11: k := 69; + 12: k := 81; + 13: k := 92; + 14: k := 102; + 15: k := 111; + 16: k := 70; + 17: k := 82; + 18: k := 93; + 19: k := 103; + 20: k := 112; + 21: k := 120; + 22: k := 77; + 23: k := 89; + 24: k := 88; + 25: k := 100; + 26: k := 99; + 27: k := 98; + 28: k := 110; + 29: k := 109; + 30: k := 108; + 31: k := 107; + 32: k := 119; + 33: k := 118; + 34: k := 117; + 35: k := 116; + 36: k := 115; + 37: k := 127; + 38: k := 126; + 39: k := 125; + 40: k := 124; + 41: k := 123; + 42: k := 122; + 43: k := 76; + 44: k := 87; + 45: k := 75; + 46: k := 97; + 47: k := 86; + 48: k := 74; + 49: k := 106; + 50: k := 96; + 51: k := 85; + 52: k := 73; + 53: k := 114; + 54: k := 105; + 55: k := 95; + 56: k := 84; + 57: k := 72; + 58: k := 121; + 59: k := 113; + 60: k := 104; + 61: k := 94; + 62: k := 83; + 63: k := 71; + 64: k := 63; + 65: k := 62; + 66: k := 50; + 67: k := 61; + 68: k := 49; + 69: k := 38; + 70: k := 60; + 71: k := 48; + 72: k := 37; + 73: k := 27; + 74: k := 59; + 75: k := 47; + 76: k := 36; + 77: k := 26; + 78: k := 17; + 79: k := 58; + 80: k := 46; + 81: k := 35; + 82: k := 25; + 83: k := 16; + 84: k := 8; + 85: k := 51; + 86: k := 39; + 87: k := 40; + 88: k := 28; + 89: k := 29; + 90: k := 30; + 91: k := 18; + 92: k := 19; + 93: k := 20; + 94: k := 21; + 95: k := 9; + 96: k := 10; + 97: k := 11; + 98: k := 12; + 99: k := 13; + 100: k := 1; + 101: k := 2; + 102: k := 3; + 103: k := 4; + 104: k := 5; + 105: k := 6; + 106: k := 52; + 107: k := 41; + 108: k := 53; + 109: k := 31; + 110: k := 42; + 111: k := 54; + 112: k := 22; + 113: k := 32; + 114: k := 43; + 115: k := 55; + 116: k := 14; + 117: k := 23; + 118: k := 33; + 119: k := 44; + 120: k := 56; + 121: k := 7; + 122: k := 15; + 123: k := 24; + 124: k := 34; + 125: k := 45; + 126: k := 57; + end; + FColorCombs[i].TabIndex := k; + end; +end; + +procedure THexaColorPicker.SelectCombIndex(i: integer); +var + j: integer; +begin + if i > 0 then + begin + if FColorCombs <> nil then + for j := 0 to High(FColorCombs) do + begin + if FColorCombs[j].TabIndex = i then + begin + SetSelectedColor(FColorCombs[j].Color); + Break; + end; + end; + end + else + if FBWCombs <> nil then + for j := 1 to High(FBWCombs) - 1 do + begin + if FBWCombs[j].TabIndex = i then + begin + SetSelectedColor(FBWCombs[j].Color); + Break; + end; + end; +end; + +function THexaColorPicker.GetSelectedCombIndex: integer; +begin + if FSelectedCombIndex < 0 then + Result := FBWCombs[-FSelectedCombIndex].TabIndex + else + Result := FColorCombs[FSelectedCombIndex].TabIndex; +end; + +function THexaColorPicker.GetNextCombIndex(i: integer): integer; +begin + if i = 127 then + Result := -1 + else + if i = -15 then + Result := 1 + else + if i > 0 then + Result := i + 1 + else + Result := i - 1; +end; + +function THexaColorPicker.GetPreviousCombIndex(i: integer): integer; +begin + if i = 1 then + Result := -15 + else + if i = -1 then + Result := 127 + else + if i > 0 then + Result := i - 1 + else + Result := i + 1; +end; + +function THexaColorPicker.GetIntensity: integer; +begin + Result := ROUND(FCenterIntensity * 100); +end; + +procedure THexaColorPicker.SetIntensity(v: integer); +var + R: TRect; + s: single; +begin + s := v/100; + FCenterIntensity := s; + if FCenterIntensity < 0 then FCenterIntensity := 0; + if FCenterIntensity > 1 then FCenterIntensity := 1; + FCenterColor.Red := DefCenterColor.Red * FCenterIntensity; + FCenterColor.Green := DefCenterColor.Green * FCenterIntensity; + FCenterColor.Blue := DefCenterColor.Blue * FCenterIntensity; + R := FSliderRect; + Dec(R.Top, 3); + Inc(R.Bottom, 3); + Inc(R.Left, 10); + InvalidateRect(Handle, @R, False); + FColorCombs := nil; + InvalidateRect(Handle, @FColorCombRect, False); + InvalidateRect(Handle, @FCustomColorRect, False); + CalculateCombLayout; + EndSelection; + if Assigned(FOnIntensityChange) then + FOnIntensityChange(Self); +end; + +procedure THexaColorPicker.ChangeIntensity(increase: boolean); +var + i: integer; +begin + i := ROUND(FCenterIntensity * 100); + if increase then + begin + Inc(i, FIncrement); + if i > 100 then i := 100; + SetIntensity(i); + end + else + begin + Dec(i, FIncrement); + if i < 0 then i := 0; + SetIntensity(i); + end; +end; + +procedure THexaColorPicker.SetRadius(r: integer); +begin + {$IFDEF FPC} + if Parent = nil then + exit; + {$ENDIF} + FRadius := r; + DrawAll; + CalculateCombLayout; + DrawCombControls; + Invalidate; +end; + +procedure THexaColorPicker.SetSliderWidth(w: integer); +begin + if (FSliderWidth <> w) and FSliderVisible then + begin + FSliderWidth := w; + DrawAll; + Width := FSliderRect.Right + 2; +// Height := FBWCombRect.Bottom + 2; + CalculateCombLayout; + DrawCombControls; + Invalidate; + end; +end; + +procedure THexaColorPicker.Resize; +var + rw, rh: integer; +begin + if (Width >= 93) and (Height >= 85) then + begin + if FSliderVisible then + rw := Round((Width - 10 - FSliderWidth)/2) + else + rw := Round(Width/2 - 5); + rh := Round((24/53)*(Height - 6)); + SetRadius(Min(rw, rh)); + inherited; + end; +end; + +procedure THexaColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if ssCtrl in Shift then + case Message.CharCode of + VK_LEFT: SetSelectedColor(clWhite); + VK_RIGHT: SetSelectedColor(clBlack); + VK_UP: if FSliderVisible then SetIntensity(100); + VK_DOWN: if FSliderVisible then SetIntensity(0); + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: SelectCombIndex(GetPreviousCombIndex(GetSelectedCombIndex)); + VK_RIGHT: SelectCombIndex(GetNextCombIndex(GetSelectedCombIndex)); + VK_UP: if FSliderVisible then ChangeIntensity(true); + VK_DOWN: if FSliderVisible then ChangeIntensity(false); + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure THexaColorPicker.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + if FSliderVisible then + begin + Handled := true; + ChangeIntensity(true); + end; +end; + +procedure THexaColorPicker.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + if FSliderVisible then + begin + Handled := true; + ChangeIntensity(false); + end; +end; + +function THexaColorPicker.SelectAvailableColor(Color: TColor): boolean; +var + I: integer; + //intens: single; + //SC: TRGBrec; + C: COLORREF; + found: Boolean; +begin + found := False; + Result := false; + C := ColorToRGB(Color); + if FColorCombs = nil then CalculateCombLayout; + FCustomIndex := 0; + FSelectedIndex := NoCell; + for I := 0 to High(FBWCombs) do + if FBWCombs[I].Color = C then + begin + FSelectedIndex := CustomCell; + FCustomIndex := -(I + 1); + found := True; + Result := true; + Break; + end; + if not found then + for I := 0 to High(FColorCombs) do + if FColorCombs[I].Color = C then + begin + FSelectedIndex := CustomCell; + FCustomIndex := I + 1; + //found := true; + Result := true; + Break; + end; + {if not found then // calculate & set intensity if not found + begin + SC := TRGBrecFromTColor(Color); + intens := SC.Red/DefCenterColor.Red; + //SetIntensity(Round(intens * 100)); // EStackOverflow + //SelectAvailableColor(Color); + end;} +end; + +procedure THexaColorPicker.SelectColor(Color: TColor); +begin + SelectAvailableColor(Color); + DrawCombControls; + if Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure THexaColorPicker.SetSliderVisible(Value: boolean); +begin + if FSliderVisible <> Value then + begin + FSliderVisible := Value; + DrawAll; + CalculateCombLayout; + DrawCombControls; + Invalidate; + end; +end; + +procedure THexaColorPicker.SetMarker(Value: TMarker); +begin + if FMarker <> Value then + begin + FMarker := Value; + DrawAll; + CalculateCombLayout; + DrawCombControls; + Invalidate; + end; +end; + +procedure THexaColorPicker.SetNewArrowStyle(Value: boolean); +begin + if FNewArrowStyle <> Value then + begin + FNewArrowStyle := Value; + DrawAll; + CalculateCombLayout; + DrawCombControls; + Invalidate; + end; +end; + +end. diff --git a/components/mbColorLib/KColorPicker.dcr b/components/mbColorLib/KColorPicker.dcr new file mode 100644 index 000000000..90c463530 Binary files /dev/null and b/components/mbColorLib/KColorPicker.dcr differ diff --git a/components/mbColorLib/KColorPicker.pas b/components/mbColorLib/KColorPicker.pas new file mode 100644 index 000000000..d22757377 --- /dev/null +++ b/components/mbColorLib/KColorPicker.pas @@ -0,0 +1,290 @@ +unit KColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; + +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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R KColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + 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; +end; + +procedure TKColorPicker.CreateKGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FKBmp = nil then + begin + FKBmp := TBitmap.Create; + FKBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FKBmp.width := 255; + FKBmp.height := 12; + for i := 0 to 254 do + for j := 0 to 11 do + begin + row := FKBmp.ScanLine[j]; + if not WebSafe then + row[i] := RGBToRGBQuad(CMYKtoTColor(FCyan, FMagenta, FYellow, i)) +// FKBmp.Canvas.Pixels[i, j] := CMYKtoTColor(FCyan, FMagenta, FYellow, i) + else + row[i] := RGBToRGBQuad(GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, i))); +// FKBmp.Canvas.Pixels[i, j] := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, i)); + end; + end + else + begin + FKBmp.width := 12; + FKBmp.height := 255; + for i := 0 to 254 do + begin + row := FKBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBToRGBQuad(CMYKtoTColor(FCyan, FMagenta, FYellow, 255-i)) +// FKBmp.Canvas.Pixels[j, i] := CMYKtoTColor(FCyan, FMagenta, FYellow, 255-i) + else + row[j] := RGBToRGBQuad(GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, 255-i))); +// FKBmp.Canvas.Pixels[j, i] := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, 255-i)); + end; + end; +end; + +procedure TKColorPicker.SetBlack(k: integer); +begin + 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); + end; +end; + +procedure TKColorPicker.SetMagenta(m: integer); +begin + 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); + end; +end; + +procedure TKColorPicker.SetYellow(y: integer); +begin + 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); + end; +end; + +procedure TKColorPicker.SetCyan(c: integer); +begin + 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); + end; +end; + +function TKColorPicker.ArrowPosFromBlack(k: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*k); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TKColorPicker.BlackFromArrowPos(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; +end; + +function TKColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); +end; + +function TKColorPicker.GetSelectedValue: integer; +begin + Result := FBlack; +end; + +procedure TKColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function TKColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/LColorPicker.dcr b/components/mbColorLib/LColorPicker.dcr new file mode 100644 index 000000000..f1f30be32 Binary files /dev/null and b/components/mbColorLib/LColorPicker.dcr differ diff --git a/components/mbColorLib/LColorPicker.pas b/components/mbColorLib/LColorPicker.pas new file mode 100644 index 000000000..6de4e5d33 --- /dev/null +++ b/components/mbColorLib/LColorPicker.pas @@ -0,0 +1,270 @@ +unit LColorPicker; + +interface + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBHSLUtils, mbTrackBarPicker, HTMLColors, Scanlines; + +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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R LColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + 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; +end; + +procedure TLColorPicker.CreateLGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FLBmp = nil then + begin + FLBmp := TBitmap.Create; + FLBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FLBmp.width := MaxLum; + FLBmp.height := 12; + for i := 0 to MaxLum - 1 do + for j := 0 to 11 do + begin + row := FLBmp.Scanline[j]; + if not WebSafe then + row[i] := RGBToRGBQuad(HSLRangeToRGB(FHue, FSat, i)) +// FLBmp.Canvas.Pixels[i, j] := HSLRangeToRGB(FHue, FSat, i) + else + row[i] := RGBToRGBQuad(GetWebSafe(HSLRangeToRGB(FHue, FSat, i))); +// FLBmp.Canvas.Pixels[i, j] := GetWebSafe(HSLRangeToRGB(FHue, FSat, i)); + end; + end + else + begin + FLBmp.width := 12; + FLBmp.height := MaxLum; + for i := 0 to MaxLum - 1 do + begin + row := FLBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBToRGBQuad(HSLRangeToRGB(FHue, FSat, MaxLum - i)) +// FLBmp.Canvas.Pixels[j, i] := HSLRangeToRGB(FHue, FSat, MaxLum - i) + else + row[j] := RGBToRGBQuad(GetWebSafe(HSLRangeToRGB(FHue, FSat, MaxLum - i))); +// FLBmp.Canvas.Pixels[j, i] := GetWebSafe(HSLRangeToRGB(FHue, FSat, MaxLum - i)); + end; + end; +end; + +procedure TLColorPicker.SetHue(h: integer); +begin + 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); + end; +end; + +procedure TLColorPicker.SetSat(s: integer); +begin + 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); + end; +end; + +function TLColorPicker.ArrowPosFromLum(l: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/MaxLum)*l); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TLColorPicker.LumFromArrowPos(p: integer): integer; +var + 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; +end; + +procedure TLColorPicker.SetLuminance(l: integer); +begin + 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); + end; +end; + +function TLColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := HSLRangeToRGB(FHue, FSat, FLuminance) + else + Result := GetWebSafe(HSLRangeToRGB(FHue, FSat, FLuminance)); +end; + +function TLColorPicker.GetSelectedValue: integer; +begin + Result := FLuminance; +end; + +procedure TLColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function TLColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/MColorPicker.dcr b/components/mbColorLib/MColorPicker.dcr new file mode 100644 index 000000000..8f04d4602 Binary files /dev/null and b/components/mbColorLib/MColorPicker.dcr differ diff --git a/components/mbColorLib/MColorPicker.pas b/components/mbColorLib/MColorPicker.pas new file mode 100644 index 000000000..ff9528b4f --- /dev/null +++ b/components/mbColorLib/MColorPicker.pas @@ -0,0 +1,290 @@ +unit MColorPicker; + +interface + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +uses + {$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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R MColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TMColorPicker]); +end; + +{TMColorPicker} + +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; +end; + +procedure TMColorPicker.CreateMGradient; + var + i,j: integer; + row: pRGBQuadArray; +begin + if FMBmp = nil then + begin + FMBmp := TBitmap.Create; + FMBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FMBmp.width := 255; + FMBmp.height := 12; + for i := 0 to 254 do + for j := 0 to 11 do + begin + row := FMBmp.ScanLine[j]; + if not WebSafe then + row[i] := RGBToRGBQuad(CMYKtoTColor(FCyan, i, FYellow, FBlack)) +// FMBmp.Canvas.Pixels[i, j] := CMYKtoTColor(FCyan, i, FYellow, FBlack) + else + row[i] := RGBToRGBQuad(GetWebSafe(CMYKtoTColor(FCyan, i, FYellow, FBlack))); +// FMBmp.Canvas.Pixels[i, j] := GetWebSafe(CMYKtoTColor(FCyan, i, FYellow, FBlack)); + end; + end + else + begin + FMBmp.width := 12; + FMBmp.height := 255; + for i := 0 to 254 do + begin + row := FMBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBToRGBQuad(CMYKtoTColor(FCyan, 255-i, FYellow, FBlack)) +// FMBmp.Canvas.Pixels[j, i] := CMYKtoTColor(FCyan, 255-i, FYellow, FBlack) + else + row[j] := RGBToRGBQuad(GetWebSafe(CMYKtoTColor(FCyan, 255-i, FYellow, FBlack))); +// FMBmp.Canvas.Pixels[j, i] := GetWebSafe(CMYKtoTColor(FCyan, 255-i, FYellow, FBlack)); + end; + end; +end; + +procedure TMColorPicker.SetMagenta(m: integer); +begin + 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); + end; +end; + +procedure TMColorPicker.SetCyan(c: integer); +begin + 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); + end; +end; + +procedure TMColorPicker.SetYellow(y: integer); +begin + 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); + end; +end; + +procedure TMColorPicker.SetBlack(k: integer); +begin + 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); + end; +end; + +function TMColorPicker.ArrowPosFromMagenta(m: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*m); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TMColorPicker.MagentaFromArrowPos(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; +end; + +function TMColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); +end; + +function TMColorPicker.GetSelectedValue: integer; +begin + Result := FMagenta; +end; + +procedure TMColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function TMColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/OfficeMoreColorsDialog.dfm b/components/mbColorLib/OfficeMoreColorsDialog.dfm new file mode 100644 index 000000000..5ec10d554 --- /dev/null +++ b/components/mbColorLib/OfficeMoreColorsDialog.dfm @@ -0,0 +1,204 @@ +object OfficeMoreColorsWin: TOfficeMoreColorsWin + Left = 194 + Top = 112 + Width = 331 + Height = 358 + ActiveControl = OKbtn + BorderIcons = [biSystemMenu] + Caption = 'More colors...' + Color = clBtnFace + Constraints.MinHeight = 358 + Constraints.MinWidth = 331 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Shell Dlg 2' + Font.Style = [] + OldCreateOrder = False + Position = poMainFormCenter + OnCreate = FormCreate + OnKeyDown = FormKeyDown + OnResize = FormResize + DesignSize = ( + 315 + 319) + PixelsPerInch = 96 + TextHeight = 13 + object Label4: TLabel + Left = 268 + Top = 218 + Width = 21 + Height = 13 + Anchors = [akRight, akBottom] + Caption = 'New' + Transparent = True + end + object Label5: TLabel + Left = 260 + Top = 306 + Width = 37 + Height = 13 + Anchors = [akRight, akBottom] + Caption = 'Current' + Transparent = True + end + object Pages: TPageControl + Left = 6 + Top = 6 + Width = 227 + Height = 316 + ActivePage = Standard + Anchors = [akLeft, akTop, akRight, akBottom] + TabOrder = 0 + OnChange = PagesChange + object Standard: TTabSheet + Caption = 'Standard' + DesignSize = ( + 219 + 288) + object Label2: TLabel + Left = 6 + Top = 7 + Width = 34 + Height = 13 + Caption = '&Colors:' + FocusControl = Hexa + Transparent = True + end + object Hexa: THexaColorPicker + Left = 6 + Top = 26 + Width = 209 + Height = 207 + Anchors = [akLeft, akTop, akRight, akBottom] + HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' + IntensityText = 'Intensity' + TabOrder = 0 + Constraints.MinHeight = 85 + Constraints.MinWidth = 93 + OnChange = HexaChange + end + end + object Custom: TTabSheet + Caption = 'Custom' + ImageIndex = 1 + DesignSize = ( + 219 + 288) + object Label1: TLabel + Left = 6 + Top = 7 + Width = 34 + Height = 13 + Caption = '&Colors:' + FocusControl = HSL + end + object Label3: TLabel + Left = 6 + Top = 178 + Width = 60 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = 'Color mo&del:' + FocusControl = ColorModel + end + object LRed: TLabel + Left = 6 + Top = 204 + Width = 23 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Red:' + end + object LGreen: TLabel + Left = 6 + Top = 230 + Width = 33 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Green:' + end + object LBlue: TLabel + Left = 6 + Top = 256 + Width = 24 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Blue:' + end + object HSL: THSLColorPicker + Left = 6 + Top = 20 + Width = 211 + Height = 152 + HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex' + LPickerHintFormat = 'Luminance: %l' + Anchors = [akLeft, akTop, akRight, akBottom] + TabOrder = 0 + OnChange = HSLChange + DesignSize = ( + 211 + 152) + end + object ColorModel: TComboBox + Left = 74 + Top = 172 + Width = 92 + Height = 21 + Style = csDropDownList + Anchors = [akLeft, akBottom] + ItemHeight = 13 + ItemIndex = 0 + TabOrder = 1 + Text = 'RGB' + OnChange = ColorModelChange + Items.Strings = ( + 'RGB' + 'HSL') + end + end + end + object OKbtn: TButton + Left = 242 + Top = 6 + Width = 73 + Height = 23 + Anchors = [akTop, akRight] + Caption = 'OK' + ModalResult = 1 + TabOrder = 1 + end + object Cancelbtn: TButton + Left = 242 + Top = 36 + Width = 73 + Height = 23 + Anchors = [akTop, akRight] + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end + object NewSwatch: TmbColorPreview + Left = 246 + Top = 238 + Width = 68 + Height = 32 + Hint = 'RGB(255, 255, 255)' + Anchors = [akRight, akBottom] + ShowHint = True + ParentShowHint = False + OnColorChange = NewSwatchColorChange + end + object OldSwatch: TmbColorPreview + Left = 246 + Top = 269 + Width = 68 + Height = 32 + Hint = 'RGB(255, 255, 255)'#13#10'Hex: FFFFFF' + Anchors = [akRight, akBottom] + ShowHint = True + ParentShowHint = False + OnColorChange = OldSwatchColorChange + end +end diff --git a/components/mbColorLib/OfficeMoreColorsDialog.lfm b/components/mbColorLib/OfficeMoreColorsDialog.lfm new file mode 100644 index 000000000..5ec10d554 --- /dev/null +++ b/components/mbColorLib/OfficeMoreColorsDialog.lfm @@ -0,0 +1,204 @@ +object OfficeMoreColorsWin: TOfficeMoreColorsWin + Left = 194 + Top = 112 + Width = 331 + Height = 358 + ActiveControl = OKbtn + BorderIcons = [biSystemMenu] + Caption = 'More colors...' + Color = clBtnFace + Constraints.MinHeight = 358 + Constraints.MinWidth = 331 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Shell Dlg 2' + Font.Style = [] + OldCreateOrder = False + Position = poMainFormCenter + OnCreate = FormCreate + OnKeyDown = FormKeyDown + OnResize = FormResize + DesignSize = ( + 315 + 319) + PixelsPerInch = 96 + TextHeight = 13 + object Label4: TLabel + Left = 268 + Top = 218 + Width = 21 + Height = 13 + Anchors = [akRight, akBottom] + Caption = 'New' + Transparent = True + end + object Label5: TLabel + Left = 260 + Top = 306 + Width = 37 + Height = 13 + Anchors = [akRight, akBottom] + Caption = 'Current' + Transparent = True + end + object Pages: TPageControl + Left = 6 + Top = 6 + Width = 227 + Height = 316 + ActivePage = Standard + Anchors = [akLeft, akTop, akRight, akBottom] + TabOrder = 0 + OnChange = PagesChange + object Standard: TTabSheet + Caption = 'Standard' + DesignSize = ( + 219 + 288) + object Label2: TLabel + Left = 6 + Top = 7 + Width = 34 + Height = 13 + Caption = '&Colors:' + FocusControl = Hexa + Transparent = True + end + object Hexa: THexaColorPicker + Left = 6 + Top = 26 + Width = 209 + Height = 207 + Anchors = [akLeft, akTop, akRight, akBottom] + HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' + IntensityText = 'Intensity' + TabOrder = 0 + Constraints.MinHeight = 85 + Constraints.MinWidth = 93 + OnChange = HexaChange + end + end + object Custom: TTabSheet + Caption = 'Custom' + ImageIndex = 1 + DesignSize = ( + 219 + 288) + object Label1: TLabel + Left = 6 + Top = 7 + Width = 34 + Height = 13 + Caption = '&Colors:' + FocusControl = HSL + end + object Label3: TLabel + Left = 6 + Top = 178 + Width = 60 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = 'Color mo&del:' + FocusControl = ColorModel + end + object LRed: TLabel + Left = 6 + Top = 204 + Width = 23 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Red:' + end + object LGreen: TLabel + Left = 6 + Top = 230 + Width = 33 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Green:' + end + object LBlue: TLabel + Left = 6 + Top = 256 + Width = 24 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Blue:' + end + object HSL: THSLColorPicker + Left = 6 + Top = 20 + Width = 211 + Height = 152 + HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex' + LPickerHintFormat = 'Luminance: %l' + Anchors = [akLeft, akTop, akRight, akBottom] + TabOrder = 0 + OnChange = HSLChange + DesignSize = ( + 211 + 152) + end + object ColorModel: TComboBox + Left = 74 + Top = 172 + Width = 92 + Height = 21 + Style = csDropDownList + Anchors = [akLeft, akBottom] + ItemHeight = 13 + ItemIndex = 0 + TabOrder = 1 + Text = 'RGB' + OnChange = ColorModelChange + Items.Strings = ( + 'RGB' + 'HSL') + end + end + end + object OKbtn: TButton + Left = 242 + Top = 6 + Width = 73 + Height = 23 + Anchors = [akTop, akRight] + Caption = 'OK' + ModalResult = 1 + TabOrder = 1 + end + object Cancelbtn: TButton + Left = 242 + Top = 36 + Width = 73 + Height = 23 + Anchors = [akTop, akRight] + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end + object NewSwatch: TmbColorPreview + Left = 246 + Top = 238 + Width = 68 + Height = 32 + Hint = 'RGB(255, 255, 255)' + Anchors = [akRight, akBottom] + ShowHint = True + ParentShowHint = False + OnColorChange = NewSwatchColorChange + end + object OldSwatch: TmbColorPreview + Left = 246 + Top = 269 + Width = 68 + Height = 32 + Hint = 'RGB(255, 255, 255)'#13#10'Hex: FFFFFF' + Anchors = [akRight, akBottom] + ShowHint = True + ParentShowHint = False + OnColorChange = OldSwatchColorChange + end +end diff --git a/components/mbColorLib/OfficeMoreColorsDialog.pas b/components/mbColorLib/OfficeMoreColorsDialog.pas new file mode 100644 index 000000000..f7e85d435 --- /dev/null +++ b/components/mbColorLib/OfficeMoreColorsDialog.pas @@ -0,0 +1,340 @@ +unit OfficeMoreColorsDialog; + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, {$IFDEF DELPHI_6_UP}Variants,{$ENDIF} Classes, Graphics, Controls, + Forms, StdCtrls, ExtCtrls, ComCtrls, + HexaColorPicker, HSLColorPicker, RGBHSLUtils, + mbColorPreview, {$IFDEF mbXP_Lib}mbXPSpinEdit, mbXPSizeGrip,{$ELSE} Spin,{$ENDIF} + HTMLColors; + +type + TOfficeMoreColorsWin = class(TForm) + Pages: TPageControl; + Standard: TTabSheet; + Custom: TTabSheet; + Hexa: THexaColorPicker; + HSL: THSLColorPicker; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + ColorModel: TComboBox; + LRed: TLabel; + LGreen: TLabel; + LBlue: TLabel; + Label4: TLabel; + Label5: TLabel; + OKbtn: TButton; + Cancelbtn: TButton; + NewSwatch: TmbColorPreview; + OldSwatch: TmbColorPreview; + procedure ColorModelChange(Sender: TObject); + procedure HSLChange(Sender: TObject); + procedure ERedChange(Sender: TObject); + procedure EGreenChange(Sender: TObject); + procedure EBlueChange(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure HexaChange(Sender: TObject); + procedure NewSwatchColorChange(Sender: TObject); + procedure OldSwatchColorChange(Sender: TObject); + function GetHint(c: TColor): string; + procedure SetAllToSel(c: TColor); + procedure PagesChange(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure FormCreate(Sender: TObject); + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + end; + +var + OfficeMoreColorsWin: TOfficeMoreColorsWin; + h, s, l: integer; + {$IFDEF mbXP_Lib} + ERed, EGreen, EBlue: TmbXPSpinEdit; + grip: TmbXPSizeGrip; + {$ELSE} + ERed, EGreen, EBlue: TSpinEdit; + {$ENDIF} + +implementation + +{$IFDEF DELPHI} + {$R *.dfm} +{$ELSE} + {$R *.lfm} +{$ENDIF} + +procedure TOfficeMoreColorsWin.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + Params.Style := WS_CAPTION or WS_SIZEBOX or WS_SYSMENU; + Params.ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; +end; + +procedure TOfficeMoreColorsWin.CreateWnd; +begin + inherited CreateWnd; + { wp : LM_SETICON not used in LCL } + // SendMessage(Self.Handle, {$IFDEF FPC}LM_SETICON{$ELSE}WM_SETICON{$ENDIF}, 1, 0); +end; + +procedure TOfficeMoreColorsWin.ColorModelChange(Sender: TObject); +begin + case ColorModel.ItemIndex of + 0: + begin + LRed.Caption := '&Red:'; + LGreen.Caption := '&Green:'; + LBlue.Caption := '&Blue:'; + ERed.MaxValue := 255; + EGreen.MaxValue := 255; + EBlue.MaxValue := 255; + ERed.Value := GetRValue(NewSwatch.Color); + EGreen.Value := GetGValue(NewSwatch.Color); + EBlue.Value := GetBValue(NewSwatch.Color); + end; + 1: + begin + LRed.Caption := 'H&ue:'; + LGreen.Caption := '&Sat:'; + LBlue.Caption := '&Lum:'; + ERed.MaxValue := 238; + EGreen.MaxValue := 240; + EBlue.MaxValue := 240; + RGBtoHSLRange(NewSwatch.Color, h, s, l); + ERed.Value := h; + EGreen.Value := s; + EBlue.Value := l; + end; + end; +end; + +procedure TOfficeMoreColorsWin.HSLChange(Sender: TObject); +begin + if HSL.Manual then + case ColorModel.ItemIndex of + 0: + begin + ERed.Value := HSL.RValue; + EGreen.Value := HSL.GValue; + EBlue.Value := HSL.BValue; + NewSwatch.Color := HSL.SelectedColor; + end; + 1: + begin + ERed.Value := HSL.HValue; + EGreen.Value := HSL.SValue; + EBlue.Value := HSL.LValue; + NewSwatch.Color := HSL.SelectedColor; + end; + end; +end; + +procedure TOfficeMoreColorsWin.ERedChange(Sender: TObject); +begin + if (ERed.Text <> '') and + (ERed.Focused {$IFDEF DELPHI} or ERed.Button.Focused{$ENDIF}) + then + case ColorModel.ItemIndex of + 0: begin + HSL.RValue := ERed.Value; + NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value); + end; + 1: begin + HSL.HValue := ERed.Value; + NewSwatch.Color := HSLRangeToRGB(ERed.Value, EGreen.Value, EBlue.Value); + end; + end; +end; + +procedure TOfficeMoreColorsWin.EGreenChange(Sender: TObject); +begin + if (EGreen.Text <> '') and + (EGreen.Focused {$IFDEF DELPHI}or EGreen.Button.Focused{$ENDIF}) + then + case ColorModel.ItemIndex of + 0: begin + HSL.GValue := EGreen.Value; + NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value); + end; + 1: begin + HSL.SValue := EGreen.Value; + NewSwatch.Color := HSLRangeToRGB(ERed.Value, EGreen.Value, EBlue.Value); + end; + end; +end; + +procedure TOfficeMoreColorsWin.EBlueChange(Sender: TObject); +begin + if (EBlue.Text <> '') and + (EBlue.Focused {$IFDEF DELPHI} or EBlue.Button.Focused{$ENDIF}) + then + case ColorModel.ItemIndex of + 0: begin + HSL.BValue := EBlue.Value; + NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value); + end; + 1: begin + HSL.LValue := EBlue.Value; + NewSwatch.Color := HSLRangeToRGB(ERed.Value, EGreen.Value, EBlue.Value); + end; + end; +end; + +procedure TOfficeMoreColorsWin.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + case Key of + VK_RETURN: ModalResult := mrOK; + VK_ESCAPE: ModalResult := mrCancel; + end; +end; + +procedure TOfficeMoreColorsWin.HexaChange(Sender: TObject); +begin + NewSwatch.Color := Hexa.SelectedColor; +end; + +function TOfficeMoreColorsWin.GetHint(c: TColor): string; +begin + Result := Format('RGB(%u, %u, %u)'#13'Hex: %s', [GetRValue(c), GetGValue(c), GetBValue(c), ColorToHex(c)]); +end; + +procedure TOfficeMoreColorsWin.NewSwatchColorChange(Sender: TObject); +begin + NewSwatch.Hint := GetHint(NewSwatch.Color); +end; + +procedure TOfficeMoreColorsWin.OldSwatchColorChange(Sender: TObject); +begin + OldSwatch.Hint := GetHint(OldSwatch.Color); + SetAllToSel(OldSwatch.Color); +end; + +procedure TOfficeMoreColorsWin.SetAllToSel(c: TColor); +begin + case Pages.ActivePageIndex of + // Standard Page + 0: Hexa.SelectedColor := c; + // Custom Page + 1: + begin + HSL.SelectedColor := c; + case ColorModel.ItemIndex of + 0: + begin + ERed.Value := GetRValue(c); + EGreen.Value := GetGValue(c); + EBlue.Value := GetBValue(c); + end; + 1: + begin + RGBtoHSLRange(c, h, s, l); + ERed.Value := h; + EGreen.Value := s; + EBlue.Value := l; + end; + end; + end; + end; + NewSwatch.Color := c; +end; + +procedure TOfficeMoreColorsWin.PagesChange(Sender: TObject); +begin + SetAllToSel(NewSwatch.Color); +end; + +procedure TOfficeMoreColorsWin.FormResize(Sender: TObject); +begin +{$IFDEF mbXP_Lib} +grip.Left := ClientWidth - 15; +grip.Top := ClientHeight - 15; +{$ENDIF} +end; + +procedure TOfficeMoreColorsWin.FormCreate(Sender: TObject); +begin + {$IFDEF mbXP_Lib} + ERed := TmbXPSpinEdit.CreateParented(Custom.Handle); + EGreen := TmbXPSpinEdit.CreateParented(Custom.Handle); + EBlue := TmbXPSpinEdit.CreateParented(Custom.Handle); + grip := TmbXPSizeGrip.CreateParented(Self.Handle); + {$ELSE} + ERed := TSpinEdit.CreateParented(Custom.Handle); + EGreen := TSpinEdit.CreateParented(Custom.Handle); + EBlue := TSpinEdit.CreateParented(Custom.Handle); + {$ENDIF} + with ERed do + begin + Name := 'ERed'; + Width := 47; + Height := 22; + Left := 74; + Top := 198; + Anchors := [akLeft, akBottom]; + MaxValue := 255; + MinValue := 0; + Value := 0; + { to do + OnChange := ERedChange; + } + end; + with EGreen do + begin + Name := 'EGreen'; + Width := 47; + Height := 22; + Left := 74; + Top := 224; + Anchors := [akLeft, akBottom]; + MaxValue := 255; + MinValue := 0; + Value := 0; + { to do + OnChange := EGreenChange; + } + end; + with EBlue do + begin + Name := 'EBlue'; + Width := 47; + Height := 22; + Left := 74; + Top := 251; + Anchors := [akLeft, akBottom]; + MaxValue := 255; + MinValue := 0; + Value := 0; + { to do + OnChange := EBlueChange; + } + end; + Custom.InsertControl(ERed); + Custom.InsertControl(EGreen); + Custom.InsertControl(EBlue); + {$IFDEF mbXP_Lib} + with grip do + begin + Name := 'grip'; + Width := 15; + Height := 15; + Left := 308; + Top := 314; + Anchors := [akRight, akBottom]; + end; + InsertControl(grip); + {$ENDIF} +end; + +end. diff --git a/components/mbColorLib/PalUtils.pas b/components/mbColorLib/PalUtils.pas new file mode 100644 index 000000000..e6c22bc1e --- /dev/null +++ b/components/mbColorLib/PalUtils.pas @@ -0,0 +1,706 @@ +unit PalUtils; + +interface + +uses + LCLType, LCLIntf, SysUtils, Classes, Graphics, + RGBHSVUtils, RGBHSLUtils, RGBCIEUtils, RGBCMYKUtils, + HTMLColors; + +const + clCustom = $2FFFFFFF; + clTransparent = $3FFFFFFF; + +type + TSortOrder = (soAscending, soDescending); + TSortMode = (smRed, smGreen, smBlue, smHue, smSaturation, smLuminance, smValue, smNone, smCyan, smMagenta, smYellow, smBlacK, smCIEx, smCIEy, smCIEz, smCIEl, smCIEa, smCIEb); + + AcoColors = record + Colors: array of TColor; + Names: array of WideString; + HasNames: boolean; + end; + +//replaces passed strings with passed value +function ReplaceFlags(s: string; flags: array of string; value: integer): string; +//replaces the appropriate tags with values in a hint format string +function FormatHint(fmt: string; c: TColor): string; +//converts a string value to TColor including clCustom and clTransparent +function mbStringToColor(s: string): TColor; +//converts a TColor to a string value including clCustom and clTransparent +function mbColorToString(c: TColor): string; +//blends two colors together in proportion C1 : C2 = W1 : 100 - W1, where 0 <= W1 <= 100 +function Blend(C1, C2: TColor; W1: Integer): TColor; +//generates a white-color-black or a black-color-white gradient palette +function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string; +//generates a gradient palette from the given colors +function MakeGradientPalette(Colors: array of TColor): string; +//sorts colors in a string list +procedure SortPalColors(Colors: TStrings; SortMode: TSortMode; SortOrder: TSortOrder); +//reads JASC .pal file +function ReadJASCPal(PalFile: TFileName): string; +//saves a string list to a JASC .pal file +procedure SaveJASCPal(pal: TStrings; FileName: TFileName); +//reads Photoshop .aco file into an Aco record +function ReadPhotoshopAco(PalFile: TFileName): AcoColors; +//reads Photoshop .act file +function ReadPhotoshopAct(PalFile: TFileName): string; + +implementation + +function ReplaceFlags(s: string; flags: array of string; value: integer): string; +var + i, p: integer; + v: string; +begin + Result := s; + v := IntToStr(value); + for i := 0 to Length(flags) - 1 do + begin + p := Pos(flags[i], Result); + if p > 0 then + begin + Delete(Result, p, Length(flags[i])); + Insert(v, Result, p); + end; + end; +end; + +function AnsiReplaceText(const AText, AFromText, AToText: string): string; +begin + Result := StringReplace(AText, AFromText, AToText, [rfReplaceAll, rfIgnoreCase]); +end; + +function FormatHint(fmt: string; c: TColor): string; +var + h: string; +begin + h := AnsiReplaceText(fmt, '%hex', ColorToHex(c)); + h := AnsiReplaceText(h, '%cieL', IntToStr(Round(GetCIElValue(c)))); + h := AnsiReplaceText(h, '%cieA', IntToStr(Round(GetCIEaValue(c)))); + h := AnsiReplaceText(h, '%cieB', IntToStr(Round(GetCIEbValue(c)))); + h := AnsiReplaceText(h, '%cieX', IntToStr(Round(GetCIExValue(c)))); + h := AnsiReplaceText(h, '%cieY', IntToStr(Round(GetCIEyValue(c)))); + h := AnsiReplaceText(h, '%cieZ', IntToStr(Round(GetCIEzValue(c)))); + h := AnsiReplaceText(h, '%cieC', IntToStr(Round(GetCIEcValue(c)))); + h := AnsiReplaceText(h, '%cieH', IntToStr(Round(GetCIEhValue(c)))); + h := AnsiReplaceText(h, '%hslH', IntToStr(RGBHSLUtils.GetHValue(c))); + h := AnsiReplaceText(h, '%hslS', IntToStr(RGBHSLUtils.GetSValue(c))); + h := AnsiReplaceText(h, '%hslL', IntToStr(RGBHSLUtils.GetLValue(c))); + h := AnsiReplaceText(h, '%hsvH', IntToStr(RGBHSVUtils.GetHValue(c))); + h := AnsiReplaceText(h, '%hsvS', IntToStr(RGBHSVUtils.GetSValue(c))); + h := AnsiReplaceText(h, '%hsvV', IntToStr(RGBHSVUtils.GetVValue(c))); + h := AnsiReplaceText(h, '%r', IntToStr(GetRValue(c))); + h := AnsiReplaceText(h, '%g', IntToStr(GetGValue(c))); + h := AnsiReplaceText(h, '%b', IntToStr(GetBValue(c))); + h := AnsiReplaceText(h, '%c', IntToStr(GetCValue(c))); + h := AnsiReplaceText(h, '%m', IntToStr(GetMValue(c))); + h := AnsiReplaceText(h, '%y', IntToStr(GetYValue(c))); + h := AnsiReplaceText(h, '%k', IntToStr(GetKValue(c))); + h := AnsiReplaceText(h, '%h', IntToStr(RGBHSLUtils.GetHValue(c))); + h := AnsiReplaceText(h, '%s', IntToStr(RGBHSLUtils.GetSValue(c))); + h := AnsiReplaceText(h, '%l', IntToStr(RGBHSLUtils.GetLValue(c))); + h := AnsiReplaceText(h, '%v', IntToStr(RGBHSVUtils.GetVValue(c))); + Result := h; +end; + +function mbStringToColor(s: string): TColor; +begin + //remove spaces + s := AnsiReplaceText(s, ' ', ''); + if SameText(s, 'clCustom') then + Result := clCustom + else + if SameText(s, 'clTransparent') then + Result := clTransparent + else + Result := StringToColor(s); +end; + +function mbColorToString(c: TColor): string; +begin + if c = clCustom then + Result := 'clCustom' + else + if c = clTransparent then + Result := 'clTransparent' + else + Result := ColorToString(c); +end; + +//taken from TBXUtils, TBX Package © Alex Denisov (www.g32.org) +function Blend(C1, C2: TColor; W1: Integer): TColor; +var + W2, A1, A2, D, F, G: Integer; +begin + if C1 < 0 then C1 := GetSysColor(C1 and $FF); + if C2 < 0 then C2 := GetSysColor(C2 and $FF); + + if W1 >= 100 then D := 1000 + else D := 100; + + W2 := D - W1; + F := D div 2; + + A2 := C2 shr 16 * W2; + A1 := C1 shr 16 * W1; + G := (A1 + A2 + F) div D and $FF; + Result := G shl 16; + + A2 := (C2 shr 8 and $FF) * W2; + A1 := (C1 shr 8 and $FF) * W1; + G := (A1 + A2 + F) div D and $FF; + Result := Result or G shl 8; + + A2 := (C2 and $FF) * W2; + A1 := (C1 and $FF) * W1; + G := (A1 + A2 + F) div D and $FF; + Result := Result or G; +end; + +function IsMember(sl: TStrings; s: string): boolean; +var + i: integer; +begin + Result := false; + for i := 0 to sl.count -1 do + if sl.Strings[i] = s then + Result := true; +end; + +function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string; +var + i: integer; + s: TStrings; +begin + Result := ''; + s := TStringList.Create; + try + case SortOrder of + soAscending: + for i := 239 downto 0 do + s.Add(ColorToString(HSLRangeToRGB(GetHValue(BaseColor), GetSValue(BaseColor), 240 - i))); + soDescending: + for i := 0 to 239 do + s.Add(ColorToString(HSLRangeToRGB(GetHValue(BaseColor), GetSValue(BaseColor), 240 - i))); + end; + Result := s.Text; + finally + s.Free; + end; +end; + +function MakeGradientPalette(Colors: array of TColor): string; +type + RGBArray = array[0..2] of Byte; +var + i, j, k, Span: Integer; + s: TStringList; + Scolor: string; + Faktor: double; + a: RGBArray; + b: array of RGBArray; +begin + Result := ''; + Span := 300; + s := TStringList.Create; + try + SetLength(b, High(Colors) + 1); + for i := 0 to High(Colors) do + begin + Colors[i] := ColorToRGB(Colors[i]); + b[i, 0] := GetRValue(Colors[i]); + b[i, 1] := GetGValue(Colors[i]); + b[i, 2] := GetBValue(Colors[i]); + end; + for i := 0 to High(Colors) - 1 do + for j := 0 to Span do + begin + Faktor := j / Span; + for k := 0 to 3 do + a[k] := Trunc(b[i, k] + ((b[i + 1, k] - b[i, k]) * Faktor)); + Scolor := ColorToString(RGB(a[0], a[1], a[2])); + if not IsMember(s, Scolor) then + s.add(Scolor); + end; + Result := s.Text; + finally + s.Free; + end; +end; + +procedure SortPalColors(Colors: TStrings; SortMode: TSortMode; SortOrder: TSortOrder); + + function MaxPos(s: TStrings; sm: TSortMode): integer; + var + i: integer; + first: TColor; + begin + Result := 0; + first := clBlack; + for i := 0 to s.Count - 1 do + case sm of + smRed: + if GetRValue(first) < GetRValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smGreen: + if GetGValue(first) < GetGValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlue: + if GetBValue(first) < GetBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smHue: + if GetHValue(first) < GetHValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smSaturation: + if GetSValue(first) < GetSValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smLuminance: + if GetLValue(first) < GetLValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smValue: + if GetVValue(first) < GetVValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCyan: + if GetCValue(first) < GetCValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smMagenta: + if GetMValue(first) < GetMValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smYellow: + if GetYValue(first) < GetYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlacK: + if GetKValue(first) < GetKValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEx: + if GetCIEXValue(first) < GetCIEXValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEy: + if GetCIEYValue(first) < GetCIEYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEz: + if GetCIEZValue(first) < GetCIEZValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEl: + if GetCIELValue(first) < GetCIELValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEa: + if GetCIEAValue(first) < GetCIEAValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEb: + if GetCIEBValue(first) < GetCIEBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + end; + end; + + function MinPos(s: TStrings; sm: TSortMode): integer; + var + i: integer; + first: TColor; + begin + Result := 0; + first := clWhite; + for i := 0 to s.Count - 1 do + case sm of + smRed: + if GetRValue(first) > GetRValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smGreen: + if GetGValue(first) > GetGValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlue: + if GetBValue(first) > GetBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smHue: + if GetHValue(first) > GetHValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smSaturation: + if GetSValue(first) > GetSValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smLuminance: + if GetLValue(first) > GetLValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smValue: + if GetVValue(first) > GetVValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCyan: + if GetCValue(first) > GetCValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smMagenta: + if GetMValue(first) > GetMValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smYellow: + if GetYValue(first) > GetYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlacK: + if GetKValue(first) > GetKValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEx: + if GetCIEXValue(first) > GetCIEXValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEy: + if GetCIEYValue(first) > GetCIEYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEz: + if GetCIEZValue(first) > GetCIEZValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEl: + if GetCIELValue(first) > GetCIELValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEa: + if GetCIEAValue(first) > GetCIEAValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEb: + if GetCIEBValue(first) > GetCIEBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + end; + end; + +var + i, m: integer; + s: TStrings; +begin + if SortMode <> smNone then + begin + if Colors.Count = 0 then Exit; + m := 0; + s := TStringList.Create; + s.AddStrings(Colors); + Colors.Clear; + for i := s.Count - 1 downto 0 do + begin + case SortOrder of + soAscending: m := MinPos(s, SortMode); + soDescending: m := MaxPos(s, SortMode); + end; + Colors.Add(s.Strings[m]); + s.Delete(m); + end; + s.Free; + end; +end; + +function ReadJASCPal(PalFile: TFileName): string; +var + p, t, c: TStrings; + i: integer; +begin + if not FileExists(PalFile) then + begin + raise Exception.Create('File not found'); + Exit; + end; + p := TStringList.Create; + t := TStringList.Create; + c := TStringList.Create; + try + p.LoadFromFile(PalFile); + for i := 0 to p.Count - 1 do + if p.strings[i] <> '' then + begin + t.Clear; + ExtractStrings([' '], [], PChar(p.strings[i]), t); + if t.Count = 3 then + c.Add(ColorToString(RGB(StrToInt(t.strings[0]), StrToInt(t.strings[1]), StrToInt(t.strings[2])))); + end; + Result := c.Text; + finally + c.Free; + t.Free; + p.Free; + end; +end; + +procedure SaveJASCPal(pal: TStrings; FileName: TFileName); +var + i: integer; + p: TStringList; + c: TColor; +begin + if not FileExists(FileName) then + begin + raise Exception.Create('File not found'); + Exit; + end; + p := TStringList.Create; + try + p.Add('JASC-PAL'); + p.Add('0100'); + p.Add('256'); + for i := 0 to pal.Count - 1 do + if (pal.Strings[i] <> '') and not SameText(pal.Strings[i], 'clCustom') and not SameText(pal.Strings[i], 'clTransparent') then + begin + c := StringToColor(pal.Strings[i]); + p.Add(IntToStr(GetRValue(c)) + ' ' + IntToStr(GetGValue(c)) + ' ' + IntToStr(GetBValue(c))); + end; + p.SaveToFile(FileName); + finally + p.Free; + end; +end; + +procedure ExchangeBytes(var w: Word); +begin + Swap(w); +{ +asm + MOV DX,[w] //assign the word to the data register + XCHG DL,DH // exchange low and high data values + MOV [w],DX //assign the register data to the word + } +end; + +procedure ExchangeChars(var s: WideString); +var + i: Integer; + w: Word; +begin + for i := 1 to Length(s) do + begin + w := Word(s[i]); + ExchangeBytes(w); + s[i] := WideChar(w); + end; +end; + +function GetAcoColor(space,w,x,y,z: word): TColor; +begin + case space of + 0: //RGB + Result := RGB(w div 256, x div 256, y div 256); + 1: //HSB - HSV + Result := HSVToColor(Round(w/182.04), Round(x/655.35), Round(y/655.35)); + 2: //CMYK + Result := CMYKToTColor(Round(100-w/55.35), Round(100-x/655.35), Round(100-y/655.35), Round(100-z/655.35)); + 7: //Lab + Result := LabToRGB(w/100, x/100, y/100); + 8: //Grayscale + Result := RGB(Round(w/39.0625), Round(w/39.0625), Round(w/39.0625)); + 9: //Wide CMYK + Result := CMYKToTColor(w div 100, x div 100, y div 100, z div 100) + else //unknown + Result := RGB(w div 256, x div 256, y div 256); + end; +end; + +function ReadPhotoshopAco(PalFile: TFileName): AcoColors; +var + f: file; + ver, num, space, w, x, y, z, dummy: Word; + i: integer; + v0Length: byte; + v0Name: string; + v2Length: Word; + v2Name: WideString; +begin + if not FileExists(PalFile) then + begin + raise Exception.Create('File not found'); + SetLength(Result.Colors, 0); + SetLength(Result.Names, 0); + Result.HasNames := false; + Exit; + end; + AssignFile(f, PalFile); + Reset(f, 1); + //read version + BlockRead(f, ver, sizeof(ver)); + ExchangeBytes(ver); + if not (ver in [0, 1, 2]) then + begin + CloseFile(f); + Exception.Create('The file you are trying to load is not (yet) supported.'#13'Please submit the file for testing to MXS so loading of this version will be supported too'); + Exit; + end; + //read number of colors + BlockRead(f, num, sizeof(num)); + ExchangeBytes(num); + //read names + if (ver = 0) or (ver = 2) then + begin + SetLength(Result.Names, num); + Result.HasNames := true; + end + else + begin + SetLength(Result.Names, 0); + Result.HasNames := false; + end; + //read colors + SetLength(Result.Colors, num); + for i := 0 to num - 1 do + begin + BlockRead(f, space, sizeof(space)); + ExchangeBytes(space); + BlockRead(f, w, sizeof(w)); + ExchangeBytes(w); + BlockRead(f, x, sizeof(x)); + ExchangeBytes(x); + BlockRead(f, y, sizeof(y)); + ExchangeBytes(y); + BlockRead(f, z, sizeof(z)); + ExchangeBytes(z); + Result.Colors[i] := GetAcoColor(space, w, x, y, z); + case ver of + 0: + begin + BlockRead(f, v0Length, SizeOf(v0Length)); + SetLength(v0Name, v0Length); + if v0Length > 0 then + BlockRead(f, PChar(v0Name)^, v0Length); + Result.Names[i] := v0Name; + end; + 2: + begin + BlockRead(f, dummy, sizeof(dummy)); + BlockRead(f, v2Length, SizeOf(v2Length)); + ExchangeBytes(v2Length); + SetLength(v2Name, v2Length - 1); + if v2Length > 0 then + begin + BlockRead(f, PWideChar(v2Name)^, 2*(v2Length - 1)); + ExchangeChars(v2Name); + end; + Result.Names[i] := v2Name; + BlockRead(f, dummy, sizeof(dummy)); + end; + end; + end; + CloseFile(f); +end; + +function ReadPhotoshopAct(PalFile: TFileName): string; +var + f: file; + r, g, b: byte; + s: TStringList; + i: integer; +begin + if not FileExists(PalFile) then + begin + raise Exception.Create('File not found'); + Result := ''; + Exit; + end; + s := TStringList.Create; + try + AssignFile(f, PalFile); + Reset(f, 1); + for i := 0 to 255 do + begin + BlockRead(f, r, sizeof(r)); + BlockRead(f, g, sizeof(g)); + BlockRead(f, b, sizeof(b)); + s.Add(ColorToString(RGB(r, g, b))); + end; + Result := s.Text; + finally + s.Free; + end; + CloseFile(f); +end; + +end. diff --git a/components/mbColorLib/PickCursor.res b/components/mbColorLib/PickCursor.res new file mode 100644 index 000000000..41626c1ab Binary files /dev/null and b/components/mbColorLib/PickCursor.res differ diff --git a/components/mbColorLib/RAxisColorPicker.dcr b/components/mbColorLib/RAxisColorPicker.dcr new file mode 100644 index 000000000..952900521 Binary files /dev/null and b/components/mbColorLib/RAxisColorPicker.dcr differ diff --git a/components/mbColorLib/RAxisColorPicker.pas b/components/mbColorLib/RAxisColorPicker.pas new file mode 100644 index 000000000..15192d6b5 --- /dev/null +++ b/components/mbColorLib/RAxisColorPicker.pas @@ -0,0 +1,382 @@ +unit RAxisColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, Forms, + HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; + +type + TRAxisColorPicker = class(TmbColorPickerControl) + private + FSelected: TColor; + FBmp: TBitmap; + FOnChange: TNotifyEvent; + FR, FG, FB: integer; + FManual: boolean; + dx, dy, mxx, myy: integer; + + procedure SetRValue(r: integer); + procedure SetGValue(g: integer); + procedure SetBValue(b: integer); + protected + function GetSelectedColor: TColor; override; + procedure WebSafeChanged; override; + procedure SetSelectedColor(c: TColor); override; + procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + 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 DrawMarker(x, y: integer); + procedure Paint; override; + procedure CreateRGBGradient; + procedure Resize; override; + procedure CreateWnd; override; + procedure CorrectCoords(var x, y: integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property SelectedColor default clRed; + property RValue: integer read FR write SetRValue default 255; + property GValue: integer read FG write SetGValue default 0; + property BValue: integer read FB write SetBValue default 0; + property MarkerStyle default msCircle; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R RAxisColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TRAxisColorPicker]); +end; + +{TRAxisColorPicker} + +constructor TRAxisColorPicker.Create(AOwner: TComponent); +begin + inherited; + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.SetSize(256, 256); + Width := 256; + Height := 256; + HintFormat := 'G: %g B: %b'#13'Hex: %hex'; + FG := 0; + FB := 0; + FR := 255; + FSelected := clRed; + FManual := false; + dx := 0; + dy := 0; + mxx := 0; + myy := 0; + MarkerStyle := msCircle; +end; + +destructor TRAxisColorPicker.Destroy; +begin + FBmp.Free; + inherited Destroy; +end; + +procedure TRAxisColorPicker.CreateWnd; +begin + inherited; + CreateRGBGradient; +end; + +procedure TRAxisColorPicker.CreateRGBGradient; +var + g, b : integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + FBmp.Width := 256; + FBmp.Height := 256; + end; + for g := 255 downto 0 do + begin + row := FBmp.Scanline[255-g]; + for b := 0 to 255 do + if not WebSafe then + row[b] := RGBtoRGBQuad(FR, g, b) +// FBmp.Canvas.Pixels[b,255-g] := RGB(FR, g, b) + else + row[b] := RGBtoRGBQuad(GetWebSafe(RGB(FR, g, b))); +// FBmp.Canvas.Pixels[b,255-g] := GetWebSafe(RGB(FR, g, b)); + end; +end; + +procedure TRAxisColorPicker.CorrectCoords(var x, y: integer); +begin + if x < 0 then x := 0; + if y < 0 then y := 0; + if x > Width - 1 then x := Width - 1; + if y > Height - 1 then y := Height - 1; +end; + +procedure TRAxisColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + CorrectCoords(x, y); + FR := GetRValue(FSelected); + FG := GetGValue(FSelected); + FB := GetBValue(FSelected); + if Assigned(FOnChange) then + FOnChange(Self); + dx := x; + dy := y; + if Focused or (csDesigning in ComponentState) then + c := clBlack + else + c := clWhite; + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +function TRAxisColorPicker.GetSelectedColor: TColor; +begin + Result := FSelected; +end; + +procedure TRAxisColorPicker.SetSelectedColor(c: TColor); +begin + if WebSafe then c := GetWebSafe(c); + FR := GetRValue(c); + FG := GetGValue(c); + FB := GetBValue(c); + FSelected := c; + FManual := false; + myy := Round((255-FG)*(Height/255)); + mxx := Round(FB*(Width/255)); + CreateRGBGradient; + Invalidate; +end; + +procedure TRAxisColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FBmp); + CorrectCoords(mxx, myy); + DrawMarker(mxx, myy); +end; + +procedure TRAxisColorPicker.Resize; +begin + FManual := false; + myy := Round((255-FG)*(Height/255)); + mxx := Round(FB*(Width/255)); + inherited; +end; + +procedure TRAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + R: TRect; +begin + inherited; + mxx := x; + myy := y; + if Button = mbLeft then + begin + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; + SetFocus; +end; + +procedure TRAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; +end; + +procedure TRAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if ssLeft in Shift then + begin + mxx := x; + myy := y; + FSelected := GetColorAtPoint(x, y); + FManual := true; + Invalidate; + end; +end; + +procedure TRAxisColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 1; + myy := dy; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 1; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + begin + mxx := dx - 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_RIGHT: + begin + mxx := dx + 10; + myy := dy; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_UP: + begin + mxx := dx; + myy := dy - 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + VK_DOWN: + begin + mxx := dx; + myy := dy + 10; + Refresh; + FSelected := GetColorAtPoint(mxx, myy); + FManual := true; + Invalidate; + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure TRAxisColorPicker.SetRValue(r: integer); +begin + if r > 255 then r := 255; + if r < 0 then r := 0; + FR := r; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +procedure TRAxisColorPicker.SetGValue(g: integer); +begin + if g > 255 then g := 255; + if g < 0 then g := 0; + FG := g; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +procedure TRAxisColorPicker.SetBValue(b: integer); +begin + if b > 255 then b := 255; + if b < 0 then b := 0; + FB := b; + SetSelectedColor(RGB(FR, FG, FB)); +end; + +function TRAxisColorPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := Canvas.Pixels[x, y]; +end; + +procedure TRAxisColorPicker.WebSafeChanged; +begin + inherited; + CreateRGBGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/RColorPicker.dcr b/components/mbColorLib/RColorPicker.dcr new file mode 100644 index 000000000..97e11aca5 Binary files /dev/null and b/components/mbColorLib/RColorPicker.dcr differ diff --git a/components/mbColorLib/RColorPicker.pas b/components/mbColorLib/RColorPicker.pas new file mode 100644 index 000000000..7aa5bf7ff --- /dev/null +++ b/components/mbColorLib/RColorPicker.pas @@ -0,0 +1,268 @@ +unit RColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + mbTrackBarPicker, HTMLColors, Scanlines; + +type + 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 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; + 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 RColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TRColorPicker]); +end; + +{TRColorPicker} + +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; +end; + +procedure TRColorPicker.CreateRGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FBmp = nil then + begin + FBmp := TBitmap.Create; + FBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FBmp.width := 256; + FBmp.height := 12; + for i := 0 to 255 do + for j := 0 to 11 do + begin + row := FBmp.Scanline[j]; + if not WebSafe then + row[i] := RGBToRGBQuad(i, FGreen, FBlue) +// FBmp.Canvas.Pixels[i, j] := RGB(i, FGreen, FBlue) + else + row[i] := RGBToRGBQuad(GetWebSafe(RGB(i, FGreen, FBlue))); +// FBmp.Canvas.Pixels[i, j] := GetWebSafe(RGB(i, FGreen, FBlue)); + end; + end + else + begin + FBmp.width := 12; + FBmp.height := 256; + for i := 0 to 255 do + begin + row := FBmp.ScanLine[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBtoRGBQuad(255-i, FGreen, FBlue) +// FBmp.Canvas.Pixels[j, i] := RGB(255-i, FGreen, FBlue) + else + row[j] := RGBtoRGBQuad(GetWebSafe(RGB(255-i, FGreen, FBlue))); +// FBmp.Canvas.Pixels[j, i] := GetWebSafe(RGB(255-i, FGreen, FBlue)); + end; + end; +end; + +procedure TRColorPicker.SetRed(r: integer); +begin + 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); + end; +end; + +procedure TRColorPicker.SetGreen(g: integer); +begin + 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); + end; +end; + +procedure TRColorPicker.SetBlue(b: integer); +begin + 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); + end; +end; + +function TRColorPicker.ArrowPosFromRed(r: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*r); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TRColorPicker.RedFromArrowPos(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; +end; + +function TRColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := RGB(FRed, FGreen, FBlue) + else + Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); +end; + +function TRColorPicker.GetSelectedValue: integer; +begin + Result := FRed; +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); +end; + +function TRColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/RGBCIEUtils.pas b/components/mbColorLib/RGBCIEUtils.pas new file mode 100644 index 000000000..9b395c8e6 --- /dev/null +++ b/components/mbColorLib/RGBCIEUtils.pas @@ -0,0 +1,323 @@ +unit RGBCIEUtils; + +interface + +uses + SysUtils, + {$IFDEF FPC}LCLIntf,{$ELSE}Windows,{$ENDIF} + Graphics, Math; + +const + {// Observer= 2°, Illuminant= D65 - Daylignt + ref_X = 95.047; + ref_Z = 108.883; + // Observer= 10°, Illuminant= D65 - Daylight + ref_X = 94.811; + ref_Z = 35.2; + + // Observer= 2°, Illuminant= A - Incadescent + ref_X = 109.850; + ref_Z = 35.585; + // Observer= 10°, Illuminant= A - Incadescent + ref_X = 111.144; + ref_Z = 35.2; + + // Observer= 2°, Illuminant= C + ref_X = 98.074; + ref_Z = 118.232; + // Observer= 10°, Illuminant= C + ref_X = 97.285; + ref_Z = 116.145; + } + // Observer= 2°, Illuminant= D50 + ref_X = 96.422; + ref_Z = 82.521;{ + // Observer= 10°, Illuminant= D50 - Photoshop + ref_X = 96.72; + ref_Z = 81.427; } + + {// Observer= 2°, Illuminant= D55 + ref_X = 95.682; + ref_Z = 92.149; + // Observer= 10°, Illuminant= D55 + ref_X = 95.799; + ref_Z = 90.926; + + // Observer= 2°, Illuminant= D75 + ref_X = 94.972; + ref_Z = 122.638; + // Observer= 10°, Illuminant= D75 + ref_X = 94.416; + ref_Z = 12.641; + + // Observer= 2°, Illuminant= F2 - Fluorescent + ref_X = 99.187; + ref_Z = 67.395; + // Observer= 10°, Illuminant= F2 - Fluorescent + ref_X = 103.28; + ref_Z = 69.026; + + // Observer= 2°, Illuminant= F7 + ref_X = 95.044; + ref_Z = 108.755; + // Observer= 10°, Illuminant= F7 + ref_X = 95.792; + ref_Z = 107.678; + + // Observer= 2°, Illuminant= F11 + ref_X = 100.966; + ref_Z = 64.370; + // Observer= 10°, Illuminant= F11 + ref_X = 103.866; + ref_Z = 65.627; } + +type + xyz = record + x: real; + y: real; + z: real; + end; + +function LabToXYZ(l, a, b: real): xyz; +function XYZToRGB(space: xyz): TColor; +function LabToRGB(l, a, b: real): TColor; +function RGBToXYZ(c: TColor): xyz; +procedure RGBToLab(clr: TColor; var l, a, b: real); +procedure XYZToLab(space: xyz; var l, a, b: real); +procedure LCHToLab(lum, c, h: real; var l, a, b: real); +procedure LabToLCH(l, a, b: real; var lum, c, h: real); +function LCHToRGB(l, c, h: real): TColor; +procedure RGBToLCH(clr: TColor; var l, c, h: real); +function GetCIEXValue(c: TColor): real; +function GetCIEYValue(c: TColor): real; +function GetCIEZValue(c: TColor): real; +function GetCIELValue(c: TColor): real; +function GetCIEAValue(c: TColor): real; +function GetCIEBValue(c: TColor): real; +function GetCIECValue(c: TColor): real; +function GetCIEHValue(c: TColor): real; + +implementation + +function LabToXYZ(l, a, b: real): xyz; +var + x, y, z: real; +begin + y := (l + 16)/116; + x := a/500 + y; + z := y - b/200; + if y > 0.2069 then + y := IntPower(y, 3) + else + y := (y - 0.138)/7.787; + if x > 0.2069 then + x := IntPower(x, 3) + else + x := (x - 0.138)/7.787; + if z > 0.2069 then + z := IntPower(z, 3) + else + z := (z - 0.138)/7.787; + Result.x := ref_X * x; + Result.y := 100 * y; + Result.z := ref_Z * z; +end; + +function XYZToRGB(space: xyz): TColor; +var + r, g, b, x, y, z: real; +begin + x := space.x/100; + y := space.y/100; + z := space.z/100; + r := x * 3.2406 + y * (-1.5372) + z * (-0.49); + g := x * (-0.969) + y * 1.8758 + z * 0.0415; + b := x * 0.0557 + y * (-0.2040) + z * 1.0570; + if r > 0.00313 then + r := 1.055 * Power(r, 1/2.4) - 0.055 + else + r := 12.92 * r; + if g > 0.00313 then + g := 1.055 * Power(g, 1/2.4) - 0.055 + else + g := 12.92 * g; + if b > 0.00313 then + b := 1.055 * Power(b, 1/2.4) - 0.055 + else + b := 12.92 * b; + + if r < 0 then r := 0; + if r > 1 then r := 1; + if g < 0 then g := 0; + if g > 1 then g := 1; + if b < 0 then b := 0; + if b > 1 then b := 1; + Result := RGB(Round(r*255), Round(g*255), Round(b*255)); +end; + +function LabToRGB(l, a, b: real): TColor; +begin + Result := XYZToRGB(LabToXYZ(l, a, b)); +end; + +function RGBToXYZ(c: TColor): xyz; +var + r, g, b: real; +begin + r := GetRValue(c)/255; + g := GetGValue(c)/255; + b := GetBValue(c)/255; + if r > 0.04045 then + r := Power((r + 0.055)/1.055, 2.4) + else + r := r/12.92; + if g > 0.04045 then + g := Power((g + 0.055)/1.055, 2.4) + else + g := g/12.92; + if b > 0.04045 then + b := Power((b + 0.055)/1.055, 2.4) + else + b := b/12.92; + r := r * 100; + g := g * 100; + b := b * 100; + // Observer= 2°, Illuminant= D65 + Result.x := r * 0.4124 + g * 0.3576 + b * 0.1805; + Result.y := r * 0.2126 + g * 0.7152 + b * 0.0722; + Result.z := r * 0.0193 + g * 0.1192 + b * 0.9505; +end; + +procedure XYZToLab(space: xyz; var l, a, b: real); +var +x, y, z: real; +begin + x := space.x/ref_X; + y := space.y/100; + z := space.z/ref_Z; + if x > 0.008856 then + x := Power(x, 1/3) + else + x := (7.787*x) + 0.138; + if y > 0.008856 then + y := Power(y, 1/3) + else + y := (7.787*y) + 0.138; + if z > 0.008856 then + z := Power(z, 1/3) + else + z := (7.787*z) + 0.138; + l := (116*y) - 16; + a := 500 * (x - y); + b := 200 * (y - z); + if l > 100 then l := 100; + if l < 0 then l := 0; + if a < -128 then a := -128; + if a > 127 then a := 127; + if b < -128 then b := -128; + if b > 127 then b := 127; +end; + +procedure RGBToLab(clr: TColor; var l, a, b: real); +var + s: xyz; +begin + s := RGBToXYZ(clr); + XYZToLab(s, l, a, b); +end; + +procedure LCHToLab(lum, c, h: real; var l, a, b: real); +begin + l := lum; + a := cos(DegToRad(h)) * c; + b := sin(DegToRad(h)) * c; +end; + +procedure LabToLCH(l, a, b: real; var lum, c, h: real); +begin + h := ArcTan2(b, a); + if h > 0 then + h := (h/PI) * 180 + else + h := 360 - (ABS(h)/PI) * 180; + lum := l; + c := SQRT(a*a + b*b); +end; + +procedure RGBToLCH(clr: TColor; var l, c, h: real); +var + a, b: real; +begin + RGBToLab(clr, l, a, b); + LabToLCH(l, a, b, l, c, h); +end; + +function LCHToRGB(l, c, h: real): TColor; +var + lum, a, b: real; +begin + LCHToLab(l, c, h, lum, a, b); + Result := LabToRGB(lum, a, b); +end; + +function GetCIEXValue(c: TColor): real; +var + d: xyz; +begin + d := RGBToXYZ(c); + Result := d.x; +end; + +function GetCIEYValue(c: TColor): real; +var + d: xyz; +begin + d := RGBToXYZ(c); + Result := d.y; +end; + +function GetCIEZValue(c: TColor): real; +var + d: xyz; +begin + d := RGBToXYZ(c); + Result := d.z; +end; + +function GetCIELValue(c: TColor): real; +var + d: real; +begin + XYZToLab(RGBToXYZ(c), Result, d, d); +end; + +function GetCIEAValue(c: TColor): real; +var + d: real; +begin + XYZToLab(RGBToXYZ(c), d, Result, d); +end; + +function GetCIEBValue(c: TColor): real; +var + d: real; +begin + XYZToLab(RGBToXYZ(c), d, d, Result); +end; + +function GetCIECValue(c: TColor): real; +var + d: real; +begin + RGBToLCH(c, d, Result, d); +end; + +function GetCIEHValue(c: TColor): real; +var + d: real; +begin + RGBToLCH(c, d, d, Result); +end; + +end. + diff --git a/components/mbColorLib/RGBCMYKUtils.pas b/components/mbColorLib/RGBCMYKUtils.pas new file mode 100644 index 000000000..a08407593 --- /dev/null +++ b/components/mbColorLib/RGBCMYKUtils.pas @@ -0,0 +1,76 @@ +unit RGBCMYKUtils; + +interface + +uses + {$IFDEF FPC}LCLIntf,{$ELSE} Windows,{$ENDIF} + Graphics, Math; + +function CMYtoTColor(C, M, Y: integer): TColor; +procedure RGBtoCMY(clr: TColor; var C, M, Y: integer); +function CMYKToTColor (C, M, Y, K: integer): TColor; +procedure ColorToCMYK(clr: TColor; var C, M, Y, K: integer); +function GetCValue(c: TColor): integer; +function GetMValue(c: TColor): integer; +function GetYValue(c: TColor): integer; +function GetKValue(c: TColor): integer; + +implementation + +function CMYtoTColor(C, M, Y: integer): TColor; +begin + Result := RGB(255 - C, 255 - M, 255 - Y); +end; + +procedure RGBtoCMY(clr: TColor; var C, M, Y: integer); +begin + C := 255 - GetRValue(clr); + M := 255 - GetGValue(clr); + Y := 255 - GetBValue(clr); +end; + +function CMYKToTColor (C, M, Y, K: integer): TColor; +begin + Result := RGB(255 - (C + K), 255 - (M + K), 255 - (Y + K)); +end; + +procedure ColorToCMYK(clr: TColor; var C, M, Y, K: integer); +begin + C := 255 - GetRValue(clr); + M := 255 - GetGValue(clr); + Y := 255 - GetBValue(clr); + K := MinIntValue([C, M, Y]); + C := C - K; + M := M - K; + Y := Y - K; +end; + +function GetCValue(c: TColor): integer; +var + d: integer; +begin + ColorToCMYK(c, Result, d, d, d); +end; + +function GetMValue(c: TColor): integer; +var + d: integer; +begin + ColorToCMYK(c, d, Result, d, d); +end; + +function GetYValue(c: TColor): integer; +var + d: integer; +begin + ColorToCMYK(c, d, d, Result, d); +end; + +function GetKValue(c: TColor): integer; +var + d: integer; +begin + ColorToCMYK(c, d, d, d, Result); +end; + +end. diff --git a/components/mbColorLib/RGBHSLUtils.pas b/components/mbColorLib/RGBHSLUtils.pas new file mode 100644 index 000000000..f43559790 --- /dev/null +++ b/components/mbColorLib/RGBHSLUtils.pas @@ -0,0 +1,276 @@ +unit RGBHSLUtils; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, + {$ELSE} + Windows, + {$ENDIF} + Graphics, Math, Scanlines; + +var //set these variables to your needs, e.g. 360, 255, 255 + MaxHue: integer = 239; + MaxSat: integer = 240; + MaxLum: integer = 240; + +function HSLtoRGB (H, S, L: double): TColor; +function HSLRangeToRGB (H, S, L: integer): TColor; +procedure RGBtoHSLRange (RGB: TColor; var H1, S1, L1 : integer); +function GetHValue(AColor: TColor): integer; +function GetSValue(AColor: TColor): integer; +function GetLValue(AColor: TColor): integer; +procedure Clamp(var Input: integer; Min, Max: integer); +function HSLToRGBTriple(H, S, L : integer) : TRGBTriple; +function HSLToRGBQuad(H, S, L: integer): TRGBQuad; +procedure RGBTripleToHSL(RGBTriple : TRGBTriple; var h, s, l: integer); + +implementation + +function HSLtoRGB(H, S, L: double): TColor; +var + M1, M2: double; + + function HueToColorValue(Hue: double): byte; + var + V : double; + begin + if Hue < 0 then + Hue := Hue + 1 + else + if Hue > 1 then + Hue := Hue - 1; + if 6 * Hue < 1 then + V := M1 + (M2 - M1) * Hue * 6 + else + if 2 * Hue < 1 then + V := M2 + else + if 3 * Hue < 2 then + V := M1 + (M2 - M1) * (2/3 - Hue) * 6 + else + V := M1; + Result := round (255 * V) + end; + +var + R, G, B: byte; +begin + if S = 0 then + begin + R := round (MaxLum * L); + G := R; + B := R + end + else + begin + if L <= 0.5 then + M2 := L * (1 + S) + else + M2 := L + S - L * S; + M1 := 2 * L - M2; + R := HueToColorValue (H + 1/3); + G := HueToColorValue (H); + B := HueToColorValue (H - 1/3) + end; + Result := RGB (R, G, B) +end; + +function HSLRangeToRGB(H, S, L : integer): TColor; +begin + if s > MaxSat then s := MaxSat; + if s < 0 then s := 0; + if l > MaxLum then l := MaxLum; + if l < 0 then l := 0; + Result := HSLToRGB(H / MaxHue, S / MaxSat, L / MaxLum); +end; + +procedure RGBtoHSLRange(RGB: TColor; var H1, S1, L1 : integer); +var + R, G, B, D, Cmax, Cmin, h, s, l: double; +begin + H := h1; + S := s1; + L := l1; + R := GetRValue (RGB) / 255; + G := GetGValue (RGB) / 255; + B := GetBValue (RGB) / 255; + Cmax := Max (R, Max (G, B)); + Cmin := Min (R, Min (G, B)); + L := (Cmax + Cmin) / 2; + if Cmax = Cmin then + begin + H := 0; + S := 0; + end + else + begin + D := Cmax - Cmin; + //calc L + if L < 0.5 then + S := D / (Cmax + Cmin) + else + S := D / (2 - Cmax - Cmin); + //calc H + if R = Cmax then + H := (G - B) / D + else + if G = Cmax then + H := 2 + (B - R) /D + else + H := 4 + (R - G) / D; + H := H / 6; + if H < 0 then + H := H + 1; + end; + H1 := round (H * MaxHue); + S1 := round (S * MaxSat); + L1 := round (L * MaxLum); +end; + +function GetHValue(AColor: TColor): integer; +var + d, h: integer; +begin + RGBToHSLRange(AColor, h, d, d); + Result := h; +end; + +function GetSValue(AColor: TColor): integer; +var + d, s: integer; +begin + RGBToHSLRange(AColor, d, s, d); + Result := s; +end; + +function GetLValue(AColor: TColor): integer; +var + d, l: integer; +begin + RGBToHSLRange(AColor, d, d, l); + Result := l; +end; + +procedure Clamp(var Input: integer; Min, Max: integer); +begin + if (Input < Min) then Input := Min; + if (Input > Max) then Input := Max; +end; + +function HSLToRGBTriple(H, S, L: integer): TRGBTriple; +const + Divisor = 255*60; +var + 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 + 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; + end; +end; + +function HSLToRGBQuad(H, S, L: integer): TRGBQuad; +const + Divisor = 255*60; +var + 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 := RGBToRGBQuad(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 := RGBToRGBQuad(L, r, p); + 1: Result := RGBToRGBQuad(q, L, p); + 2: Result := RGBToRGBQuad(p, L, r); + 3: Result := RGBToRGBQuad(p, q, L); + 4: Result := RGBToRGBQuad(r, p, L); + 5: Result := RGBToRGBQuad(L, p, q); + else + Result := RGBToRGBQuad(0, 0, 0); + end; + end; +end; + +procedure RGBTripleToHSL(RGBTriple: TRGBTriple; var h, s, l: integer); + + function RGBMaxValue(RGB: TRGBTriple): byte; + begin + Result := RGB.rgbtRed; + if (Result < RGB.rgbtGreen) then Result := RGB.rgbtGreen; + if (Result < RGB.rgbtBlue) then Result := RGB.rgbtBlue; + end; + + function RGBMinValue(RGB: TRGBTriple) : byte; + begin + Result := RGB.rgbtRed; + if (Result > RGB.rgbtGreen) then Result := RGB.rgbtGreen; + if (Result > RGB.rgbtBlue) then Result := RGB.rgbtBlue; + end; +var + Delta, Min: byte; +begin + L := RGBMaxValue(RGBTriple); + Min := RGBMinValue(RGBTriple); + Delta := L-Min; + if (L = Min) then + begin + H := 0; + S := 0; + end + else + begin + S := MulDiv(Delta, 255, L); + with RGBTriple do + begin + if (rgbtRed = L) then + H := MulDiv(60, rgbtGreen-rgbtBlue, Delta) + else + if (rgbtGreen = L) then + H := MulDiv(60, rgbtBlue-rgbtRed, Delta) + 120 + else + if (rgbtBlue = L) then + H := MulDiv(60, rgbtRed-rgbtGreen, Delta) + 240; + if (H < 0) then H := H + 360; + end; + end; +end; + +end. diff --git a/components/mbColorLib/RGBHSVUtils.pas b/components/mbColorLib/RGBHSVUtils.pas new file mode 100644 index 000000000..a86234810 --- /dev/null +++ b/components/mbColorLib/RGBHSVUtils.pas @@ -0,0 +1,179 @@ +unit RGBHSVUtils; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, + {$ELSE} + Windows, + {$ENDIF} + SysUtils, Classes, Graphics, Math, Scanlines; + +procedure Clamp(var Input: integer; Min, Max: integer); +function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; +function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; +function RGBTripleToColor(Triple: TRGBTriple): TColor; +procedure RGBToHSV(R,G,B: integer; var H,S,V: integer); +function HSVtoRGBTriple(H, S, V: integer): TRGBTriple; +function HSVtoRGBQuad(H, S, V: integer): TRGBQuad; +function HSVtoColor(H, S, V: integer): TColor; +function GetHValue(Color: TColor): integer; +function GetVValue(Color: TColor): integer; +function GetSValue(Color: TColor): integer; + +implementation + +procedure Clamp(var Input: integer; Min, Max: integer); +begin + if Input < Min then Input := Min; + if Input > Max then Input := Max; +end; + +function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; +begin + with Result do + begin + rgbtRed := R; + rgbtGreen := G; + rgbtBlue := B; + end +end; + +function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; +begin + with Result do + begin + rgbRed := R; + rgbGreen := G; + rgbBlue := B; + rgbReserved := 0; + end +end; + +function RGBTripleToColor(Triple: TRGBTriple): TColor; +begin + Result := TColor(RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue)); +end; + +procedure RGBToHSV(R, G, B: integer; var H, S, V: integer); +var + Delta, Min, H1, S1: real; +begin + h1 := h; + s1 := s; + Min := MinIntValue([R, G, B]); + V := MaxIntValue([R, G, B]); + Delta := V - Min; + if V = 0.0 then S1 := 0 else S1 := Delta / V; + if S1 = 0.0 then + H1 := 0 + else + begin + if R = V then + H1 := 60.0 * (G - B) / Delta + else + if G = V then + H1 := 120.0 + 60.0 * (B - R) / Delta + else + if B = V then + H1 := 240.0 + 60.0 * (R - G) / Delta; + if H1 < 0.0 then H1 := H1 + 360.0; + end; + h := round(h1); + s := round(s1*255); +end; + +function HSVtoRGBTriple(H, S, V: integer): TRGBTriple; +const + divisor: integer = 255*60; +var + f, hTemp, p, q, t, VS: integer; +begin + if H > 360 then H := H - 360; + if H < 0 then H := H + 360; + if s = 0 then + Result := RGBtoRGBTriple(V, V, V) + else + begin + if H = 360 then hTemp := 0 else hTemp := H; + f := hTemp mod 60; + hTemp := hTemp div 60; + VS := V*S; + p := V - VS div 255; + q := V - (VS*f) div divisor; + t := V - (VS*(60 - f)) div divisor; + case hTemp of + 0: Result := RGBtoRGBTriple(V, t, p); + 1: Result := RGBtoRGBTriple(q, V, p); + 2: Result := RGBtoRGBTriple(p, V, t); + 3: Result := RGBtoRGBTriple(p, q, V); + 4: Result := RGBtoRGBTriple(t, p, V); + 5: Result := RGBtoRGBTriple(V, p, q); + else Result := RGBtoRGBTriple(0,0,0) + end; + end; +end; + +function HSVtoRGBQuad(H, S, V: integer): TRGBQuad; +const + divisor: integer = 255*60; +var + f, hTemp, p, q, t, VS: integer; +begin + if H > 360 then H := H - 360; + if H < 0 then H := H + 360; + if s = 0 then + Result := RGBtoRGBQuad(V, V, V) + else + begin + if H = 360 then hTemp := 0 else hTemp := H; + f := hTemp mod 60; + hTemp := hTemp div 60; + VS := V*S; + p := V - VS div 255; + q := V - (VS*f) div divisor; + t := V - (VS*(60 - f)) div divisor; + case hTemp of + 0: Result := RGBtoRGBQuad(V, t, p); + 1: Result := RGBtoRGBQuad(q, V, p); + 2: Result := RGBtoRGBQuad(p, V, t); + 3: Result := RGBtoRGBQuad(p, q, V); + 4: Result := RGBtoRGBQuad(t, p, V); + 5: Result := RGBtoRGBQuad(V, p, q); + else Result := RGBtoRGBQuad(0,0,0) + end; + end; +end; + +function HSVtoColor(H, S, V: integer): TColor; +begin + Result := RGBTripleToColor(HSVtoRGBTriple(H, S, V)); +end; + +function GetHValue(Color: TColor): integer; +var + s, v: integer; +begin + RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), Result, s, v); +end; + +function GetSValue(Color: TColor): integer; +var + h, v: integer; +begin + RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, Result, v); +end; + +function GetVValue(Color: TColor): integer; +var + h, s: integer; +begin + RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, s, Result); +end; + +end. diff --git a/components/mbColorLib/Readme.rtf b/components/mbColorLib/Readme.rtf new file mode 100644 index 000000000..8a7be24ee Binary files /dev/null and b/components/mbColorLib/Readme.rtf differ diff --git a/components/mbColorLib/SColorPicker.dcr b/components/mbColorLib/SColorPicker.dcr new file mode 100644 index 000000000..484a46d95 Binary files /dev/null and b/components/mbColorLib/SColorPicker.dcr differ diff --git a/components/mbColorLib/SColorPicker.pas b/components/mbColorLib/SColorPicker.pas new file mode 100644 index 000000000..07ddec8aa --- /dev/null +++ b/components/mbColorLib/SColorPicker.pas @@ -0,0 +1,267 @@ +unit SColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; + +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 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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R SColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TSColorPicker]); +end; + +{ TSColorPicker } + +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; +end; + +procedure TSColorPicker.CreateSGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FSBmp = nil then + begin + FSBmp := TBitmap.Create; + FSBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FSBmp.width := 255; + FSBmp.height := 12; + for i := 0 to 254 do + for j := 0 to 11 do + begin + row := FSBmp.Scanline[j]; + if not WebSafe then + row[i] := RGBToRGBQuad(HSVtoColor(FHue, i, FVal)) +// FSBmp.Canvas.Pixels[i, j] := HSVtoColor(FHue, i, FVal) + else + row[i] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, i, FVal))); +// FSBmp.Canvas.Pixels[i, j] := GetWebSafe(HSVtoColor(FHue, i, FVal)); + end; + end + else + begin + FSBmp.width := 12; + FSBmp.height := 255; + for i := 0 to 254 do + begin + row := FSBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBToRGBQuad(HSVtoColor(FHue, 255-i, FVal)) +// FSBmp.Canvas.Pixels[j, i] := HSVtoColor(FHue, 255-i, FVal) + else + row[j] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, 255-i, FVal))); +// FSBmp.Canvas.Pixels[j, i] := GetWebSafe(HSVtoColor(FHue, 255-i, FVal)); + end; + end; +end; + +procedure TSColorPicker.SetValue(v: integer); +begin + 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); + end; +end; + +procedure TSColorPicker.SetHue(h: integer); +begin + 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); + end; +end; + +procedure TSColorPicker.SetSat(s: integer); +begin + 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); + end; +end; + +function TSColorPicker.ArrowPosFromSat(s: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*s); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TSColorPicker.SatFromArrowPos(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; +end; + +function TSColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FVal) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); +end; + +function TSColorPicker.GetSelectedValue: integer; +begin + Result := FSat; +end; + +procedure TSColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function TSColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/SLColorPicker.dcr b/components/mbColorLib/SLColorPicker.dcr new file mode 100644 index 000000000..500a42a26 Binary files /dev/null and b/components/mbColorLib/SLColorPicker.dcr differ diff --git a/components/mbColorLib/SLColorPicker.pas b/components/mbColorLib/SLColorPicker.pas new file mode 100644 index 000000000..f11f86b66 --- /dev/null +++ b/components/mbColorLib/SLColorPicker.pas @@ -0,0 +1,416 @@ +unit SLColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Math, RGBHSLUtils, + Forms, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; + +type + TSLColorPicker = class(TmbColorPickerControl) + private + FManual: boolean; + FHue, FSat, FLum: integer; + FOnChange: TNotifyEvent; + FChange: boolean; + FBMP: TBitmap; + + procedure CreateSLGradient; + procedure DrawMarker(x, y: integer); + procedure SelectionChanged(x, y: integer); + procedure UpdateCoords; + procedure SetHue(h: integer); + procedure SetSat(s: integer); + procedure SetLum(l: integer); + protected + procedure WebSafeChanged; override; + function GetSelectedColor: TColor; override; + procedure SetSelectedColor(c: TColor); override; + procedure Paint; override; + procedure Resize; override; + procedure CreateWnd; override; + 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 CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); + message CN_KEYDOWN; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorAtPoint(x, y: integer): TColor; override; + property Manual: boolean read FManual; + published + property Hue: integer read FHue write SetHue default 0; + property Saturation: integer read FSat write SetSat default 0; + property Luminance: integer read FLum write SetLum default 255; + property SelectedColor default clWhite; + property MarkerStyle default msCircle; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R SLColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TSLColorPicker]); +end; + +constructor TSLColorPicker.Create(AOwner: TComponent); +begin + inherited; + FBMP := TBitmap.Create; + FBMP.PixelFormat := pf32bit; + FBMP.SetSize(256, 256); + Width := 255; + Height := 255; + MaxHue := 360; + MaxSat := 255; + MaxLum := 255; + FHue := 0; + FSat := 0; + FLum := 255; + FChange := true; + MarkerStyle := msCircle; +end; + +destructor TSLColorPicker.Destroy; +begin + FBMP.Free; + inherited; +end; + +procedure TSLColorPicker.CreateSLGradient; +var + x, y, skip: integer; + row: pRGBQuadArray; + tc: TColor; +begin + 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); + end; +end; + +procedure TSLColorPicker.Resize; +begin + inherited; + UpdateCoords; +end; + +procedure TSLColorPicker.CreateWnd; +begin + inherited; + CreateSLGradient; + UpdateCoords; +end; + +procedure TSLColorPicker.UpdateCoords; +begin + mdx := MulDiv(FSat, Width, 255); + mdy := MulDiv(255-FLum, Height, 255); +end; + +procedure TSLColorPicker.DrawMarker(x, y: integer); +var + c: TColor; +begin + c := not GetColorAtPoint(x, y); + case MarkerStyle of + msCircle: DrawSelCirc(x, y, Canvas); + msSquare: DrawSelSquare(x, y, Canvas); + msCross: DrawSelCross(x, y, Canvas, c); + msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c); + end; +end; + +procedure TSLColorPicker.Paint; +begin + Canvas.StretchDraw(ClientRect, FBMP); + DrawMarker(mdx, mdy); +end; + +procedure TSLColorPicker.SetHue(h: integer); +begin + if h > 360 then h := 360; + if h < 0 then h := 0; + if FHue <> h then + begin + FHue := h; + FManual := false; + CreateSLGradient; + UpdateCoords; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure TSLColorPicker.SetSat(s: integer); +begin + if s > 255 then s := 255; + if s < 0 then s := 0; + if FSat <> s then + begin + FSat := s; + FManual := false; + UpdateCoords; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure TSLColorPicker.SetLum(l: integer); +begin + if l > 255 then l := 255; + if l < 0 then l := 0; + if FLum <> l then + begin + FLum := l; + FManual := false; + UpdateCoords; + Invalidate; + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure TSLColorPicker.SelectionChanged(x, y: integer); +begin + FChange := false; +// SetSat(MulDiv(255, x, Width)); +// SetLum(MulDiv(255, Height - y, Height)); + SetSat(MulDiv(255, x, Width - 1)); + SetLum(MulDiv(255, Height - y -1, Height - 1)); + FChange := true; +end; + +procedure TSLColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited; + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + if csDesigning in ComponentState then Exit; + if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then + begin + mdx := x; + mdy := y; + SelectionChanged(X, Y); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure TSLColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + R: TRect; +begin + inherited; + if csDesigning in ComponentState then Exit; + if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then + begin + mdx := x; + mdy := y; + R := ClientRect; + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + {$IFDEF DELPHI} + ClipCursor(@R); + {$ENDIF} + SelectionChanged(X, Y); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + SetFocus; +end; + +procedure TSLColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + if csDesigning in ComponentState then Exit; + if (ssLeft in Shift) and PtInRect(ClientRect, Point(x, y)) then + begin + mdx := x; + mdy := y; + SelectionChanged(X, Y); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure TSLColorPicker.SetSelectedColor(c: TColor); +var + h, s, l: integer; +begin + if WebSafe then c := GetWebSafe(c); + FManual := false; + Fchange := false; + RGBTripleToHSL(RGBtoRGBTriple(GetRValue(c), GetGValue(c), GetBValue(c)), h, s, l); + SetHue(h); + SetSat(s); + SetLum(l); + if Fchange then + if Assigned(FOnChange) then FOnChange(Self); + FChange := true; +end; + +function TSLColorPicker.GetSelectedColor: TColor; +var + triple: TRGBTriple; +begin + triple := HSLToRGBTriple(FHue, FSat, FLum); + if not WebSafe then + Result := RGBTripleToTColor(triple) + else + Result := GetWebSafe(RGBTripleToTColor(triple)); +end; + +function TSLColorPicker.GetColorAtPoint(x, y: integer): TColor; +var + triple: TRGBTriple; +begin + triple := HSLToRGBTriple(FHue, MulDiv(255, x, Width), MulDiv(255, Height - y, Height)); + if not WebSafe then + Result := RGBTripleToTColor(triple) + else + Result := GetWebSafe(RGBTripleToTColor(triple)); +end; + +procedure TSLColorPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + if not (ssCtrl in Shift) then + case Message.CharCode of + VK_LEFT: + if not (mdx - 1 < 0) then + begin + Dec(mdx, 1); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_RIGHT: + if not (mdx + 1 > Width) then + begin + Inc(mdx, 1); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_UP: + if not (mdy - 1 < 0) then + begin + Dec(mdy, 1); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_DOWN: + if not (mdy + 1 > Height) then + begin + Inc(mdy, 1); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + else + begin + FInherited := true; + inherited; + end; + end + else + case Message.CharCode of + VK_LEFT: + if not (mdx - 10 < 0) then + begin + Dec(mdx, 10); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_RIGHT: + if not (mdx + 10 > Width) then + begin + Inc(mdx, 10); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_UP: + if not (mdy - 10 < 0) then + begin + Dec(mdy, 10); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_DOWN: + if not (mdy + 10 > Height) then + begin + Inc(mdy, 10); + SelectionChanged(mdx, mdy); + FManual := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +end; + +procedure TSLColorPicker.WebSafeChanged; +begin + inherited; + CreateSLGradient; + Invalidate; +end; + +end. diff --git a/components/mbColorLib/SLHColorPicker.dcr b/components/mbColorLib/SLHColorPicker.dcr new file mode 100644 index 000000000..48354ff3c Binary files /dev/null and b/components/mbColorLib/SLHColorPicker.dcr differ diff --git a/components/mbColorLib/SLHColorPicker.pas b/components/mbColorLib/SLHColorPicker.pas new file mode 100644 index 000000000..c5699c45a --- /dev/null +++ b/components/mbColorLib/SLHColorPicker.pas @@ -0,0 +1,379 @@ +unit SLHColorPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus, + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors; + +type + TSLHColorPicker = class(TCustomControl) + private + FOnChange: TNotifyEvent; + FSLPicker: TSLColorPicker; + FHPicker: THColorPicker; + FSelectedColor: TColor; + FHValue, FSValue, FLValue: integer; + FRValue, FGValue, FBValue: integer; + FSLHint, FHHint: string; + FSLMenu, FHMenu: TPopupMenu; + FSLCursor, FHCursor: TCursor; + PBack: TBitmap; + + function GetManual: boolean; + procedure SelectColor(c: TColor); + procedure SetH(v: integer); + procedure SetS(v: integer); + procedure SetL(v: integer); + procedure SetR(v: integer); + procedure SetG(v: integer); + procedure SetB(v: integer); + procedure SetHHint(h: string); + procedure SetSLHint(h: string); + procedure SetSLMenu(m: TPopupMenu); + 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 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); + procedure HPickerChange(Sender: TObject); + procedure SLPickerChange(Sender: TObject); + procedure DoChange; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetColorUnderCursor: TColor; + function GetHexColorUnderCursor: string; + function GetSelectedHexColor: string; + property ColorUnderCursor: TColor read GetColorUnderCursor; + property HValue: integer read FHValue write SetH default 0; + property SValue: integer read FSValue write SetS default 240; + property LValue: integer read FLValue write SetL default 120; + property RValue: integer read FRValue write SetR default 255; + property GValue: integer read FGValue write SetG default 0; + property BValue: integer read FBValue write SetB default 0; + property Manual: boolean read GetManual; + published + property SelectedColor: TColor read FSelectedColor write SelectColor default clRed; + property HPickerPopupMenu: TPopupMenu read FHMenu write SetHMenu; + property SLPickerPopupMenu: TPopupMenu read FSLMenu write SetSLMenu; + property HPickerHintFormat: string read FHHint write SetHHint; + property SLPickerHintFormat: string read FSLHint write SetSLHint; + property HPickerCursor: TCursor read FHCursor write SetHCursor default crDefault; + property SLPickerCursor: TCursor read FSLCursor write SetSLCursor default crDefault; + property TabStop default true; + property ShowHint; + property ParentShowHint; + property Anchors; + property Align; + property Visible; + property Enabled; + property TabOrder; + property Color; + property ParentColor default true; + {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} + property ParentBackground default true; + {$ENDIF}{$ENDIF} + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnMouseMove; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R SLHColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TSLHColorPicker]); +end; + +{TSLHColorPicker} + +constructor TSLHColorPicker.Create(AOwner: TComponent); +begin + inherited; + ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; + DoubleBuffered := true; + PBack := TBitmap.Create; + PBack.PixelFormat := pf32bit; + ParentColor := true; + {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} + 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 + 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; + end; + 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; + end; + 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; +begin + PBack.Free; + FHPicker.Free; + FSLPicker.Free; + inherited Destroy; +end; + +procedure TSLHColorPicker.HPickerChange(Sender: TObject); +begin + FSLPicker.Hue := FHPicker.Hue; + DoChange; +end; + +procedure TSLHColorPicker.SLPickerChange(Sender: TObject); +begin + FSelectedColor := FSLPicker.SelectedColor; + DoChange; +end; + +procedure TSLHColorPicker.DoChange; +begin + FHValue := FHPicker.Hue; + FSValue := FSLPicker.Saturation; + FLValue := FSLPicker.Luminance; + FRValue := GetRValue(FSLPicker.SelectedColor); + FGValue := GetGValue(FSLPicker.SelectedColor); + FBValue := GetBValue(FSLPicker.SelectedColor); + if Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure TSLHColorPicker.SelectColor(c: TColor); +begin + FSelectedColor := c; + FHPicker.Hue := GetHValue(c); + FSLPicker.SelectedColor := c; +end; + +procedure TSLHColorPicker.SetH(v: integer); +begin + FHValue := v; + FSLPicker.Hue := v; + FHPicker.Hue := v; +end; + +procedure TSLHColorPicker.SetS(v: integer); +begin + FSValue := v; + FSLPicker.Saturation := v; +end; + +procedure TSLHColorPicker.SetL(v: integer); +begin + FLValue := v; + FSLPicker.Luminance := v; +end; + +procedure TSLHColorPicker.SetR(v: integer); +begin + FRValue := v; + SelectColor(RGB(FRValue, FGValue, FBValue)); +end; + +procedure TSLHColorPicker.SetG(v: integer); +begin + FGValue := v; + SelectColor(RGB(FRValue, FGValue, FBValue)); +end; + +procedure TSLHColorPicker.SetB(v: integer); +begin + FBValue := v; + SelectColor(RGB(FRValue, FGValue, FBValue)); +end; + +function TSLHColorPicker.GetSelectedHexColor: string; +begin + Result := ColorToHex(FSelectedColor); +end; + +procedure TSLHColorPicker.SetHHint(h: string); +begin + FHHint := h; + FHPicker.HintFormat := h; +end; + +procedure TSLHColorPicker.SetSLHint(h: string); +begin + FSLHint := h; + FSLPicker.HintFormat := h; +end; + +procedure TSLHColorPicker.SetSLMenu(m: TPopupMenu); +begin + FSLMenu := m; + FSLPicker.PopupMenu := m; +end; + +procedure TSLHColorPicker.SetHMenu(m: TPopupMenu); +begin + FHMenu := m; + FHPicker.PopupMenu := m; +end; + +procedure TSLHColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +begin + if Assigned(OnMouseMove) then + OnMouseMove(Self, Shift, x, y); + inherited; +end; + +function TSLHColorPicker.GetColorUnderCursor: TColor; +begin + Result := FSLPicker.GetColorUnderCursor; +end; + +function TSLHColorPicker.GetHexColorUnderCursor: string; +begin + Result := FSLPicker.GetHexColorUnderCursor; +end; + +procedure TSLHColorPicker.SetHCursor(c: TCursor); +begin + FHCursor := c; + FHPicker.Cursor := c; +end; + +procedure TSLHColorPicker.SetSLCursor(c: TCursor); +begin + FSLCursor := c; + FSLPicker.Cursor := c; +end; + +procedure TSLHColorPicker.WMSetFocus( + var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF} ); +begin + FHPicker.SetFocus; + Message.Result := 1; +end; + +function TSLHColorPicker.GetManual:boolean; +begin + Result := FHPicker.Manual or FSLPicker.Manual; +end; + +procedure TSLHColorPicker.Resize; +begin + inherited; + PaintParentBack; +end; + +procedure TSLHColorPicker.PaintParentBack; +{$IFDEF DELPHI_7_UP} +var + MemDC: HDC; + OldBMP: HBITMAP; +{$ENDIF} +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 TSLHColorPicker.Paint; +begin + PaintParentBack; + Canvas.Draw(0, 0, PBack); +end; + +procedure TSLHColorPicker.CreateWnd; +begin + inherited; + 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 new file mode 100644 index 000000000..9a10ceb37 --- /dev/null +++ b/components/mbColorLib/Scanlines.pas @@ -0,0 +1,72 @@ +unit Scanlines; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$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; + +function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; +function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload; +function RGBToRGBQuad(c: TColor): TRGBQuad; overload; +function RGBQuadToRGB(q: TRGBQuad): TColor; +function RGBTripleToTColor(RGBTriple : TRGBTriple) : TColor; + +implementation + +function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; +begin + with Result do + begin + rgbtRed := R; + rgbtGreen := G; + rgbtBlue := B; + end +end; + +function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload; +begin + with Result do + begin + rgbRed := R; + rgbGreen := G; + rgbBlue := B; + rgbReserved := 0; + end +end; + +function RGBToRGBQuad(c: TColor): TRGBQuad; overload; +begin + with Result do + begin + 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); +end; + +function RGBTripleToTColor(RGBTriple: TRGBTriple): TColor; +begin + Result := RGBTriple.rgbtBlue shl 16 + RGBTriple.rgbtGreen shl 8 + RGBTriple.rgbtRed; +end; + +end. + diff --git a/components/mbColorLib/ScreenWin.dfm b/components/mbColorLib/ScreenWin.dfm new file mode 100644 index 000000000..680598087 --- /dev/null +++ b/components/mbColorLib/ScreenWin.dfm @@ -0,0 +1,26 @@ +object ScreenForm: TScreenForm + Left = 198 + Top = 117 + Align = alClient + BorderIcons = [] + BorderStyle = bsNone + Caption = 'Pick a color...' + ClientHeight = 96 + ClientWidth = 149 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Shell Dlg 2' + Font.Style = [] + FormStyle = fsStayOnTop + OldCreateOrder = False + Position = poDefault + OnCreate = FormCreate + OnKeyDown = FormKeyDown + OnMouseMove = FormMouseMove + OnMouseUp = FormMouseUp + OnShow = FormShow + PixelsPerInch = 96 + TextHeight = 13 +end diff --git a/components/mbColorLib/ScreenWin.lfm b/components/mbColorLib/ScreenWin.lfm new file mode 100644 index 000000000..297562a00 --- /dev/null +++ b/components/mbColorLib/ScreenWin.lfm @@ -0,0 +1,20 @@ +object ScreenForm: TScreenForm + Left = 198 + Height = 96 + Top = 117 + Width = 149 + Align = alClient + BorderIcons = [] + BorderStyle = bsNone + Caption = 'Pick a color...' + Color = clBtnFace + Font.Color = clWindowText + FormStyle = fsStayOnTop + OnCreate = FormCreate + OnKeyDown = FormKeyDown + OnMouseMove = FormMouseMove + OnMouseUp = FormMouseUp + OnShow = FormShow + Position = poDefault + LCLVersion = '1.7' +end diff --git a/components/mbColorLib/ScreenWin.pas b/components/mbColorLib/ScreenWin.pas new file mode 100644 index 000000000..5ebe6eb60 --- /dev/null +++ b/components/mbColorLib/ScreenWin.pas @@ -0,0 +1,162 @@ +unit ScreenWin; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls, StdCtrls, + PalUtils; + +const + crPickerCursor = 13; + +type + TScreenForm = class(TForm) + procedure FormShow(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure EndSelection(x, y: integer; ok: boolean); + procedure FormMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); + + private + FOnSelColorChange: TNotifyEvent; + FOnKeyDown: TKeyEvent; + + protected + procedure CreateParams(var Params:TCreateParams); override; + procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; + + public + FHintFormat: string; + SelectedColor: TColor; + property OnSelColorChange: TNotifyEvent read FOnSelColorChange write FOnSelColorChange; + property OnScreenKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown; + end; + +var + ScreenForm: TScreenForm; + +implementation + +{$IFDEF DELPHI} + {$R *.dfm} +{$ELSE} + {$R *.lfm} +{$ENDIF} + +{$R PickCursor.res} + +function ColorToHex(Color: TColor): string; +begin + Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2); +end; + +function GetDesktopColor(const X, Y: Integer): TColor; +{$IFDEF DELPHI} +var + c: TCanvas; +begin + c := TCanvas.Create; + try + c.Handle := GetWindowDC(GetDesktopWindow); + Result := GetPixel(c.Handle, X, Y); + finally + c.Free; + end; +end; +{$ELSE} +var + bmp: TBitmap; + screenDC: HDC; +begin + bmp := TBitmap.Create; + screenDC := GetDC(0); + bmp.LoadFromDevice(screenDC); + Result := bmp.Canvas.Pixels[X, Y]; + ReleaseDC(0, screenDC); + bmp.Free; +end; +{$ENDIF} + +procedure TScreenForm.CreateParams(var Params:TCreateParams); +Begin + inherited CreateParams(Params); + Params.ExStyle := WS_EX_TRANSPARENT or WS_EX_TOPMOST; +end; + +procedure TScreenForm.FormShow(Sender: TObject); +begin + Width := Screen.Width; + Height := Screen.Height; + Left := 0; + Top := 0; +end; + +procedure TScreenForm.FormCreate(Sender: TObject); +begin + Brush.Style := bsClear; + Screen.Cursors[crPickerCursor] := LoadCursor(HInstance, 'PickerCursor'); + Cursor := crPickerCursor; + SelectedColor := clNone; + FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %h'; +end; + +procedure TScreenForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if (key = VK_ESCAPE) or (ssAlt in Shift) or (ssCtrl in Shift) then + EndSelection(0, 0, false); + if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift); +end; + +procedure TScreenForm.EndSelection(x, y: integer; ok: boolean); +begin + if ok then + SelectedColor := GetDesktopColor(x, y) + else + SelectedColor := clNone; + close; + if Assigned(FOnSelColorChange) then FOnSelColorChange(Self); +end; + +procedure TScreenForm.FormMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + EndSelection(x, y, true); +end; + +procedure TScreenForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + SelectedColor := GetDesktopColor(x, y); + if Assigned(FOnSelColorChange) then FOnSelColorChange(Self); +end; + +procedure TScreenForm.CMHintShow(var Message: TCMHintShow); +begin + with TCMHintShow(Message) do + if not ShowHint then + Message.Result := 1 + else + with HintInfo^ do + begin + Result := 0; + ReshowTimeout := 1; + HideTimeout := 5000; + HintPos := Point(HintPos.X + 16, HintPos.y - 16); + HintStr := FormatHint(FHintFormat, SelectedColor); + end; + inherited; +end; + +end. diff --git a/components/mbColorLib/SelPropUtils.pas b/components/mbColorLib/SelPropUtils.pas new file mode 100644 index 000000000..8e2d00da7 --- /dev/null +++ b/components/mbColorLib/SelPropUtils.pas @@ -0,0 +1,80 @@ +unit SelPropUtils; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, + {$ELSE} + Windows, + {$ENDIF} + Classes, Graphics; + +procedure DrawSelCross(x, y: integer; Canvas: TCanvas; Color: TColor); +procedure DrawSelCrossCirc(x, y: integer; Canvas: TCanvas; Color: TColor); +procedure DrawSelCirc(x, y: integer; Canvas: TCanvas); +procedure DrawSelSquare(x, y: integer; Canvas: TCanvas); + +implementation + +procedure DrawSelCross(x, y: integer; Canvas: TCanvas; Color: TColor); +const + w = 5; + h = 3; + o = 8; +var + R: TRect; +begin + R := Rect(x-10, y-10, x+9, y+9); + Canvas.Brush.Color := Color; + Canvas.FillRect(Rect(R.Left, R.Top + o, R.Left + w, R.Top + o + h)); + Canvas.FillRect(Rect(R.Left + o, R.Top, R.Left + o + h, R.Top + w)); + Canvas.FillRect(Rect(R.Right - w, R.Top + o, R.Right, R.Top + o + h)); + Canvas.FillRect(Rect(R.Left + o, R.Bottom - w, R.Left + o + h, R.Bottom)); +end; + +procedure DrawSelCrossCirc(x, y: integer; Canvas: TCanvas; Color: TColor); +var + R: TRect; +begin + R := Rect(x - 6, y - 6, x + 6, y + 6); + ExcludeClipRect(Canvas.Handle, x - 6, y - 1, x + 6, y + 1); + ExcludeClipRect(Canvas.Handle, x - 1, y - 6, x + 1, y + 6); + Canvas.Pen.Color := Color; + Canvas.Brush.Style := bsClear; + InflateRect(R, -1, -1); + Canvas.Ellipse(R); + InflateRect(R, -1, -1); + Canvas.Ellipse(R); + Canvas.Brush.Style := bsSolid; +end; + +procedure DrawSelCirc(x, y: integer; Canvas: TCanvas); +var + R: TRect; +begin + R := Rect(x - 5, y - 5, x + 5, y + 5); + Canvas.Brush.Style := bsClear; + Canvas.Pen.Mode := pmNot; + Canvas.Ellipse(R); + Canvas.Pen.Mode := pmCopy; + Canvas.Brush.Style := bsSolid; +end; + +procedure DrawSelSquare(x, y: integer; Canvas: TCanvas); +var + R: TRect; +begin + R := Rect(x - 5, y - 5, x + 5, y + 5); + Canvas.Brush.Style := bsClear; + Canvas.Pen.Mode := pmNot; + Canvas.Rectangle(R); + Canvas.Pen.Mode := pmCopy; + Canvas.Brush.Style := bsSolid; +end; + +end. diff --git a/components/mbColorLib/VColorPicker.dcr b/components/mbColorLib/VColorPicker.dcr new file mode 100644 index 000000000..d8326a005 Binary files /dev/null and b/components/mbColorLib/VColorPicker.dcr differ diff --git a/components/mbColorLib/VColorPicker.pas b/components/mbColorLib/VColorPicker.pas new file mode 100644 index 000000000..05ae87442 --- /dev/null +++ b/components/mbColorLib/VColorPicker.pas @@ -0,0 +1,270 @@ +unit VColorPicker; + +interface + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +uses + {$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; + + 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; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R VColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + 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; +end; + +destructor TVColorPicker.Destroy; +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; +end; + +procedure TVColorPicker.SetHue(h: integer); +begin + 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); + end; +end; + +procedure TVColorPicker.SetSat(s: integer); +begin + 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); + end; +end; + +function TVColorPicker.ArrowPosFromVal(l: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*l); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +end; + +function TVColorPicker.ValFromArrowPos(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; +end; + +procedure TVColorPicker.SetValue(V: integer); +begin + 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); + end; +end; + +function TVColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := HSVtoColor(FHue, FSat, FVal) + else + Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); +end; + +function TVColorPicker.GetSelectedValue: integer; +begin + Result := FVal; +end; + +procedure TVColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function TVColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/XPLibIntegration.txt b/components/mbColorLib/XPLibIntegration.txt new file mode 100644 index 000000000..f426f2522 --- /dev/null +++ b/components/mbColorLib/XPLibIntegration.txt @@ -0,0 +1,3 @@ +mbXP Lib Integration + +If you want to use mbXP Lib for the mbColor Lib open the file mxs.inc and remove the dot (.) from {.$DEFINE mbXP_Lib}. \ No newline at end of file diff --git a/components/mbColorLib/YColorPicker.dcr b/components/mbColorLib/YColorPicker.dcr new file mode 100644 index 000000000..b7f1a7245 Binary files /dev/null and b/components/mbColorLib/YColorPicker.dcr differ diff --git a/components/mbColorLib/YColorPicker.pas b/components/mbColorLib/YColorPicker.pas new file mode 100644 index 000000000..c4179b16f --- /dev/null +++ b/components/mbColorLib/YColorPicker.pas @@ -0,0 +1,290 @@ +unit YColorPicker; + +interface + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; + +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 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; + property Cyan: integer read FCyan write SetCyan 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; + +implementation + +{$IFDEF FPC} + {$R YColorPicker.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TYColorPicker]); +end; + +{TYColorPicker} + +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; +end; + +destructor TYColorPicker.Destroy; +begin + FYBmp.Free; + inherited Destroy; +end; + +procedure TYColorPicker.CreateWnd; +begin + inherited; + CreateYGradient; +end; + +procedure TYColorPicker.CreateYGradient; +var + i,j: integer; + row: pRGBQuadArray; +begin + if FYBmp = nil then + begin + FYBmp := TBitmap.Create; + FYBmp.PixelFormat := pf32bit; + end; + if Layout = lyHorizontal then + begin + FYBmp.width := 255; + FYBmp.height := 12; + for i := 0 to 254 do + for j := 0 to 11 do + begin + row := FYBmp.Scanline[j]; + if not WebSafe then + row[i] := RGBToRGBQuad(CMYKtoTColor(FCyan, FMagenta, i, FBlack)) +// FYBmp.Canvas.Pixels[i, j] := CMYKtoTColor(FCyan, FMagenta, i, FBlack) + else + row[i] := RGBToRGBQuad(GetWebSafe(CMYKtoTColor(FCyan, FMagenta, i, FBlack))); +// FYBmp.Canvas.Pixels[i, j] := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, i, FBlack)); + end; + end + else + begin + FYBmp.width := 12; + FYBmp.height := 255; + for i := 0 to 254 do + begin + row := FYBmp.Scanline[i]; + for j := 0 to 11 do + if not WebSafe then + row[j] := RGBToRGBQuad(CMYKtoTColor(FCyan, FMagenta, 255-i, FBlack)) +// FYBmp.Canvas.Pixels[j, i] := CMYKtoTColor(FCyan, FMagenta, 255-i, FBlack) + else + row[j] := RGBToRGBQuad(GetWebSafe(CMYKtoTColor(FCyan, FMagenta, 255-i, FBlack))); +// FYBmp.Canvas.Pixels[j, i] := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, 255-i, FBlack)); + end; + end; +end; + +procedure TYColorPicker.SetYellow(y: integer); +begin + 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); + end; +end; + +procedure TYColorPicker.SetMagenta(m: integer); +begin + 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); + end; +end; + +procedure TYColorPicker.SetCyan(c: integer); +begin + 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); + end; +end; + +procedure TYColorPicker.SetBlack(k: integer); +begin + 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); + end; +end; + +function TYColorPicker.ArrowPosFromYellow(y: integer): integer; +var + a: integer; +begin + if Layout = lyHorizontal then + begin + a := Round(((Width - 12)/255)*y); + if a > Width - FLimit then a := Width - FLimit; + end + else + begin + 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; +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; +end; + +function TYColorPicker.GetSelectedColor: TColor; +begin + if not WebSafe then + Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) + else + Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); +end; + +function TYColorPicker.GetSelectedValue: integer; +begin + Result := FYellow; +end; + +procedure TYColorPicker.SetSelectedColor(c: TColor); +var + 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); +end; + +function TYColorPicker.GetArrowPos: integer; +begin + 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; +end; + +end. diff --git a/components/mbColorLib/clean.bat b/components/mbColorLib/clean.bat new file mode 100644 index 000000000..26c843101 --- /dev/null +++ b/components/mbColorLib/clean.bat @@ -0,0 +1,13 @@ +@echo off +del /S *.drc +del /S *.mes +del /S *.local +del /S *.IDENTCACHE +del /S *.dcu +del /S *.dsk +del /S *.dof +del /S *.cfg +del /S *.~* +del /S *.exe +del /S *.map +@cls \ No newline at end of file diff --git a/components/mbColorLib/clear history.bat b/components/mbColorLib/clear history.bat new file mode 100644 index 000000000..64b5e2585 --- /dev/null +++ b/components/mbColorLib/clear history.bat @@ -0,0 +1,4 @@ +@echo off +del __history\*.* +rd __history +@cls \ No newline at end of file diff --git a/components/mbColorLib/mbColorLibD10.dpk b/components/mbColorLib/mbColorLibD10.dpk new file mode 100644 index 000000000..9f7f28b1a --- /dev/null +++ b/components/mbColorLib/mbColorLibD10.dpk @@ -0,0 +1,110 @@ +package mbColorLibD10; + +{$R *.res} +{$R 'HexaColorPicker.dcr'} +{$R 'HSColorPicker.dcr'} +{$R 'HSLColorPicker.dcr'} +{$R 'LColorPicker.dcr'} +{$R 'mbColorPreview.dcr'} +{$R 'mbDeskPickerButton.dcr'} +{$R 'mbOfficeColorDialog.dcr'} +{$R 'mbColorPalette.dcr'} +{$R 'HColorPicker.dcr'} +{$R 'SColorPicker.dcr'} +{$R 'VColorPicker.dcr'} +{$R 'SLColorPicker.dcr'} +{$R 'HSVColorPicker.dcr'} +{$R 'HRingPicker.dcr'} +{$R 'HSLRingPicker.dcr'} +{$R 'SLHColorPicker.dcr'} +{$R 'YColorPicker.dcr'} +{$R 'BAxisColorPicker.dcr'} +{$R 'BColorPicker.dcr'} +{$R 'CColorPicker.dcr'} +{$R 'CIEAColorPicker.dcr'} +{$R 'CIEBColorPicker.dcr'} +{$R 'CIELColorPicker.dcr'} +{$R 'GAxisColorPicker.dcr'} +{$R 'GColorPicker.dcr'} +{$R 'KColorPicker.dcr'} +{$R 'mbColorList.dcr'} +{$R 'mbColorTree.dcr'} +{$R 'MColorPicker.dcr'} +{$R 'RAxisColorPicker.dcr'} +{$R 'RColorPicker.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'MXS -- mbColor Lib v2.0.2 (Color pickers)'} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + VclSmp, + vclx; + +contains + HexaColorPicker in 'HexaColorPicker.pas', + HSColorPicker in 'HSColorPicker.pas', + HSLColorPicker in 'HSLColorPicker.pas', + LColorPicker in 'LColorPicker.pas', + RGBHSLUtils in 'RGBHSLUtils.pas', + mbColorPreview in 'mbColorPreview.pas', + mbDeskPickerButton in 'mbDeskPickerButton.pas', + ScreenWin in 'ScreenWin.pas' {ScreenForm}, + OfficeMoreColorsDialog in 'OfficeMoreColorsDialog.pas' {OfficeMoreColorsWin}, + mbOfficeColorDialog in 'mbOfficeColorDialog.pas', + mbColorPalette in 'mbColorPalette.pas', + HTMLColors in 'HTMLColors.pas', + RGBHSVUtils in 'RGBHSVUtils.pas', + VColorPicker in 'VColorPicker.pas', + HColorPicker in 'HColorPicker.pas', + SColorPicker in 'SColorPicker.pas', + mbTrackBarPicker in 'mbTrackBarPicker.pas', + SLColorPicker in 'SLColorPicker.pas', + HRingPicker in 'HRingPicker.pas', + HSLRingPicker in 'HSLRingPicker.pas', + HSVColorPicker in 'HSVColorPicker.pas', + SLHColorPicker in 'SLHColorPicker.pas', + YColorPicker in 'YColorPicker.pas', + BAxisColorPicker in 'BAxisColorPicker.pas', + BColorPicker in 'BColorPicker.pas', + CColorPicker in 'CColorPicker.pas', + CIEAColorPicker in 'CIEAColorPicker.pas', + CIEBColorPicker in 'CIEBColorPicker.pas', + CIELColorPicker in 'CIELColorPicker.pas', + GAxisColorPicker in 'GAxisColorPicker.pas', + GColorPicker in 'GColorPicker.pas', + KColorPicker in 'KColorPicker.pas', + mbColorList in 'mbColorList.pas', + mbColorPickerControl in 'mbColorPickerControl.pas', + mbColorTree in 'mbColorTree.pas', + MColorPicker in 'MColorPicker.pas', + PalUtils in 'PalUtils.pas', + RAxisColorPicker in 'RAxisColorPicker.pas', + RColorPicker in 'RColorPicker.pas', + RGBCIEUtils in 'RGBCIEUtils.pas', + RGBCMYKUtils in 'RGBCMYKUtils.pas', + Scanlines in 'Scanlines.pas', + SelPropUtils in 'SelPropUtils.pas'; + +end. diff --git a/components/mbColorLib/mbColorLibD5.dpk b/components/mbColorLib/mbColorLibD5.dpk new file mode 100644 index 000000000..ff06f5f2e --- /dev/null +++ b/components/mbColorLib/mbColorLibD5.dpk @@ -0,0 +1,109 @@ +package mbColorLibD5; + +{$I mxs.inc} +{$R *.res} +{$R 'HexaColorPicker.dcr'} +{$R 'HSColorPicker.dcr'} +{$R 'HSLColorPicker.dcr'} +{$R 'LColorPicker.dcr'} +{$R 'mbColorPreview.dcr'} +{$R 'mbDeskPickerButton.dcr'} +{$R 'mbOfficeColorDialog.dcr'} +{$R 'mbColorPalette.dcr'} +{$R 'HColorPicker.dcr'} +{$R 'SColorPicker.dcr'} +{$R 'VColorPicker.dcr'} +{$R 'SLColorPicker.dcr'} +{$R 'HSVColorPicker.dcr'} +{$R 'HRingPicker.dcr'} +{$R 'HSLRingPicker.dcr'} +{$R 'SLHColorPicker.dcr'} +{$R 'MColorPicker.dcr'} +{$R 'YColorPicker.dcr'} +{$R 'CColorPicker.dcr'} +{$R 'KColorPicker.dcr'} +{$R 'BAxisColorPicker.dcr'} +{$R 'CIEAColorPicker.dcr'} +{$R 'CIEBColorPicker.dcr'} +{$R 'CIELColorPicker.dcr'} +{$R 'GAxisColorPicker.dcr'} +{$R 'RAxisColorPicker.dcr'} +{$R 'BColorPicker.dcr'} +{$R 'GColorPicker.dcr'} +{$R 'RColorPicker.dcr'} +{$R 'mbColorTree.dcr'} +{$R 'mbColorList.dcr'} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'MXS -- mbColor Lib v2.0.1 (Color pickers)'} +{$IMPLICITBUILD OFF} + +requires + vcl50, + VclSmp50{$IFDEF mbXP_Lib}, + mbXPLibD5{$ENDIF}; + +contains + HexaColorPicker in 'HexaColorPicker.pas', + HSColorPicker in 'HSColorPicker.pas', + HSLColorPicker in 'HSLColorPicker.pas', + LColorPicker in 'LColorPicker.pas', + RGBHSLUtils in 'RGBHSLUtils.pas', + mbColorPreview in 'mbColorPreview.pas', + mbDeskPickerButton in 'mbDeskPickerButton.pas', + ScreenWin in 'ScreenWin.pas' {ScreenForm}, + OfficeMoreColorsDialog in 'OfficeMoreColorsDialog.pas' {OfficeMoreColorsWin}, + mbOfficeColorDialog in 'mbOfficeColorDialog.pas', + mbColorPalette in 'mbColorPalette.pas', + HTMLColors in 'HTMLColors.pas', + RGBHSVUtils in 'RGBHSVUtils.pas', + VColorPicker in 'VColorPicker.pas', + HColorPicker in 'HColorPicker.pas', + SColorPicker in 'SColorPicker.pas', + mbTrackBarPicker in 'mbTrackBarPicker.pas', + SLColorPicker in 'SLColorPicker.pas', + HRingPicker in 'HRingPicker.pas', + HSLRingPicker in 'HSLRingPicker.pas', + HSVColorPicker in 'HSVColorPicker.pas', + SLHColorPicker in 'SLHColorPicker.pas', + PalUtils in 'PalUtils.pas', + RGBCMYKUtils in 'RGBCMYKUtils.pas', + SelPropUtils in 'SelPropUtils.pas', + mbColorPickerControl in 'mbColorPickerControl.pas', + RGBCIEUtils in 'RGBCIEUtils.pas', + CColorPicker in 'CColorPicker.pas', + MColorPicker in 'MColorPicker.pas', + YColorPicker in 'YColorPicker.pas', + KColorPicker in 'KColorPicker.pas', + mbColorTree in 'mbColorTree.pas', + RAxisColorPicker in 'RAxisColorPicker.pas', + GAxisColorPicker in 'GAxisColorPicker.pas', + BAxisColorPicker in 'BAxisColorPicker.pas', + RColorPicker in 'RColorPicker.pas', + CIELColorPicker in 'CIELColorPicker.pas', + CIEAColorPicker in 'CIEAColorPicker.pas', + CIEBColorPicker in 'CIEBColorPicker.pas', + GColorPicker in 'GColorPicker.pas', + BColorPicker in 'BColorPicker.pas', + Scanlines in 'Scanlines.pas', + mbColorList in 'mbColorList.pas'; + +end. diff --git a/components/mbColorLib/mbColorLibD7.dpk b/components/mbColorLib/mbColorLibD7.dpk new file mode 100644 index 000000000..d70cad922 --- /dev/null +++ b/components/mbColorLib/mbColorLibD7.dpk @@ -0,0 +1,110 @@ +package mbColorLibD7; + +{$I mxs.inc} +{$R *.res} +{$R 'HexaColorPicker.dcr'} +{$R 'HSColorPicker.dcr'} +{$R 'HSLColorPicker.dcr'} +{$R 'LColorPicker.dcr'} +{$R 'mbColorPreview.dcr'} +{$R 'mbDeskPickerButton.dcr'} +{$R 'mbOfficeColorDialog.dcr'} +{$R 'mbColorPalette.dcr'} +{$R 'HColorPicker.dcr'} +{$R 'SColorPicker.dcr'} +{$R 'VColorPicker.dcr'} +{$R 'SLColorPicker.dcr'} +{$R 'HSVColorPicker.dcr'} +{$R 'HRingPicker.dcr'} +{$R 'HSLRingPicker.dcr'} +{$R 'SLHColorPicker.dcr'} +{$R 'MColorPicker.dcr'} +{$R 'YColorPicker.dcr'} +{$R 'CColorPicker.dcr'} +{$R 'KColorPicker.dcr'} +{$R 'BAxisColorPicker.dcr'} +{$R 'CIEAColorPicker.dcr'} +{$R 'CIEBColorPicker.dcr'} +{$R 'CIELColorPicker.dcr'} +{$R 'GAxisColorPicker.dcr'} +{$R 'RAxisColorPicker.dcr'} +{$R 'BColorPicker.dcr'} +{$R 'GColorPicker.dcr'} +{$R 'RColorPicker.dcr'} +{$R 'mbColorTree.dcr'} +{$R 'mbColorList.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'MXS -- mbColor Lib v2.0.1 (Color pickers)'} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl{$IFDEF mbXP_Lib}, + mbXPLibD7{$ENDIF}; + +contains + HexaColorPicker in 'HexaColorPicker.pas', + HSColorPicker in 'HSColorPicker.pas', + HSLColorPicker in 'HSLColorPicker.pas', + LColorPicker in 'LColorPicker.pas', + RGBHSLUtils in 'RGBHSLUtils.pas', + mbColorPreview in 'mbColorPreview.pas', + mbDeskPickerButton in 'mbDeskPickerButton.pas', + ScreenWin in 'ScreenWin.pas' {ScreenForm}, + OfficeMoreColorsDialog in 'OfficeMoreColorsDialog.pas' {OfficeMoreColorsWin}, + mbOfficeColorDialog in 'mbOfficeColorDialog.pas', + mbColorPalette in 'mbColorPalette.pas', + HTMLColors in 'HTMLColors.pas', + RGBHSVUtils in 'RGBHSVUtils.pas', + VColorPicker in 'VColorPicker.pas', + HColorPicker in 'HColorPicker.pas', + SColorPicker in 'SColorPicker.pas', + mbTrackBarPicker in 'mbTrackBarPicker.pas', + SLColorPicker in 'SLColorPicker.pas', + HRingPicker in 'HRingPicker.pas', + HSLRingPicker in 'HSLRingPicker.pas', + HSVColorPicker in 'HSVColorPicker.pas', + SLHColorPicker in 'SLHColorPicker.pas', + PalUtils in 'PalUtils.pas', + RGBCMYKUtils in 'RGBCMYKUtils.pas', + SelPropUtils in 'SelPropUtils.pas', + mbColorPickerControl in 'mbColorPickerControl.pas', + RGBCIEUtils in 'RGBCIEUtils.pas', + CColorPicker in 'CColorPicker.pas', + MColorPicker in 'MColorPicker.pas', + YColorPicker in 'YColorPicker.pas', + KColorPicker in 'KColorPicker.pas', + mbColorTree in 'mbColorTree.pas', + RAxisColorPicker in 'RAxisColorPicker.pas', + GAxisColorPicker in 'GAxisColorPicker.pas', + BAxisColorPicker in 'BAxisColorPicker.pas', + RColorPicker in 'RColorPicker.pas', + CIELColorPicker in 'CIELColorPicker.pas', + CIEAColorPicker in 'CIEAColorPicker.pas', + CIEBColorPicker in 'CIEBColorPicker.pas', + GColorPicker in 'GColorPicker.pas', + BColorPicker in 'BColorPicker.pas', + Scanlines in 'Scanlines.pas', + mbColorList in 'mbColorList.pas'; + +end. diff --git a/components/mbColorLib/mbColorLibD9.dpk b/components/mbColorLib/mbColorLibD9.dpk new file mode 100644 index 000000000..f38c9862f --- /dev/null +++ b/components/mbColorLib/mbColorLibD9.dpk @@ -0,0 +1,111 @@ +package mbColorLibD9; + +{$R *.res} +{$R 'HexaColorPicker.dcr'} +{$R 'HSColorPicker.dcr'} +{$R 'HSLColorPicker.dcr'} +{$R 'LColorPicker.dcr'} +{$R 'mbColorPreview.dcr'} +{$R 'mbDeskPickerButton.dcr'} +{$R 'mbOfficeColorDialog.dcr'} +{$R 'mbColorPalette.dcr'} +{$R 'HColorPicker.dcr'} +{$R 'SColorPicker.dcr'} +{$R 'VColorPicker.dcr'} +{$R 'SLColorPicker.dcr'} +{$R 'HSVColorPicker.dcr'} +{$R 'HRingPicker.dcr'} +{$R 'HSLRingPicker.dcr'} +{$R 'SLHColorPicker.dcr'} +{$R 'YColorPicker.dcr'} +{$R 'BAxisColorPicker.dcr'} +{$R 'BColorPicker.dcr'} +{$R 'CColorPicker.dcr'} +{$R 'CIEAColorPicker.dcr'} +{$R 'CIEBColorPicker.dcr'} +{$R 'CIELColorPicker.dcr'} +{$R 'GAxisColorPicker.dcr'} +{$R 'GColorPicker.dcr'} +{$R 'KColorPicker.dcr'} +{$R 'mbColorList.dcr'} +{$R 'mbColorTree.dcr'} +{$R 'MColorPicker.dcr'} +{$R 'RAxisColorPicker.dcr'} +{$R 'RColorPicker.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'MXS -- mbColor Lib v2.0.1 (Color pickers)'} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + VclSmp, + vclx{$IFDEF mbXP_Lib}, + mbXPLibD9{$ENDIF}; + +contains + HexaColorPicker in 'HexaColorPicker.pas', + HSColorPicker in 'HSColorPicker.pas', + HSLColorPicker in 'HSLColorPicker.pas', + LColorPicker in 'LColorPicker.pas', + RGBHSLUtils in 'RGBHSLUtils.pas', + mbColorPreview in 'mbColorPreview.pas', + mbDeskPickerButton in 'mbDeskPickerButton.pas', + ScreenWin in 'ScreenWin.pas' {ScreenForm}, + OfficeMoreColorsDialog in 'OfficeMoreColorsDialog.pas' {OfficeMoreColorsWin}, + mbOfficeColorDialog in 'mbOfficeColorDialog.pas', + mbColorPalette in 'mbColorPalette.pas', + HTMLColors in 'HTMLColors.pas', + RGBHSVUtils in 'RGBHSVUtils.pas', + VColorPicker in 'VColorPicker.pas', + HColorPicker in 'HColorPicker.pas', + SColorPicker in 'SColorPicker.pas', + mbTrackBarPicker in 'mbTrackBarPicker.pas', + SLColorPicker in 'SLColorPicker.pas', + HRingPicker in 'HRingPicker.pas', + HSLRingPicker in 'HSLRingPicker.pas', + HSVColorPicker in 'HSVColorPicker.pas', + SLHColorPicker in 'SLHColorPicker.pas', + YColorPicker in 'YColorPicker.pas', + BAxisColorPicker in 'BAxisColorPicker.pas', + BColorPicker in 'BColorPicker.pas', + CColorPicker in 'CColorPicker.pas', + CIEAColorPicker in 'CIEAColorPicker.pas', + CIEBColorPicker in 'CIEBColorPicker.pas', + CIELColorPicker in 'CIELColorPicker.pas', + GAxisColorPicker in 'GAxisColorPicker.pas', + GColorPicker in 'GColorPicker.pas', + KColorPicker in 'KColorPicker.pas', + mbColorList in 'mbColorList.pas', + mbColorPickerControl in 'mbColorPickerControl.pas', + mbColorTree in 'mbColorTree.pas', + MColorPicker in 'MColorPicker.pas', + PalUtils in 'PalUtils.pas', + RAxisColorPicker in 'RAxisColorPicker.pas', + RColorPicker in 'RColorPicker.pas', + RGBCIEUtils in 'RGBCIEUtils.pas', + RGBCMYKUtils in 'RGBCMYKUtils.pas', + Scanlines in 'Scanlines.pas', + SelPropUtils in 'SelPropUtils.pas'; + +end. diff --git a/components/mbColorLib/mbColorList.dcr b/components/mbColorLib/mbColorList.dcr new file mode 100644 index 000000000..1976a7541 Binary files /dev/null and b/components/mbColorLib/mbColorList.dcr differ diff --git a/components/mbColorLib/mbColorList.pas b/components/mbColorLib/mbColorList.pas new file mode 100644 index 000000000..099dbbc9d --- /dev/null +++ b/components/mbColorLib/mbColorList.pas @@ -0,0 +1,447 @@ +unit mbColorList; + +interface + +{$I mxs.inc} +{$IFDEF FPC}{$MODE DELPHI}{$ENDIF} + +uses + SysUtils, + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + Classes, Controls, StdCtrls, Graphics, + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} {$IFDEF DELPHI_6_UP}GraphUtil,{$ENDIF} + HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, Forms, + PalUtils; + +type + {$IFNDEF DELPHI_6_UP} + TScrollDirection = (sdLeft, sdRight, sdUp, sdDown); + {$ENDIF} + + TmbColor = record + name: string; + value: TColor; + end; + + TDrawCaptionEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string; Selected: boolean) of object; + TGetHintEvent = procedure (AIndex: integer; var AHint: string; var Handled: boolean) of object; + + TmbColorList = class(TCustomListBox) + private + FDraw: TDrawCaptionEvent; + mx, my: integer; + FGetHint: TGetHintEvent; + protected + procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; + public + Colors: array of TmbColor; + + constructor Create(AOwner: TComponent); override; + + procedure UpdateColors; + procedure AddColor(Name: string; Value: TColor; refresh: boolean = true); + procedure ClearColors; + procedure DeleteColor(Index: integer; refresh: boolean = true); + procedure DeleteColorByName(Name: string; All: boolean); + procedure DeleteColorByValue(Value: TColor; All: boolean); + procedure InsertColor(Index: integer; Name: string; Value: TColor); + function ColorCount: integer; + published + {$IFDEF DELPHI} + property BevelKind default bkNone; + property BevelEdges; + property BevelInner; + property BevelOuter; + property Ctl3D; + property ImeMode; + property ImeName; + property ParentCtl3D; + property TabWidth; + {$ENDIF} + property ParentColor default False; + property TabStop default True; + {$IFDEF DELPHI_7_UP} + {$IFDEF DELPHI} + property AutoComplete; + {$ENDIF} + property ScrollWidth; + {$ENDIF} + property Align; + property Anchors; + property BiDiMode; + property BorderStyle; + property Color; + property Columns; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ExtendedSelect; + property Font; + property IntegralHeight default true; + property ItemHeight default 48; + //property Items; // wp: removed + property MultiSelect; + property ParentBiDiMode; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property Sorted; + property TabOrder; + property Visible; + + property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw; + property OnGetHint: TGetHintEvent read FGetHint write FGetHint; + property OnContextPopup; + {$IFDEF DELPHI_7_UP} + {$IFDEF DELPHI} + property OnData; + property OnDataFind; + property OnDataObject; + {$ENDIF} + {$ENDIF} + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R mbColorList.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TmbColorList]); +end; + +//taken from GraphUtil, only for Delphi 5 +{$IFNDEF DELPHI_6_UP} + +procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection; + Location: TPoint; Size: Integer); +const + ArrowPts: array[TScrollDirection, 0..2] of TPoint = + (((X:1; Y:0), (X:0; Y:1), (X:1; Y:2)), + ((X:0; Y:0), (X:1; Y:1), (X:0; Y:2)), + ((X:0; Y:1), (X:1; Y:0), (X:2; Y:1)), + ((X:0; Y:0), (X:1; Y:1), (X:2; Y:0))); +var + I: Integer; + Pts: array[0..2] of TPoint; + OldWidth: Integer; + OldColor: TColor; +begin + if ACanvas = nil then exit; + OldColor := ACanvas.Brush.Color; + ACanvas.Brush.Color := ACanvas.Pen.Color; + Move(ArrowPts[Direction], Pts, SizeOf(Pts)); + for I := 0 to 2 do + Pts[I] := Point(Pts[I].x * Size + Location.X, Pts[I].y * Size + Location.Y); + with ACanvas do + begin + OldWidth := Pen.Width; + Pen.Width := 1; + Polygon(Pts); + Pen.Width := OldWidth; + Brush.Color := OldColor; + end; +end; + +{$ENDIF} + +constructor TmbColorList.Create(AOwner: TComponent); +begin + inherited; + MaxHue := 360; + MaxSat := 255; + MaxLum := 255; + style := lbOwnerDrawFixed; + SetLength(Colors, 0); + ItemHeight := 48; + IntegralHeight := true; + mx := -1; + my := -1; +end; + +procedure TmbColorList.UpdateColors; +var + i: integer; +begin + Items.Clear; + for i := 0 to Length(Colors) - 1 do + Items.Add(Colors[i].name); +end; + +procedure TmbColorList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); +var + SR, TR, R: TRect; + itemText: string; +begin + if Length(Colors) = 0 then Exit; + R := Rect; + with Canvas do + begin + //background + Pen.Color := clWindow; + if odSelected in State then + Brush.Color := clHighlight + else + Brush.Color := self.Color; //clBtnFace; + FillRect(R); + MoveTo(R.Left, R.Bottom - 1); + LineTo(R.Right, R.Bottom - 1); + //swatches + SR := Classes.Rect(R.Left + 6, R.Top + 6, R.Left + ItemHeight - 6, R.Top + ItemHeight - 6); + Brush.Color := Self.Colors[Index].value; + if odSelected in State then + begin + {$IFDEF DELPHI_7_UP} + if ThemeServices.ThemesEnabled then + begin + ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); + InflateRect(SR, -2, -2); + Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Blend(self.Colors[Index].value, clBlack, 90); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Self.Colors[Index].value; + FillRect(SR); + end + else + //windows 9x + begin + {$ENDIF} + Pen.Color := clBackground; + Brush.Color := clWindow; + Rectangle(SR); + InflateRect(SR, -1, -1); + FillRect(SR); + InflateRect(SR, 1, 1); + InflateRect(SR, -2, -2); + Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Self.Colors[Index].value; + FillRect(SR); + {$IFDEF DELPHI_7_UP} + end; + {$ENDIF} + end + else + //not selected + begin + //windows XP + {$IFDEF DELPHI_7_UP} + if ThemeServices.ThemesEnabled then + begin + ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); + InflateRect(SR, -2, -2); + Brush.Color := Self.Colors[Index].value; + FillRect(SR); + end + else + //windows 9x + begin + {$ENDIF} + DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT); + InflateRect(SR, -2, -2); + Brush.Color := Self.Colors[Index].value; + Pen.Color := clBlack; + Rectangle(SR); + InflateRect(SR, -1, -1); + FillRect(SR); + InflateRect(SR, 1, 1); + {$IFDEF DELPHI_7_UP} + end; + {$ENDIF} + end; + //names + Font.Style := [fsBold]; + if odSelected in State then + begin + Brush.Color := clHighlight; + Pen.Color := clHighlightText; + Font.Color := clHighlightText; + end + else + begin + Brush.Color := clBtnFace; + Pen.Color := clWindowText; + Font.Color := clWindowText; + end; + itemText := Items.Strings[Index]; + Canvas.Brush.Style := bsClear; + TR := Classes.Rect(R.Left + ItemHeight, R.Top + (ItemHeight - TextHeight(itemText)) div 2, R.Right, R.Bottom - (ItemHeight - TextHeight(itemText)) div 2); + if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, odSelected in State); + DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS); + end; +end; + +procedure TmbColorList.AddColor(Name: string; Value: TColor; refresh: boolean = true); +var + l: integer; +begin + l := Length(Colors); + SetLength(Colors, l + 1); + Colors[l].name := Name; + Colors[l].value := Value; + if refresh then + UpdateColors; +end; + +procedure TmbColorList.ClearColors; +begin + SetLength(Colors, 0); + UpdateColors; +end; + +function TmbColorList.ColorCount: integer; +begin + Result := Length(Colors); +end; + +procedure TmbColorList.DeleteColor(Index: integer; refresh: boolean = true); +var + i: integer; +begin + if Length(Colors) = 0 then + begin + raise Exception.Create('There''s nothing to delete! The length of the array is 0.'); + Exit; + end; + + if Index > Length(Colors) - 1 then + begin + raise Exception.Create(Format('List index out of bounds (%d)', [Index])); + Exit; + end; + + for i := Index to Length(Colors) - 2 do + Colors[i] := Colors[i+1]; + SetLength(Colors, Length(Colors) - 1); + if refresh then + UpdateColors; +end; + +procedure TmbColorList.DeleteColorByName(Name: string; All: boolean); +var + i: integer; +begin + for i := Length(Colors) - 1 downto 0 do + if SameText(Colors[i].name, Name) then + begin + DeleteColor(i, false); + if not All then + begin + UpdateColors; + Exit; + end; + end; + UpdateColors; +end; + +procedure TmbColorList.DeleteColorByValue(Value: TColor; All: boolean); +var + i: integer; +begin + for i := Length(Colors) - 1 downto 0 do + if Colors[i].Value = Value then + begin + DeleteColor(i, false); + if not All then + begin + UpdateColors; + Exit; + end; + end; + UpdateColors; +end; + +procedure TmbColorList.InsertColor(Index: integer; Name: string; Value: TColor); +var + i: integer; +begin + if Index > Length(Colors) - 1 then + begin + raise Exception.Create(Format('List index out of bounds (%d)', [Index])); + Exit; + end; + + SetLength(Colors, Length(Colors) + 1); + for i := Length(Colors) - 1 downto Index do + Colors[i] := Colors[i-1]; + + Colors[Index].Name := Name; + Colors[Index].Value := Value; + + UpdateColors; +end; + +procedure TmbColorList.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + mx := x; + my := y; +end; + +procedure TmbColorList.CMHintShow(var Message: TCMHintShow); +var + Handled: boolean; + i: integer; +begin +if PtInRect(ClientRect, Point(mx, my)) and ShowHint then + begin + i := ItemAtPos(Point(mx, my), true); + if i > -1 then + with TCMHintShow(Message) do + if not ShowHint then + Message.Result := 1 + else + with HintInfo^ do + begin + Result := 0; + ReshowTimeout := 2000; + HideTimeout := 1000; + Handled := false; + if Assigned(FGetHint) then FGetHint(i, HintStr, Handled); + if Handled then + HintStr := FormatHint(HintStr, Colors[i].Value) + else + HintStr := Colors[i].Name; + end; + end; + inherited; +end; + +end. diff --git a/components/mbColorLib/mbColorPalette.dcr b/components/mbColorLib/mbColorPalette.dcr new file mode 100644 index 000000000..11bd408b7 Binary files /dev/null and b/components/mbColorLib/mbColorPalette.dcr differ diff --git a/components/mbColorLib/mbColorPalette.pas b/components/mbColorLib/mbColorPalette.pas new file mode 100644 index 000000000..53aa6dada --- /dev/null +++ b/components/mbColorLib/mbColorPalette.pas @@ -0,0 +1,1190 @@ +unit mbColorPalette; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} + Forms, HTMLColors, PalUtils, Dialogs; + +type + TMouseLoc = (mlNone, mlOver, mlDown); + TTransparentStyle = (tsPhotoshop, tsPhotoshop2, tsCorel, tsMicroangelo, tsNone); + TCellStyle = (csDefault, csCorel); + TColorCellState = (ccsNone, ccsOver, ccsDown, ccsChecked, ccsCheckedHover); + TMoveDirection = (mdLeft, mdRight, mdUp, mdDown); + TPaintCellEvent = procedure (ACanvas: TCanvas; ACellRect: TRect; AColor: TColor; Index: integer; AState: TColorCellState; var AStyle: TTransparentStyle; var PaintingHandled: boolean) of object; + TCellClickEvent = procedure (Button: TMouseButton; Shift: TShiftState; Index: integer; AColor: TColor; var DontCheck: boolean) of object; + 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) + private + FMouseLoc: TMouseLoc; + FMouseOver, FMouseDown, FAutoHeight: boolean; + FColCount, FRowCount, FTop, FLeft, FIndex, FCheckedIndex, FCellSize, FTotalCells: integer; + FTempBmp, PBack: TBitmap; + FState: TColorCellState; + FColors, FNames: TStrings; + FPalette: TFileName; + FHintFormat: string; + FOnChange, FOnColorsChange: TNotifyEvent; + FMinColors, FMaxColors: integer; + FSort: TSortMode; + FOrder: TSortOrder; + FOld: TColor; + FOnPaintCell: TPaintCellEvent; + FTStyle: TTransparentStyle; + FOnCellClick: TCellClickEvent; + FOldIndex: integer; + FOnGetHintText: TGetHintTextEvent; + FCellStyle: TCellStyle; + FOnArrowKey: TArrowKeyEvent; + + function GetMoveCellIndex(move: TMoveDirection): integer; + function GetSelColor: TColor; + procedure SetCellStyle(s: TCellStyle); + procedure SetTStyle(s: TTransparentStyle); + procedure SetCellSize(s: integer); + procedure SetSortMode(s: TSortMode); + procedure SetSortOrder(s: TSortOrder); + procedure SetMinColors(m: integer); + procedure SetMaxColors(m: integer); + procedure SetAutoHeight(auto: boolean); + procedure LoadPalette(FileName: TFileName); + procedure SetStrings(s: TStrings); + procedure SetNames(n: TStrings); + procedure SetSelColor(k: TColor); + procedure SortColors; + procedure CalcAutoHeight; + function GetTotalRowCount: integer; + protected + procedure Paint; override; + procedure PaintTransparentGlyph(ACanvas: TCanvas; R: TRect); + procedure DrawCell(clr: string); + procedure DrawCellBack(ACanvas: TCanvas; R: TRect; AIndex: integer); + procedure ColorsChange(Sender: TObject); + 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; + procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER; + procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT; + 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; + procedure CMGotFocus(var Message: TLMessage); message CM_ENTER; + procedure CMLostFocus(var Message: TLMessage); message CM_EXIT; + 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; + function GetColorUnderCursor: TColor; + function GetSelectedCellRect: TRect; + function GetIndexUnderCursor: integer; + + property ColorUnderCursor: TColor read GetColorUnderCursor; + property VisibleRowCount: integer read FRowCount; + property RowCount: integer read GetTotalRowCount; + property ColCount: integer read FColCount; + property IndexUnderCursor: integer read GetIndexUnderCursor; + procedure SaveColorsAsPalette(FileName: TFileName); + procedure GeneratePalette(BaseColor: TColor); + procedure GenerateGradientPalette(Colors: array of TColor); + published + property Align; + property Anchors; + property Enabled; + property SortMode: TSortMode read FSort write SetSortMode default smNone; + property SortOrder: TSortOrder read FOrder write SetSortOrder default soAscending; + property MinColors: integer read FMinColors write SetMinColors default 0; + property MaxColors: integer read FMaxColors write SetMaxColors default 0; + property SelectedCell: integer read FCheckedIndex write SelectCell default -1; + property SelectedColor: TColor read GetSelColor write SetSelColor default clNone; + property Colors: TStrings read FColors write SetStrings; + property Palette: TFileName read FPalette write LoadPalette; + property HintFormat: string read FHintFormat write FHintFormat; + property AutoHeight: boolean read FAutoHeight write SetAutoHeight default false; + property CellSize: integer read FCellSize write SetCellSize default 18; + property TransparentStyle: TTransparentStyle read FTStyle write SetTStyle default tsNone; + property CellStyle: TCellStyle read FCellStyle write SetCellStyle default csDefault; + property ColorNames: TStrings read FNames write SetNames; + {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} + property ParentBackground default true; + {$ENDIF} {$ENDIF} + property TabStop default true; + property TabOrder; + property ShowHint default false; + property Constraints; + property Color; + property ParentColor; + property ParentShowHint default true; + property PopupMenu; + property Visible; + + property DragCursor; + property DragKind; + property DragMode; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnStartDock; + property OnStartDrag; + property OnSelColorChange: TNotifyEvent read FOnChange write FOnChange; + property OnColorsChange: TNotifyEvent read FOnColorsChange write FOnColorsChange; + property OnPaintCell: TPaintCellEvent read FOnPaintCell write FOnPaintCell; + property OnCellClick: TCellClickEvent read FOnCellClick write FOnCellClick; + property OnGetHintText: TGetHintTextEvent read FOnGetHintText write FOnGetHintText; + property OnArrowKey: TArrowKeyEvent read FOnArrowKey write FOnArrowKey; + property OnContextPopup; + property OnMouseMove; + property OnMouseDown; + property OnMouseUp; + property OnKeyDown; + property OnKeyUp; + property OnKeyPress; + property OnResize; + property OnClick; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R mbColorPalette.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TmbColorPalette]); +end; + +constructor TmbColorPalette.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; + DoubleBuffered := true; + PBack := TBitmap.Create; + PBack.PixelFormat := pf32bit; + {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} + ParentBackground := true; + {$ENDIF} {$ENDIF} + TabStop := true; + ParentShowHint := true; + ShowHint := false; + Width := 180; + Height := 126; + FMouseLoc := mlNone; + FMouseOver := false; + FMouseDown := false; + FColCount := 0; + FRowCount := 0; + FIndex := -1; + FCheckedIndex := -1; + FTop := 0; + FLeft := 0; + FCellSize := 18; + FState := ccsNone; + FNames := TStringList.Create; + FColors := TStringList.Create; + (FColors as TStringList).OnChange := ColorsChange; + FTotalCells := 0; + FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %hex'; + FAutoHeight := false; + FMinColors := 0; + FMaxColors := 0; + FSort := smNone; + FOrder := soAscending; + FOld := clNone; + FTStyle := tsNone; + FCellStyle := csDefault; +end; + +destructor TmbColorPalette.Destroy; +begin + PBack.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 + begin + 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; +end; + +function TmbColorPalette.GetTotalRowCount: integer; +begin +if FColCount <> 0 then + Result := FTotalCells div FColCount +else + Result := 0; +end; + +procedure TmbColorPalette.CreateWnd; +begin + inherited; + CalcAutoHeight; + Invalidate; +end; + +procedure TmbColorPalette.PaintParentBack; +{$IFDEF DELPHI_7_UP} +var + MemDC: HDC; + OldBMP: HBITMAP; +{$ENDIF} +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 TmbColorPalette.Paint; +var + i: integer; +begin + PaintParentBack; + //make bmp + FTempBmp := TBitmap.Create; + try + FTempBmp.PixelFormat := pf32bit; + FTempBmp.Width := Width; + FTempBmp.Height := Height; + + {$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 + FTop := 0; + FLeft := 0; + //draw the cells + for i := 0 to FColors.Count - 1 do + begin + if FColors.Strings[i] <> '' then + DrawCell(FColors.Strings[i]); + Inc(FLeft); + end; + //draw the result + Canvas.Draw(0, 0, FTempBmp); + //csDesiginng border + if csDesigning in ComponentState then + 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; + +procedure TmbColorPalette.DrawCell(clr: string); +var + R: Trect; + FCurrentIndex: integer; + c: TColor; + Handled: boolean; +begin + // set props + if (FLeft + 1) * FCellSize > FTempBmp.width then + begin + 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 + begin + {$IFDEF FPC} + if Color = clDefault then + Brush.Color := clForm else + {$ENDIF} + Brush.Color := Color; + //get current state + if FCurrentIndex = FCheckedIndex then + begin + if FCheckedIndex = FIndex then + begin + if FMouseDown then + FState := ccsDown + else + FState := ccsCheckedHover; + end + else + FState := ccsChecked; + end + else + if FIndex = FCurrentIndex then + case FMouseLoc of + mlNone: FState := ccsNone; + mlOver: FState := ccsOver; + end + else + FState := ccsNone; + + //paint + DrawCellBack(FTempBmp.Canvas, R, FCurrentIndex); + + // 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); + end; + if not Handled then + begin + // if standard colors draw the rect + 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 + begin + Brush.Color := c; + Pen.Color := clBtnShadow; + end + else + begin + Brush.Color := clGray; + Pen.Color := clGray; + end; + Rectangle(R); + Exit; + end; + csCorel: + begin + 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; + 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; + end; +end; + +procedure TmbColorPalette.DrawCellBack(ACanvas: TCanvas; R: TRect; AIndex: integer); +begin + case FCellStyle of + csDefault: + begin + {$IFDEF DELPHI_7_UP} + if ThemeServices.ThemesEnabled then + begin + with ThemeServices do + if Enabled then + case FState of + ccsNone: ACanvas.CopyRect(R, PBack.Canvas, R); + ccsOver: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonHot), R); + ccsDown: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonPressed), R); + ccsChecked: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonChecked), R); + ccsCheckedHover: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonCheckedHot), R); + end + else + DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonDisabled), R); + end + else + {$ENDIF} + if Enabled then + case FState of + ccsNone: ACanvas.FillRect(R); + ccsOver: DrawEdge(ACanvas.Handle, R, BDR_RAISEDINNER, BF_RECT); + ccsDown, ccsChecked, ccsCheckedHover: DrawEdge(ACanvas.Handle, R, BDR_SUNKENOUTER, BF_RECT); + end + else + DrawFrameControl(ACanvas.Handle, R, DFC_BUTTON, 0 or DFCS_BUTTONPUSH or DFCS_FLAT or DFCS_INACTIVE); + end; + csCorel: + begin + if Enabled then + begin + {$IFDEF DELPHI_7_UP} + if ThemeServices.ThemesEnabled then + case FState of + ccsNone: + begin + ACanvas.Brush.Color := clWhite; + ACanvas.Pen.Color := clBlack; + //left + ACanvas.MoveTo(R.Left, R.Top); + ACanvas.LineTo(R.Left, R.Bottom-1); + //bottom + ACanvas.MoveTo(R.Left, R.Bottom-1); + ACanvas.LineTo(R.Right, R.Bottom-1); + //top + if R.Top = 0 then + begin + ACanvas.MoveTo(R.Left, R.Top); + ACanvas.LineTo(R.Right, R.Top); + end; + //right + if (R.Right = Width) then + begin + ACanvas.MoveTo(R.Right-1, R.Top); + ACanvas.LineTo(R.Right-1, R.Bottom-1); + end + else + if (AIndex = FTotalCells) then + begin + ACanvas.MoveTo(R.Right, R.Top); + ACanvas.LineTo(R.Right, R.Bottom); + end; + end; + ccsOver: ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonHot), R); + ccsDown: ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonPressed), R); + ccsChecked: ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonChecked), R); + ccsCheckedHover: ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonCheckedHot), R); + end + else + {$ENDIF} + case FState of + ccsNone: + begin + ACanvas.Brush.Color := clWhite; + ACanvas.Pen.Color := clBlack; + ACanvas.Brush.Color := clWhite; + ACanvas.Pen.Color := clBlack; + //left + ACanvas.MoveTo(R.Left, R.Top); + ACanvas.LineTo(R.Left, R.Bottom-1); + //bottom + ACanvas.MoveTo(R.Left, R.Bottom-1); + ACanvas.LineTo(R.Right, R.Bottom-1); + //top + if R.Top = 0 then + begin + ACanvas.MoveTo(R.Left, R.Top); + ACanvas.LineTo(R.Right, R.Top); + end; + //right + if (R.Right = Width) then + begin + ACanvas.MoveTo(R.Right-1, R.Top); + ACanvas.LineTo(R.Right-1, R.Bottom-1); + end + else + if (AIndex = FTotalCells) then + begin + ACanvas.MoveTo(R.Right, R.Top); + ACanvas.LineTo(R.Right, R.Bottom); + end; + end; + ccsOver: + begin + OffsetRect(R, 1,1); + DrawEdge(ACanvas.Handle, R, BDR_RAISED, BF_RECT); + end; + ccsDown, ccsChecked, ccsCheckedHover: DrawEdge(ACanvas.Handle, R, BDR_SUNKENOUTER, BF_RECT); + end; + end + else + {$IFDEF DELPHI_7_UP} + if ThemeServices.ThemesEnabled then + ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonDisabled), R) + else + {$ENDIF} + begin + ACanvas.Brush.Color := Color; + ACanvas.FillRect(R); + end; + end; + end; +end; + +procedure TmbColorPalette.PaintTransparentGlyph(ACanvas: TCanvas; R: TRect); +begin + InflateRect(R, -3, -3); + if FCellStyle = csCorel then + begin + if FState <> ccsNone then + InflateRect(R, -2, -2) + else + if FColCount > 1 then + Inc(R.Right); + end; + with ACanvas do + case FTStyle of + tsPhotoshop: + begin + if Enabled then + Pen.Color := clBtnShadow + else + Pen.Color := clGray; + Brush.Color := clWhite; + Rectangle(R); + Brush.Color := clSilver; + FillRect(Rect(R.Left + (R.Right - R.Left) div 2, R.Top + 1, R.Right - 1, R.Top + (R.Bottom - R.Top) div 2)); + FillRect(Rect(R.Left + 1, R.Top + (R.Bottom - R.Top) div 2, R.Left + (R.Right - R.Left) div 2, R.Bottom - 1)); + end; + tsPhotoshop2: + begin + InflateRect(R, -1, -1); + Brush.Color := clWhite; + Rectangle(R); + Pen.Color := clRed; + Pen.Width := 2; + InflateRect(R, 1, 1); + MoveTo(R.Left, R.Top); + LineTo(R.Right - 1, R.Bottom - 1); + Pen.Width := 1; + Pen.Color := clBlack; + end; + tsCorel: + begin + if FCellStyle = csCorel then + begin + Pen.Color := clBlack; + InflateRect(R, 3, 3); + Brush.Color := clWhite; + Rectangle(R); + //the \ line + MoveTo(R.Left, R.Top); + LineTo(R.Right, R.Bottom); + //the / line + MoveTo(R.Right-1, R.Top); + LineTo(R.Left-1, R.Bottom); + end + else + begin + if Enabled then + Pen.Color := clBtnShadow + else + Pen.Color := clGray; + Brush.Color := clWhite; + Rectangle(R); + MoveTo(R.Left, R.Top); + LineTo(R.Right, R.Bottom); + MoveTo(R.Right - 1, R.Top); + LineTo(R.Left - 1, R.Bottom); + end; + end; + tsMicroangelo: + begin + InflateRect(R, -1, -1); + Dec(R.Bottom); + Pen.Color := clBlack; + Brush.Color := clTeal; + Rectangle(R); + Pixels[R.Left + 2, R.Top + 2] := clWhite; + Pixels[R.Left + (R.Right - R.Left) div 2, R.Bottom] := clBlack; + MoveTo(R.Left + (R.Right - R.Left) div 2 - 2, R.Bottom + 1); + LineTo(R.Left + (R.Right - R.Left) div 2 + 3, R.Bottom + 1); + end; + end; +end; + +procedure TmbColorPalette.Resize; +begin + inherited; + CalcAutoHeight; + Invalidate; +end; + +procedure TmbColorPalette.CMMouseEnter( + var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); +begin + FMouseOver := true; + FMouseLoc := mlOver; + Invalidate; + inherited; +end; + +procedure TmbColorPalette.CMMouseLeave( + var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); +begin + FMouseOver := false; + FMouseLoc := mlNone; + FIndex := -1; + Invalidate; + inherited; +end; + +procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + if FIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then + begin + FIndex := (y div FCellSize)* FColCount + (x div FCellSize); + if FIndex > FTotalCells then FIndex := -1; + Invalidate; + end; + inherited; +end; + +procedure TmbColorPalette.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin +if Button = mbLeft then + begin + SetFocus; + FMouseDown := true; + FMouseLoc := mlDown; + if (y div FCellSize)* FColCount + (x div FCellSize) <= FTotalCells then + if FCheckedIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then + begin + FOldIndex := FCheckedIndex; + FCheckedIndex := (y div FCellSize)* FColCount + (x div FCellSize); + end; + Invalidate; + end; + inherited; +end; + +procedure TmbColorPalette.Click; +begin + inherited; +end; + +procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + 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); +end; + +procedure TmbColorPalette.CMGotFocus( + var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); +begin + 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; +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; +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); +end; + +function TmbColorPalette.GetSelColor: TColor; +begin +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]); +end; + +function TmbColorPalette.GetIndexUnderCursor: integer; +begin + Result := -1; + if FIndex > -1 then + if FIndex < FColors.Count then + Result := FIndex; +end; + +procedure TmbColorPalette.SetTStyle(s: TTransparentStyle); +begin + if FTStyle <> s then + begin + FTStyle := s; + Invalidate; + end; +end; + +procedure TmbColorPalette.SetCellStyle(s: TCellStyle); +begin + if FCellStyle <> s then + begin + FCellStyle := s; + Invalidate; + end; +end; + +procedure TmbColorPalette.SetSelColor(k: TColor); +var + s: string; + i: integer; +begin + s := mbColorToString(k); + for i:= 0 to FColors.Count - 1 do + if SameText(s, FColors.Strings[i]) then + begin + FCheckedIndex := i; + Break; + end + else + FCheckedIndex := -1; + Invalidate; + FOld := k; + if Assigned(FOnChange) then FOnChange(Self); +end; + +procedure TmbColorPalette.SetStrings(s: TStrings); +var + i: integer; +begin + FColors.Clear; + FColors.AddStrings(s); + if FColors.Count < FMinColors then + for i := 0 to FMinColors - FColors.Count - 1 do + FColors.Add('clNone'); + if (FColors.Count > FMaxColors) and (FMaxColors > 0) then + for i := FColors.Count - 1 downto FMaxColors do + FColors.Delete(i); + CalcAutoHeight; + SortColors; + Invalidate; +end; + +procedure TmbColorPalette.SetNames(n: TStrings); +var + i: integer; +begin + FNames.Clear; + FNames.AddStrings(n); + if (FNames.Count > FMaxColors) and (FMaxColors > 0) then + for i := FNames.Count - 1 downto FMaxColors do + FNames.Delete(i); +end; + +function TmbColorPalette.GetMoveCellIndex(move: TMoveDirection): integer; +var + FBefore: integer; +begin + Result := -1; + case move of + mdLeft: + if FCheckedIndex -1 < 0 then + Result := FTotalCells + else + Result := FCheckedIndex - 1; + mdRight: + if FCheckedIndex + 1 > FTotalCells then + Result := 0 + else + Result := FCheckedIndex + 1; + mdUp: + if FCheckedIndex - FColCount < 0 then + begin + FBefore := (FTotalcells div FColCount) * FColCount; + if FBefore + FCheckedIndex - 1 > FTotalCells then Dec(FBefore, FColCount); + Result := FBefore + FCheckedIndex - 1; + end + else + Result := FCheckedIndex - FColCount; + mdDown: + if FCheckedIndex + FColCount > FTotalCells then + Result := FCheckedIndex mod FColCount + 1 + else + Result := FCheckedIndex + FColCount; + end; + if Result > FColors.Count - 1 then + Result := 0; +end; + +procedure TmbColorPalette.CNKeyDown( + var Message: {$IFDEF DELPHI}TWMKeyDown{$ELSE}TLMKeyDown{$ENDIF} ); +var + FInherited: boolean; + Shift: TShiftState; +begin + Shift := KeyDataToShiftState(Message.KeyData); + Finherited := false; + case Message.CharCode of + VK_LEFT: + begin + FCheckedIndex := GetMoveCellIndex(mdLeft); + if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); + end; + VK_RIGHT: + begin + FCheckedIndex := GetMoveCellIndex(mdRight); + if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); + end; + VK_UP: + begin + FCheckedIndex := GetMoveCellIndex(mdUp); + if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); + end; + VK_DOWN: + begin + FCheckedIndex := GetMoveCellIndex(mdDown); + if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); + end; + VK_SPACE, VK_RETURN: if Assigned(FOnChange) then FOnChange(Self); + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + begin + Invalidate; + if Assigned(OnKeyDown) then OnKeyDown(Self, Message.CharCode, Shift); + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure TmbColorPalette.CMHintShow( + var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); +var + clr: TColor; + Handled: boolean; +begin +if (Colors.Count > 0) and (FIndex > -1) then + with TCMHintShow(Message) do + begin + if not ShowHint then + Message.Result := 1 + else + begin + with HintInfo^ do + begin + // show that we want a hint + Result := 0; + ReshowTimeout := 1; + HideTimeout := 5000; + clr := GetColorUnderCursor; + //fire event + Handled := false; + if Assigned(FOnGetHintText) then FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled); + if Handled then Exit; + //do default + if FIndex < FNames.Count then + HintStr := FNames.Strings[FIndex] + else + if SameText(FColors.Strings[GetIndexUnderCursor], 'clCustom') or SameText(FColors.Strings[GetIndexUnderCursor], 'clTransparent') then + HintStr := StringReplace(FColors.Strings[GetIndexUnderCursor], 'cl', '', [rfReplaceAll]) + else + HintStr := FormatHint(FHintFormat, GetColorUnderCursor); + end; + end; + end; +end; + +procedure TmbColorPalette.SetAutoHeight(auto: boolean); +begin + FAutoHeight := auto; + CalcAutoHeight; + Invalidate; +end; + +procedure TmbColorPalette.SetMinColors(m: integer); +var + i: integer; +begin + if (FMaxColors > 0) and (m > FMaxColors) then + m := FMaxColors; + FMinColors := m; + if FColors.Count < m then + for i := 0 to m - FColors.Count - 1 do + FColors.Add('clNone'); + CalcAutoHeight; + SortColors; + Invalidate; +end; + +procedure TmbColorPalette.SetMaxColors(m: integer); +var + i: integer; +begin + if m < 0 then m := 0; + FMaxColors := m; + if (m < FMinColors) and (m > 0) then + SetMinColors(m); + if (FColors.Count > FMaxColors) and (FMaxColors > 0) then + for i := FColors.Count - 1 downto FMaxColors do + FColors.Delete(i); + CalcAutoHeight; + SortColors; + Invalidate; +end; + +procedure TmbColorPalette.SetSortMode(s: TSortMode); +begin + if FSort <> s then + begin + FSort := s; + SortColors; + Invalidate; + end; +end; + +procedure TmbColorPalette.SetSortOrder(s: TSortOrder); +begin + if FOrder <> s then + begin + FOrder := s; + SortColors; + Invalidate; + end; +end; + +procedure TmbColorPalette.ColorsChange(Sender: TObject); +begin + if Assigned(FOnColorsChange) then FOnColorsChange(Self); + FTotalCells := FColors.Count - 1; + CalcAutoHeight; + Invalidate; +end; + +procedure TmbColorPalette.SetCellSize(s: integer); +begin + FCellSize := s; + CalcAutoHeight; + Invalidate; +end; + +function TmbColorPalette.GetSelectedCellRect: TRect; +var + row, fbottom, fleft: integer; +begin + if FCheckedIndex > -1 then + begin + if FCheckedIndex mod FColCount = 0 then + begin + row := FCheckedIndex div FColCount; + fleft := Width - FCellSize; + end + else + begin + row := FCheckedIndex div FColCount + 1; + fleft := (FCheckedIndex mod FColCount - 1) * FCellSize; + end; + fbottom := row * FCellSize; + Result := Rect(fleft, fbottom - FCellSize, fleft + FCellSize, fbottom); + end + else + Result := Rect(0, 0, 0, 0); +end; + +procedure TmbColorPalette.GeneratePalette(BaseColor: TColor); +begin + FColors.Text := MakePalette(BaseColor, FOrder); + CalcAutoHeight; + SortColors; + Invalidate; + if Assigned(FOnChange) then FOnChange(Self); +end; + +procedure TmbColorPalette.GenerateGradientPalette(Colors: array of TColor); +begin + FColors.Text := MakeGradientPalette(Colors); + CalcAutoHeight; + SortColors; + Invalidate; + if Assigned(FOnChange) then FOnChange(Self); +end; + +procedure TmbColorPalette.LoadPalette(FileName: TFileName); +var + supported: boolean; + a: AcoColors; + i: integer; +begin + supported := false; + if SameText(ExtractFileExt(FileName), '.pal') then + begin + supported := true; + FNames.Clear; + FColors.Text := ReadJASCPal(FileName); + end + else + if SameText(ExtractFileExt(FileName), '.aco') then + begin + supported := true; + a := ReadPhotoshopAco(FileName); + FColors.Clear; + for i := 0 to Length(a.Colors) - 1 do + FColors.Add(ColorToString(a.Colors[i])); + FNames.Clear; + if a.HasNames then + for i := 0 to Length(a.Names) - 1 do + FNames.Add(a.Names[i]); + end + else + if SameText(ExtractFileExt(FileName), '.act') then + begin + supported := true; + FNames.Clear; + FColors.Text := ReadPhotoshopAct(FileName); + end + else + Exception.Create('The file format you are trying to load is not supported in this version of the palette'#13'Please send a request to MXS along with the files of this format so'#13'loading support for this file can be added too'); + if supported then + begin + CalcAutoHeight; + SortColors; + Invalidate; + if Assigned(FOnChange) then FOnChange(Self); + end; +end; + +procedure TmbColorPalette.SaveColorsAsPalette(FileName: TFileName); +begin + if SameText(ExtractFileExt(FileName), '.pal') then + SaveJASCPal(FColors, FileName) + else + raise Exception.Create('The file extension specified does not identify a supported file format!'#13'Supported files formats are: .pal .aco .act'); +end; + +procedure TmbColorPalette.SortColors; +var + old: TColor; +begin + if FSort <> smNone then + begin + if FColors.Count = 0 then Exit; + old := GetSelColor; + SortPalColors(FColors, FSort, FOrder); + SetSelColor(old); + Invalidate; + end; +end; + +end. diff --git a/components/mbColorLib/mbColorPickerControl.pas b/components/mbColorLib/mbColorPickerControl.pas new file mode 100644 index 000000000..f30a3cc22 --- /dev/null +++ b/components/mbColorLib/mbColorPickerControl.pas @@ -0,0 +1,288 @@ +unit mbColorPickerControl; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + {$IFDEF DELPHI_7_UP} Themes,{$ENDIF} + RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors; + +type + TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc); + + TmbCustomPicker = class(TCustomControl) + 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; + property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle; + public + constructor Create(AOwner: TComponent); override; + + function GetColorAtPoint(x, y: integer): TColor; dynamic; + function GetHexColorAtPoint(X, Y: integer): string; + function GetColorUnderCursor: TColor; + function GetHexColorUnderCursor: string; + + property ColorUnderCursor: TColor read GetColorUnderCursor; + published + property SelectedColor: TColor read GetSelectedColor write SetSelectedColor; + property HintFormat: string read FHintFormat write FHintFormat; + property WebSafe: boolean read FWebSafe write SetWebSafe default false; + end; + + TmbColorPickerControl = class(TmbCustomPicker) + published + property Anchors; + property Align; + property ShowHint; + property ParentShowHint; + property Visible; + property Enabled; + property PopupMenu; + property TabOrder; + property TabStop default true; + property Color; + property ParentColor; + {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} + property ParentBackground default true; + {$ENDIF}{$ENDIF} + property DragCursor; + property DragMode; + property DragKind; + property Constraints; + + property OnContextPopup; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnResize; + property OnStartDrag; + end; + +implementation + +uses PalUtils; + +constructor TmbCustomPicker.Create(AOwner: TComponent); +begin + inherited; + ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls]; + DoubleBuffered := true; + TabStop := true; + ParentColor := true; + {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} + ParentBackground := true; + {$ENDIF}{$ENDIF} + mx := 0; + my := 0; + mdx := 0; + mdy := 0; + FHintFormat := 'Hex #%hex'#10#13'RGB[%r, %g, %b]'#10#13'HSL[%hslH, %hslS, %hslL]'#10#13'HSV[%hsvH, %hsvS, %hsvV]'#10#13'CMYK[%c, %m, %y, %k]'#10#13'L*a*b*[%cieL, %cieA, %cieB]'#10#13'XYZ[%cieX, %cieY, %cieZ]'; + FWebSafe := false; +end; + +procedure TmbCustomPicker.CreateWnd; +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 + inherited; + Invalidate; +end; + +procedure TmbCustomPicker.CMLostFocus( + var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF} ); +begin + inherited; + 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 + mx := 0; + my := 0; + inherited; +end; + +function TmbCustomPicker.GetSelectedColor: TColor; +begin + Result := clNone; + //handled in descendents +end; + +procedure TmbCustomPicker.SetSelectedColor(C: TColor); +begin + //handled in descendents +end; + +function TmbCustomPicker.GetColorAtPoint(x, y: integer): TColor; +begin + Result := clNone; + //handled in descendents +end; + +function TmbCustomPicker.GetHexColorAtPoint(X, Y: integer): string; +begin + Result := ColorToHex(GetColorAtPoint(x, y)); +end; + +function TmbCustomPicker.GetColorUnderCursor: TColor; +begin + Result := GetColorAtPoint(mx, my); +end; + +function TmbCustomPicker.GetHexColorUnderCursor: string; +begin + Result := ColorToHex(GetColorAtPoint(mx, my)); +end; + +procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow); +begin +if GetColorUnderCursor <> clNone then + with TCMHintShow(Message) do + if not ShowHint then + Message.Result := 1 + else + with HintInfo^ do + begin + Result := 0; + ReshowTimeout := 1; + HideTimeout := 5000; + HintStr := FormatHint(FHintFormat, GetColorUnderCursor);; + end; + inherited; +end; + +procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + mx := x; + my := y; +end; + +procedure TmbCustomPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited; + mx := x; + my := y; +end; + +procedure TmbCustomPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited; + mx := x; + my := y; +end; + +procedure TmbCustomPicker.SetMarkerStyle(s: TMarkerStyle); +begin + if FMarkerStyle <> s then + begin + FMarkerStyle := s; + invalidate; + end; +end; + +procedure TmbCustomPicker.SetWebSafe(s: boolean); +begin + if FWebSafe <> s then + begin + FWebSafe := s; + WebSafeChanged; + end; +end; + +procedure TmbCustomPicker.WebSafeChanged; +begin + //handled in descendents +end; + +end. diff --git a/components/mbColorLib/mbColorPreview.dcr b/components/mbColorLib/mbColorPreview.dcr new file mode 100644 index 000000000..edec47a42 Binary files /dev/null and b/components/mbColorLib/mbColorPreview.dcr differ diff --git a/components/mbColorLib/mbColorPreview.pas b/components/mbColorLib/mbColorPreview.pas new file mode 100644 index 000000000..a504a7c8e --- /dev/null +++ b/components/mbColorLib/mbColorPreview.pas @@ -0,0 +1,251 @@ +unit mbColorPreview; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics; + +type + TmbColorPreview = class(TCustomControl) + private + FSelColor: TColor; + FOpacity: integer; + FOnColorChange: TNotifyEvent; + FOnOpacityChange: TNotifyEvent; + FBlockSize: integer; + FSwatchStyle: boolean; + + procedure SetSwatchStyle(Value: boolean); + procedure SetSelColor(c: TColor); + procedure SetOpacity(o: integer); + procedure SetBlockSize(s: integer); + function MakeBmp: TBitmap; + protected + procedure Paint; override; + procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); + message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; + public + constructor Create(AOwner: TComponent); override; + published + property Color: TColor read FSelColor write SetSelColor default clWhite; + property Opacity: integer read FOpacity write SetOpacity default 100; + property BlockSize: integer read FBlockSize write SetBlockSize default 6; + property SwatchStyle: boolean read FSwatchStyle write SetSwatchStyle default false; + property Anchors; + property Align; + property ShowHint; + property ParentShowHint; + property Visible; + property Enabled; + property PopupMenu; + property DragCursor; + property DragMode; + property DragKind; + property Constraints; + + property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange; + property OnOpacityChange: TNotifyEvent read FOnOpacityChange write FOnOpacityChange; + property OnContextPopup; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnResize; + property OnStartDrag; + property OnDblClick; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R mbColorPreview.dcr} +{$ENDIF} + +uses + PalUtils; + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TmbColorPreview]); +end; + +constructor TmbColorPreview.Create(AOwner: TComponent); +begin + inherited; + DoubleBuffered := true; + ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque]; + FSelColor := clWhite; + Width := 68; + Height := 32; + TabStop := false; + FOpacity := 100; + FBlockSize := 6; + FSwatchStyle := false; +end; + +function TmbColorPreview.MakeBmp: TBitmap; + begin + Result := TBitmap.Create; + Result.Width := FBlockSize; + Result.Height := FBlockSize; + if (FSelColor = clNone) or (FOpacity = 0) then + Result.Canvas.Brush.Color := clSilver + else + Result.Canvas.Brush.Color := Blend(FSelColor, clSilver, FOpacity); + Result.Canvas.FillRect(Result.Canvas.ClipRect); + end; + +procedure TmbColorPreview.Paint; +var + TempBMP, cBMP: TBitmap; + i, j: integer; + R: TRect; + rgn: HRgn; + c: TColor; +begin + TempBMP := TBitmap.Create; + cBMP := nil; + rgn := 0; + try + TempBMP.Width := Width + FBlockSize; + TempBMP.Height := Height + FBlockSize; + TempBMP.PixelFormat := pf24bit; + TempBmp.Canvas.Pen.Color := clBtnShadow; + TempBmp.Canvas.Brush.Color := FSelColor; + R := ClientRect; + with TempBmp.Canvas do + if (FSelColor <> clNone) and (FOpacity = 100) then + begin + if not FSwatchStyle then + Rectangle(R) + else + begin + Brush.Color := clWindow; + Rectangle(R); + InflateRect(R, -1, -1); + FillRect(R); + InflateRect(R, 1, 1); + InflateRect(R, -2, -2); + Brush.Color := Blend(FSelColor, clBlack, 75); + FillRect(R); + InflateRect(R, -1, -1); + Brush.Color := Blend(FSelColor, clBlack, 87); + FillRect(R); + InflateRect(R, -1, -1); + Brush.Color := FSelColor; + FillRect(R); + end; + end + else + begin + cBMP := MakeBmp; + if (FSelColor = clNone) or (FOpacity = 0) then + c := clWhite + else + c := Blend(FSelColor, clWhite, FOpacity); + Brush.Color := c; + Rectangle(R); + if FSwatchStyle then + begin + InflateRect(R, -1, -1); + FillRect(R); + InflateRect(R, 1, 1); + InflateRect(R, -2, -2); + Brush.Color := Blend(c, clBlack, 75); + FillRect(R); + InflateRect(R, -1, -1); + Brush.Color := Blend(c, clBlack, 87); + FillRect(R); + InflateRect(R, -1, -1); + Brush.Color := c; + FillRect(R); + end; + InflateRect(R, -1, -1); + rgn := CreateRectRgnIndirect(R); + SelectClipRgn(TempBmp.Canvas.Handle, rgn); + for i := 0 to (Height div FBlockSize) do + for j := 0 to (Width div FBlockSize) do + begin + if i mod 2 = 0 then + begin + if j mod 2 > 0 then + TempBmp.Canvas.Draw(j*FBlockSize, i*FBlockSize, cBMP); + end + else + begin + if j mod 2 = 0 then + TempBmp.Canvas.Draw(j*FBlockSize, i*FBlockSize, cBMP); + end; + end; + end; + Canvas.Draw(0, 0, TempBmp); + finally + DeleteObject(rgn); + cBMP.Free; + TempBMP.Free; + end; +end; + +procedure TmbColorPreview.WMEraseBkgnd( + var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); +begin + Message.Result := 1; +end; + +procedure TmbColorPreview.SetSelColor(c: TColor); +begin + if c <> FSelColor then + begin + FSelColor := c; + Invalidate; + if Assigned(FOnColorChange) then FOnColorChange(Self); + end; +end; + +procedure TmbColorPreview.SetOpacity(o: integer); +begin + if FOpacity <> o then + begin + FOpacity := o; + Invalidate; + if Assigned(FOnOpacityChange) then FOnOpacityChange(Self); + end; +end; + +procedure TmbColorPreview.SetBlockSize(s: integer); +begin + if (FBlockSize <> s) and (s > 0) then + begin + FBlockSize := s; + Invalidate; + end; +end; + +procedure TmbColorPreview.SetSwatchStyle(Value: boolean); +begin + if FSwatchStyle <> Value then + begin + FSwatchStyle := Value; + Invalidate; + end; +end; + +end. diff --git a/components/mbColorLib/mbColorTree.dcr b/components/mbColorLib/mbColorTree.dcr new file mode 100644 index 000000000..e117cf097 Binary files /dev/null and b/components/mbColorLib/mbColorTree.dcr differ diff --git a/components/mbColorLib/mbColorTree.pas b/components/mbColorLib/mbColorTree.pas new file mode 100644 index 000000000..45e003db3 --- /dev/null +++ b/components/mbColorLib/mbColorTree.pas @@ -0,0 +1,686 @@ +unit mbColorTree; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC} + LCLIntf, LCLType, LMessages, + {$ELSE} + Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, ComCtrls, Graphics, + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} {$IFDEF DELPHI_6_UP}GraphUtil,{$ENDIF} + ImgList, HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, + Forms; + +type + {$IFNDEF DELPHI_6_UP} + TScrollDirection = (sdLeft, sdRight, sdUp, sdDown); + {$ENDIF} + + TmbColor = record + name: string; + value: TColor; + end; + + TDrawCaptionEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string; Selected: boolean) of object; + TDrawLabelEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string) of object; + TGetHintEvent = procedure (AIndex: integer; var AHint: string; var Handled: boolean) of object; + + TmbColorTree = class(TCustomTreeView) + private + dummy: TCustomImageList; + FInfo1, FInfo2: string; + FInfoLabel: string; + FDraw: TDrawCaptionEvent; + FDraw1, FDraw2, FDraw3: TDrawLabelEvent; + mx, my: integer; + 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; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState; + Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; override; + function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; {$IFDEF DELPHI_7_UP}override;{$ENDIF} + 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); + public + Colors: array of TmbColor; + + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure UpdateColors; + procedure AddColor(Name: string; Value: TColor; refresh: boolean = true); + procedure ClearColors; + procedure DeleteColor(Index: integer; refresh: boolean = true); + procedure DeleteColorByName(Name: string; All: boolean); + procedure DeleteColorByValue(Value: TColor; All: boolean); + procedure InsertColor(Index: integer; Name: string; Value: TColor); + function ColorCount: integer; + published + property InfoLabelText: string read FInfoLabel write SetInfoLabel; + property InfoDisplay1: string read FInfo1 write SetInfo1; + property InfoDisplay2: string read FInfo2 write SetInfo2; + property Align; + property Anchors; + property AutoExpand; + {$IFDEF DELPHI} + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind default bkNone; + property BevelWidth; + {$ENDIF} + property BorderStyle; + property BorderWidth; + {$IFDEF DELPHI} + property ChangeDelay; + property Ctl3D; + property ParentCtl3D; + {$ENDIF} + property Constraints; + property Color; + property DragKind; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property Indent; + {$IFDEF DELPHI_7_UP} + property MultiSelect; + property MultiSelectStyle; + {$ENDIF} + property ParentColor default False; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RightClickSelect; + property ShowHint; + property SortType; + property TabOrder; + property TabStop default True; + property ToolTips; + property Visible; + + property OnGetHint: TGetHintEvent read FGetHint write FGetHint; + property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw; + property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1; + property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2; + property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3; + {$IFDEF DELPHI_7_UP} + property OnAddition; + property OnCreateNodeClass; + {$ENDIF} + property OnAdvancedCustomDraw; + property OnAdvancedCustomDrawItem; + property OnChange; + property OnChanging; + property OnClick; + property OnCollapsed; + property OnCollapsing; + property OnCompare; + property OnContextPopup; + property OnCustomDraw; + property OnCustomDrawItem; + property OnDblClick; + property OnDeletion; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag; + property OnEnter; + property OnExit; + property OnExpanding; + property OnExpanded; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag; + property Items; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R mbColorTree.dcr} +{$ENDIF} + +uses + PalUtils; + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TmbColorTree]); +end; + +//taken from GraphUtil, only for Delphi 5 +{$IFNDEF DELPHI_6_UP} + +procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection; + Location: TPoint; Size: Integer); +const + ArrowPts: array[TScrollDirection, 0..2] of TPoint = + (((X:1; Y:0), (X:0; Y:1), (X:1; Y:2)), + ((X:0; Y:0), (X:1; Y:1), (X:0; Y:2)), + ((X:0; Y:1), (X:1; Y:0), (X:2; Y:1)), + ((X:0; Y:0), (X:1; Y:1), (X:2; Y:0))); +var + I: Integer; + Pts: array[0..2] of TPoint; + OldWidth: Integer; + OldColor: TColor; +begin + if ACanvas = nil then exit; + OldColor := ACanvas.Brush.Color; + ACanvas.Brush.Color := ACanvas.Pen.Color; + Move(ArrowPts[Direction], Pts, SizeOf(Pts)); + for I := 0 to 2 do + Pts[I] := Point(Pts[I].x * Size + Location.X, Pts[I].y * Size + Location.Y); + with ACanvas do + begin + OldWidth := Pen.Width; + Pen.Width := 1; + Polygon(Pts); + Pen.Width := OldWidth; + Brush.Color := OldColor; + end; +end; + +{$ENDIF} + +{ TmbColorTree } + +constructor TmbColorTree.Create(AOwner: TComponent); +begin + inherited; + ControlStyle := ControlStyle + [csDisplayDragImage]; + MaxHue := 360; + MaxSat := 255; + MaxLum := 255; + ReadOnly := true; + ShowButtons := false; + ShowLines := false; + ShowRoot := true; + RowSelect := true; + HotTrack := false; + SetLength(Colors, 0); + dummy := TCustomImageList.Create(Self); + dummy.Width := 48; + dummy.Height := 48; + Images := dummy; + FInfoLabel := 'Color Values:'; + FInfo1 := 'RGB: %r.%g.%b'; + FInfo2 := 'HEX: #%hex'; +end; + +destructor TmbColorTree.Destroy; +begin + dummy.Free; + inherited; +end; + +procedure TmbColorTree.UpdateColors; +var + i: integer; + n: TTreeNode; +begin + Items.Clear; + for i := 0 to Length(Colors) - 1 do + begin + n := Items.Add(TopItem, Colors[i].name); + Items.AddChild(n, ''); + end; +end; + +function TmbColorTree.CanChange(Node: TTreeNode): Boolean; +begin + Result := Node.HasChildren; +end; + +procedure TmbColorTree.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + r: TRect; +begin + inherited; + if (ssShift in Shift) or (ssCtrl in Shift) then Exit; + if Selected <> nil then + r := Selected.DisplayRect(false) + else + Exit; + if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then + if (Selected.HasChildren) and PtInRect(r, Point(x, y)) then + begin + if selected.Expanded then + Selected.Collapse(false) + else + Selected.Expand(false); + Invalidate; + end; +end; + +procedure TmbColorTree.MouseMove(Shift: TShiftState; X, Y: Integer); +var + r: TRect; +begin + inherited; + mx := x; + my := y; + if GetNodeAt(x, y) <> nil then + r := GetNodeAt(x, y).DisplayRect(false) + else + begin + Cursor := crDefault; + Exit; + end; + + if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then + begin + if (GetNodeAt(x, y).HasChildren) and PtInRect(r, Point(x, y)) then + Cursor := crHandPoint + else + Cursor := crDefault; + end + else + Cursor := crDefault; +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); +end; + +procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); +var + b: TBitmap; +begin + b := TBitmap.Create; + try + b.Height := 12; + b.Width := 12; + if Sel then + begin + b.Canvas.Brush.Color := clHighlight; + b.Canvas.Pen.Color := clHighlightText; + end + else + begin + b.Canvas.Brush.Color := clBtnFace; + b.Canvas.Pen.Color := clWindowText; + end; + b.Canvas.FillRect(B.Canvas.ClipRect); + case dir of + sdDown: DrawArrow(b.Canvas, dir, Point(2, 3), 3); + sdRight: DrawArrow(b.Canvas, dir, Point(1, 2), 3); + end; + c.Draw(p.x, p.y, b); + finally + b.Free; + end; +end; + +procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); +var + SR, TR: TRect; +begin + with Canvas do + begin + //background + Pen.Color := clWindow; + if Selected then + Brush.Color := clHighlight + else + Brush.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 + {$IFDEF DELPHI_7_UP} + if ThemeServices.ThemesEnabled then + begin + ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); + InflateRect(SR, -2, -2); + Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Blend(Self.Colors[Index].value, clBlack, 90); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Self.Colors[Index].value; + FillRect(SR); + end + else + //windows 9x + begin + {$ENDIF} + Pen.Color := clBackground; + Brush.Color := clWindow; + Rectangle(SR); + InflateRect(SR, -1, -1); + FillRect(SR); + InflateRect(SR, 1, 1); + InflateRect(SR, -2, -2); + Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87); + FillRect(SR); + InflateRect(SR, -1, -1); + Brush.Color := Self.Colors[Index].value; + FillRect(SR); + {$IFDEF DELPHI_7_UP} + end; + {$ENDIF} + end + else + //not selected + begin + //windows XP + {$IFDEF DELPHI_7_UP} + if ThemeServices.ThemesEnabled then + begin + ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); + InflateRect(SR, -2, -2); + Brush.Color := Self.Colors[Index].value; + FillRect(SR); + end + else + //windows 9x + begin + {$ENDIF} + DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT); + InflateRect(SR, -2, -2); + Brush.Color := Self.Colors[Index].value; + Pen.Color := clBlack; + Rectangle(SR); + InflateRect(SR, -1, -1); + FillRect(SR); + InflateRect(SR, 1, 1); + {$IFDEF DELPHI_7_UP} + end; + {$ENDIF} + end; + //names + Font.Style := [fsBold]; + if Selected then + begin + Brush.Color := clHighlightText; + Pen.Color := clHighlightText; + end + else + begin + Brush.Color := clWindowText; + Pen.Color := clWindowText; + 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 R.Right > 60 then + begin + if Expanded then + 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; +end; + +procedure TmbColorTree.DrawInfoItem(R: TRect; Index: integer); +var + b: TBitmap; + BR, TR: TRect; + i, fx: integer; + s: string; +begin + b := TBitmap.Create; + try + b.Width := R.Right - R.Left; + b.Height := R.Bottom - R.Top; + BR := b.Canvas.ClipRect; + b.Canvas.Font.Assign(Font); + with b.Canvas do + begin + Brush.Color := Blend(clBtnFace, clWindow, 30); + FillRect(BR); + BR := Rect(BR.Left + 42, BR.Top, BR.Right, BR.Bottom); + Brush.Color := clWindow; + FillRect(BR); + Inc(BR.Left, 6); + Font.Style := []; + Font.Size := 7; + + s := FInfoLabel; + TR := Rect(BR.Left, BR.Top + 2, BR.Right, BR.Top + 12); + if Assigned(FDraw1) then FDraw1(Self, Index, Canvas.Font, s); + DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, DT_LEFT or DT_END_ELLIPSIS or DT_NOCLIP); + + fX := BR.Left; + for i := 0 to (BR.Right - 2 - BR.Left) div 2 do + begin + Pixels[fX, BR.Top + 4 + TextHeight(s)] := clGray; + fX := fX + 2; + end; + + s := FormatHint(FInfo1, Self.Colors[Index].value); + TR := Rect(BR.Left, BR.Top + (BR.Bottom - BR.Top) div 3 + 2, BR.Right, BR.Top + 12); + if Assigned(FDraw2) then FDraw2(Self, Index, Canvas.Font, s); + DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, DT_LEFT or DT_END_ELLIPSIS or DT_NOCLIP); + + fX := BR.Left; + for i := 0 to (BR.Right - 2 - BR.Left) div 2 do + begin + Pixels[fX, BR.Top + (BR.Bottom - BR.Top) div 3 + 4 + TextHeight(s)] := clGray; + fX := fX + 2; + end; + + s := FormatHint(FInfo2, Self.Colors[Index].value); + TR := Rect(BR.Left, BR.Top + 2*((BR.Bottom - BR.Top) div 3) + 2, BR.Right, BR.Top + 12); + if Assigned(FDraw3) then FDraw3(Self, Index, Canvas.Font, s); + DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, DT_LEFT or DT_END_ELLIPSIS or DT_NOCLIP); + end; + Canvas.Draw(R.Left, R.Top, b); + finally + b.Free; + end; +end; + +function TmbColorTree.IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; +begin + Result := true; +end; + +procedure TmbColorTree.SetInfoLabel(Value: string); +begin + if FInfoLabel <> Value then + begin + FInfoLabel := Value; + Invalidate; + end; +end; + +procedure TmbColorTree.SetInfo1(Value: string); +begin + if FInfo1 <> Value then + begin + FInfo1 := Value; + Invalidate; + end; +end; + +procedure TmbColorTree.SetInfo2(Value: string); +begin + if FInfo2 <> Value then + begin + FInfo2 := Value; + Invalidate; + end; +end; + +procedure TmbColorTree.AddColor(Name: string; Value: TColor; refresh: boolean = true); +var + l: integer; +begin + l := Length(Colors); + SetLength(Colors, l + 1); + Colors[l].name := Name; + Colors[l].value := Value; + if refresh then + UpdateColors; +end; + +procedure TmbColorTree.ClearColors; +begin + SetLength(Colors, 0); + UpdateColors; +end; + +function TmbColorTree.ColorCount: integer; +begin + Result := Length(Colors); +end; + +procedure TmbColorTree.DeleteColor(Index: integer; refresh: boolean = true); +var + i: integer; +begin + if Length(Colors) = 0 then + begin + raise Exception.Create('There''s nothing to delete! The length of the array is 0.'); + Exit; + end; + + if Index > Length(Colors) - 1 then + begin + raise Exception.Create(Format('List index out of bounds (%d)', [Index])); + Exit; + end; + + for i := Index to Length(Colors) - 2 do + Colors[i] := Colors[i+1]; + SetLength(Colors, Length(Colors) - 1); + if refresh then + UpdateColors; +end; + +procedure TmbColorTree.DeleteColorByName(Name: string; All: boolean); +var + i: integer; +begin + for i := Length(Colors) - 1 downto 0 do + if SameText(Colors[i].name, Name) then + begin + DeleteColor(i, false); + if not All then + begin + UpdateColors; + Exit; + end; + end; + UpdateColors; +end; + +procedure TmbColorTree.DeleteColorByValue(Value: TColor; All: boolean); +var + i: integer; +begin + for i := Length(Colors) - 1 downto 0 do + if Colors[i].Value = Value then + begin + DeleteColor(i, false); + if not All then + begin + UpdateColors; + Exit; + end; + end; + UpdateColors; +end; + +procedure TmbColorTree.InsertColor(Index: integer; Name: string; Value: TColor); +var + i: integer; +begin + if Index > Length(Colors) - 1 then + begin + raise Exception.Create(Format('List index out of bounds (%d)', [Index])); + Exit; + end; + + SetLength(Colors, Length(Colors) + 1); + for i := Length(Colors) - 1 downto Index do + Colors[i] := Colors[i-1]; + + Colors[Index].Name := Name; + Colors[Index].Value := Value; + + UpdateColors; +end; + +procedure TmbColorTree.CMHintShow(var Message: TCMHintShow); +var + Handled: boolean; + i: integer; + n: TTreeNode; +begin +if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then + begin + n := GetNodeAt(mx, my); + if n <> nil then + begin + if not n.HasChildren then + i := n.Parent.Index + else + i := n.Index; + with TCMHintShow(Message) do + if not ShowHint then + Message.Result := 1 + else + with HintInfo^ do + begin + Result := 0; + ReshowTimeout := 2000; + HideTimeout := 1000; + Handled := false; + if Assigned(FGetHint) then FGetHint(i, HintStr, Handled); + if Handled then + HintStr := FormatHint(HintStr, Colors[i].Value) + else + HintStr := Colors[i].Name; + end; + end; + end; + inherited; +end; + +end. diff --git a/components/mbColorLib/mbDeskPickerButton.dcr b/components/mbColorLib/mbDeskPickerButton.dcr new file mode 100644 index 000000000..262e4b94d Binary files /dev/null and b/components/mbColorLib/mbDeskPickerButton.dcr differ diff --git a/components/mbColorLib/mbDeskPickerButton.pas b/components/mbColorLib/mbDeskPickerButton.pas new file mode 100644 index 000000000..99623a9e7 --- /dev/null +++ b/components/mbColorLib/mbDeskPickerButton.pas @@ -0,0 +1,113 @@ +unit mbDeskPickerButton; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, + {$ELSE} + Windows, + {$ENDIF} + SysUtils, Classes, Controls, StdCtrls, Graphics, Forms, ScreenWin; + +type + TmbDeskPickerButton = class(TButton) + private + FSelColor: TColor; + ScreenFrm: TScreenForm; + FOnColorPicked: TNotifyEvent; + FOnKeyDown: TKeyEvent; + FHintFmt: string; + FShowScreenHint: boolean; + OnWUp, OnWDown: TMouseWheelUpDownEvent; + protected + procedure StartPicking; + procedure ColorPicked(Sender: TObject); + procedure ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); + procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); + public + constructor Create(AOwner: TComponent); override; + procedure Click; override; + + property SelectedColor: TColor read FSelColor; + published + property OnSelColorChange: TNotifyEvent read FOnColorPicked write FOnColorPicked; + property OnScreenKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown; + property OnSelMouseWheelUp: TMouseWheelUpDownEvent read OnWUp write OnWUp; + property OnSelMouseWheelDown: TMouseWheelUpDownEvent read OnWDown write OnWDown; + property ScreenHintFormat: string read FHintFmt write FHintFmt; + property ShowScreenHint: boolean read FShowScreenHint write FShowScreenHint default false; + end; + +procedure Register; + + +implementation + +{$IFDEF FPC} + {$R mbDeskPickerButton.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TmbDeskPickerButton]); +end; + +constructor TmbDeskPickerButton.Create(AOwner: TComponent); +begin + inherited; + DoubleBuffered := true; + ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}]; + FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h'; + FShowScreenHint := false; +end; + +procedure TmbDeskPickerButton.Click; +begin + inherited; + StartPicking; +end; + +procedure TmbDeskPickerButton.StartPicking; +begin + ScreenFrm := TScreenForm.Create(Application); + try + ScreenFrm.OnSelColorChange := ColorPicked; + ScreenFrm.OnScreenKeyDown := ScreenKeyDown; + ScreenFrm.OnMouseWheelDown := WheelDown; + ScreenFrm.OnMouseWheelUp := WheelUp; + ScreenFrm.ShowHint := FShowScreenHint; + ScreenFrm.FHintFormat := FHintFmt; + ScreenFrm.ShowModal; + finally + ScreenFrm.Free; + end; +end; + +procedure TmbDeskPickerButton.ColorPicked(Sender: TObject); +begin + FSelColor := ScreenFrm.SelectedColor; + if Assigned(FOnColorPicked) then FOnColorPicked(Self); +end; + +procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift); +end; + +procedure TmbDeskPickerButton.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + if Assigned(OnWUp) then OnWUp(Self, Shift, MousePos, Handled); +end; + +procedure TmbDeskPickerButton.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + if Assigned(OnWDown) then OnWDown(Self, Shift, MousePos, Handled); +end; + +end. diff --git a/components/mbColorLib/mbOfficeColorDialog.dcr b/components/mbColorLib/mbOfficeColorDialog.dcr new file mode 100644 index 000000000..aa894cca6 Binary files /dev/null and b/components/mbColorLib/mbOfficeColorDialog.dcr differ diff --git a/components/mbColorLib/mbOfficeColorDialog.pas b/components/mbColorLib/mbOfficeColorDialog.pas new file mode 100644 index 000000000..b31f8a20b --- /dev/null +++ b/components/mbColorLib/mbOfficeColorDialog.pas @@ -0,0 +1,84 @@ +unit mbOfficeColorDialog; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + {$IFDEF FPC} + LCLIntf, LCLType, + {$ELSE} + Windows, + {$ENDIF} + SysUtils, Classes, Graphics, Forms, OfficeMoreColorsDialog; + +type + TmbOfficeColorDialog = class(TComponent) + private + FWin: TOfficeMoreColorsWin; + FSelColor: TColor; + FUseHint: boolean; + public + constructor Create(AOwner: TComponent); override; + function Execute: boolean; overload; + function Execute(AColor: TColor): boolean; overload; + published + property SelectedColor: TColor read FSelColor write FSelColor default clWhite; + property UseHints: boolean read FUseHint write FUseHint default false; + end; + +procedure Register; + +implementation + +{$IFDEF FPC} + {$R mbOfficeColorDialog.dcr} +{$ENDIF} + +procedure Register; +begin + RegisterComponents('mbColor Lib', [TmbOfficeColorDialog]); +end; + +constructor TmbOfficeColorDialog.Create(AOwner: TComponent); +begin + inherited; + FSelColor := clWhite; + FUseHint := false; +end; + +function TmbOfficeColorDialog.Execute: boolean; +begin + FWin := TOfficeMoreColorsWin.Create(Application); + try + FWin.OldSwatch.Color := FSelColor; + FWin.ShowHint := FUseHint; + Result := (FWin.ShowModal = IdOK); + if Result then + FSelColor := FWin.NewSwatch.Color + else + FSelColor := clNone; + finally + FWin.Free; + end; +end; + +function TmbOfficeColorDialog.Execute(AColor: TColor): boolean; +begin + FWin := TOfficeMoreColorsWin.Create(Application); + try + FWin.OldSwatch.Color := AColor; + FWin.ShowHint := FUseHint; + Result := (FWin.ShowModal = IdOK); + if Result then + FSelColor := FWin.NewSwatch.Color + else + FSelColor := clNone; + finally + FWin.Free; + end; +end; + +end. diff --git a/components/mbColorLib/mbTrackBarPicker.pas b/components/mbColorLib/mbTrackBarPicker.pas new file mode 100644 index 000000000..2713e055b --- /dev/null +++ b/components/mbColorLib/mbTrackBarPicker.pas @@ -0,0 +1,843 @@ +unit mbTrackBarPicker; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +{$I mxs.inc} + +uses + {$IFDEF FPC}LCLIntf, LCLType, LMessages, + {$ELSE} Windows, Messages, + {$ENDIF} + SysUtils, Classes, Controls, Graphics, Forms, + {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils; + +const + TBA_Resize = 0; + TBA_Paint = 1; + TBA_MouseMove = 2; + TBA_MouseDown = 3; + TBA_MouseUp = 4; + TBA_WheelUp = 5; + TBA_WheelDown = 6; + TBA_VKUp = 7; + TBA_VKCtrlUp = 8; + TBA_VKDown = 9; + TBA_VKCtrlDown = 10; + TBA_VKLeft = 11; + TBA_VKCtrlLeft = 12; + TBA_VKRight = 13; + TBA_VKCtrlRight = 14; + TBA_RedoBMP = 15; + +type + TTrackBarLayout = (lyHorizontal, lyVertical); + TSliderPlacement = (spBefore, spAfter, spBoth); + TSelIndicator = (siArrows, siRect); + + TmbTrackBarPicker = class(TCustomControl) + private + mx, my: integer; + FOnChange: TNotifyEvent; + FIncrement: integer; + FHintFormat: string; + FLayout: TTrackBarLayout; + FPlacement: TSliderPlacement; + FNewArrowStyle: boolean; + Aw, Ah: integer; + FDoChange: boolean; + FSelIndicator: TSelIndicator; + FWebSafe: boolean; + FBevelInner: TBevelCut; + FBevelOuter: TBevelCut; + FBevelWidth: TBevelWidth; + FBorderStyle: TBorderStyle; + + procedure SetBevelInner(Value: TBevelCut); + procedure SetBevelOuter(Value: TBevelCut); + procedure SetBevelWidth(Value: TBevelWidth); + procedure SetBorderStyle(Value: TBorderStyle); + procedure SetWebSafe(s: boolean); + function XToArrowPos(p: integer): integer; + function YToArrowPos(p: integer): integer; + procedure SetLayout(Value: TTrackBarLayout); + procedure SetNewArrowStyle(s: boolean); + procedure SetPlacement(Value: TSliderPlacement); + procedure DrawMarker(p: integer); + procedure SetSelIndicator(Value: TSelIndicator); + procedure PaintParentBack; + procedure CalcPickRect; + protected + FArrowPos: integer; + FManual: boolean; + FChange: boolean; + FPickRect: TRect; + FLimit: 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 Paint; override; + procedure DrawFrames; dynamic; + procedure Resize; override; + procedure CreateWnd; override; + procedure Execute(tbaAction: integer); dynamic; + function GetArrowPos: integer; dynamic; + function GetHintStr: string; + function GetSelectedValue: integer; virtual; abstract; + public + constructor Create(AOwner: TComponent); 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; + property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1; + property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone; + + property HintFormat: string read FHintFormat write FHintFormat; + property Increment: integer read FIncrement write FIncrement default 1; + property Layout: TTrackBarLayout read FLayout write SetLayout default lyHorizontal; + property ArrowPlacement: TSliderPlacement read FPlacement write SetPlacement default spAfter; + property NewArrowStyle: boolean read FNewArrowStyle write SetNewArrowStyle default false; + property SelectionIndicator: TSelIndicator read FSelIndicator write SetSelIndicator default siArrows; + property WebSafe: boolean read FWebSafe write SetWebSafe default false; + property TabStop default true; + property ShowHint; + property Color; + property ParentColor default true; + {$IFDEF DELPHI_7_UP} + {$IFDEF DELPHI} + property ParentBackground default true; + {$ENDIF} + {$ENDIF} + property ParentShowHint default true; + property Anchors; + property Align; + property Visible; + property Enabled; + property PopupMenu; + property TabOrder; + property DragCursor; + property DragMode; + property DragKind; + property Constraints; + + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnContextPopup; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelUp; + property OnMouseWheelDown; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnResize; + property OnStartDrag; + end; + +implementation + +const + { 3D border styles } + BDR_RAISEDOUTER = 1; + BDR_SUNKENOUTER = 2; + BDR_RAISEDINNER = 4; + BDR_SUNKENINNER = 8; + + BDR_OUTER = 3; + BDR_INNER = 12; + BDR_RAISED = 5; + BDR_SUNKEN = 10; + + { Border flags } + BF_LEFT = 1; + BF_TOP = 2; + BF_RIGHT = 4; + BF_BOTTOM = 8; + + BF_TOPLEFT = (BF_TOP or BF_LEFT); + BF_TOPRIGHT = (BF_TOP or BF_RIGHT); + BF_BOTTOMLEFT = (BF_BOTTOM or BF_LEFT); + BF_BOTTOMRIGHT = (BF_BOTTOM or BF_RIGHT); + BF_RECT = (BF_LEFT or BF_TOP or BF_RIGHT or BF_BOTTOM); + + BF_DIAGONAL = $10; + + +{TmbTrackBarPicker} + +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; +end; + +procedure TmbTrackBarPicker.CreateWnd; +begin + inherited; + CalcPickRect; +end; + +procedure TmbTrackBarPicker.CalcPickRect; +var + 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 + 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 + begin + if Assigned(FOnChange) then FOnChange(Self); + FDoChange := false; + end; +end; + +procedure TmbTrackBarPicker.DrawFrames; +var + flags: cardinal; + R: TRect; + i: integer; +begin + flags := 0; + if (FBorderStyle = bsNone) or (FBevelWidth = 0) then Exit; + case FBevelInner of + bvNone: flags := 0; + bvRaised: flags := BDR_RAISEDINNER; + bvLowered: flags := BDR_SUNKENINNER; + bvSpace: flags := BDR_INNER; + end; + case FBevelOuter of + bvRaised: flags := flags or BDR_RAISEDOUTER; + bvLowered: flags := flags or BDR_SUNKENOUTER; + bvSpace: flags := flags or BDR_OUTER; + end; + R := FPickRect; + InflateRect(R, -FBevelWidth + 1, -FBevelWidth + 1); + for i := 0 to FBevelWidth do + begin + DrawEdge(Canvas.Handle, R, flags, BF_RECT); + InflateRect(R, 1, 1); + end; +end; + +procedure TmbTrackBarPicker.DrawMarker(p: integer); +var + x, y: integer; + R: TRect; +begin + case FSelIndicator of + siRect: + begin + 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; + 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: + 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; + 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: + 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; +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; +end; + +function TmbTrackBarPicker.XToArrowPos(p: integer): integer; +var + pos: integer; +begin + 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; +begin + 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 + 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; + end; + 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; +end; + +procedure TmbTrackBarPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + {$IFDEF DELPHI} + ClipCursor(nil); + {$ENDIF} + if Button <> mbLeft then Exit; + mx := x; + my := y; + if FLayout = lyHorizontal then + FArrowPos := XToArrowPos(x) + else + FArrowPos := YToArrowPos(y); + Execute(TBA_MouseUp); + FManual := true; + FDoChange := true; + Invalidate; + inherited; +end; + +procedure TmbTrackBarPicker.CNKeyDown( + var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); +var + Shift: TShiftState; + FInherited: boolean; +begin + FInherited := false; + Shift := KeyDataToShiftState(Message.KeyData); + case Message.CharCode of + VK_UP: + begin + if FLayout = lyHorizontal then + begin + inherited; + Exit; + end; + FChange := false; + if not (ssCtrl in Shift) then + Execute(TBA_VKUp) + else + Execute(TBA_VKCtrlUp); + FManual := true; + FChange := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_LEFT: + begin + if FLayout = lyVertical then + begin + inherited; + Exit; + end; + FChange := false; + if not (ssCtrl in Shift) then + Execute(TBA_VKLeft) + else + Execute(TBA_VKCtrlLeft); + FManual := true; + FChange := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_RIGHT: + begin + if FLayout = lyVertical then + begin + inherited; + Exit; + end; + FChange := false; + if not (ssCtrl in Shift) then + Execute(TBA_VKRight) + else + Execute(TBA_VKCtrlRight); + FManual := true; + FChange := true; + if Assigned(FOnChange) then FOnChange(Self); + end; + VK_DOWN: + begin + if FLayout = lyHorizontal then + begin + inherited; + Exit; + end; + FChange := false; + if not (ssCtrl in Shift) then + Execute(TBA_VKDown) + else + Execute(TBA_VKCtrlDown); + FManual := true; + FChange := true; + if Assigned(FOnChange) then FOnChange(Self); + end + else + begin + FInherited := true; + inherited; + end; + end; + if not FInherited then + if Assigned(OnKeyDown) then + OnKeyDown(Self, Message.CharCode, Shift); +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; +end; + +procedure TmbTrackBarPicker.CMGotFocus( + var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF}); +begin + 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; +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); +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); +end; + +procedure TmbTrackBarPicker.SetLayout(Value: TTrackBarLayout); +begin + if FLayout <> Value then + begin + FLayout := Value; + Execute(TBA_RedoBMP); + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.SetPlacement(Value: TSliderPlacement); +begin + if FPlacement <> Value then + begin + FPlacement := Value; + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.SetNewArrowStyle(s: boolean); +begin + if FNewArrowStyle <> s then + begin + FNewArrowStyle := s; + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.SetSelIndicator(Value: TSelIndicator); +begin + if FSelIndicator <> Value then + begin + FSelIndicator := Value; + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.SetWebSafe(s: boolean); +begin + if FWebSafe <> s then + begin + FWebSafe := s; + Execute(TBA_RedoBMP); + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.Execute(tbaAction: integer); +begin + //handled in descendants +end; + +function TmbTrackBarPicker.GetArrowPos: integer; +begin + Result := 0; + //handled in descendants +end; + +function TmbTrackBarPicker.GetHintStr: string; +begin + Result := ReplaceFlags(FHintFormat, ['%value', '%h', '%s', '%l', '%v', '%c', + '%m', '%y', '%k', '%r', '%g', '%b'], GetSelectedValue); +end; + +procedure TmbTrackBarPicker.SetBevelInner(Value: TBevelCut); +begin + if FBevelInner <> Value then + begin + FBevelInner := Value; + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.SetBevelOuter(Value: TBevelCut); +begin + if FBevelOuter <> Value then + begin + FBevelOuter := Value; + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.SetBevelWidth(Value: TBevelWidth); +begin + if FBevelWidth <> Value then + begin + FBevelWidth := Value; + Invalidate; + end; +end; + +procedure TmbTrackBarPicker.SetBorderStyle(Value: TBorderStyle); +begin + if FBorderStyle <> Value then + begin + FBorderStyle := Value; + Invalidate; + end; +end; + +end. diff --git a/components/mbColorLib/mbcolorliblaz.lpk b/components/mbColorLib/mbcolorliblaz.lpk new file mode 100644 index 000000000..d09168577 --- /dev/null +++ b/components/mbColorLib/mbcolorliblaz.lpk @@ -0,0 +1,234 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <Package Version="4"> + <PathDelim Value="\"/> + <Name Value="mbColorLibLaz"/> + <Type Value="RunAndDesignTime"/> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + </CompilerOptions> + <Files Count="43"> + <Item1> + <Filename Value="PalUtils.pas"/> + <UnitName Value="PalUtils"/> + </Item1> + <Item2> + <Filename Value="HTMLColors.pas"/> + <UnitName Value="HTMLColors"/> + </Item2> + <Item3> + <Filename Value="RGBCIEUtils.pas"/> + <UnitName Value="RGBCIEUtils"/> + </Item3> + <Item4> + <Filename Value="RGBCMYKUtils.pas"/> + <UnitName Value="RGBCMYKUtils"/> + </Item4> + <Item5> + <Filename Value="RGBHSLUtils.pas"/> + <UnitName Value="RGBHSLUtils"/> + </Item5> + <Item6> + <Filename Value="RGBHSVUtils.pas"/> + <UnitName Value="RGBHSVUtils"/> + </Item6> + <Item7> + <Filename Value="mbColorList.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="mbColorList"/> + </Item7> + <Item8> + <Filename Value="mbTrackBarPicker.pas"/> + <UnitName Value="mbTrackBarPicker"/> + </Item8> + <Item9> + <Filename Value="BColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="BColorPicker"/> + </Item9> + <Item10> + <Filename Value="GColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="GColorPicker"/> + </Item10> + <Item11> + <Filename Value="RColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="RColorPicker"/> + </Item11> + <Item12> + <Filename Value="HColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="HColorPicker"/> + </Item12> + <Item13> + <Filename Value="KColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="KColorPicker"/> + </Item13> + <Item14> + <Filename Value="LColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="LColorPicker"/> + </Item14> + <Item15> + <Filename Value="MColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="MColorPicker"/> + </Item15> + <Item16> + <Filename Value="VColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="VColorPicker"/> + </Item16> + <Item17> + <Filename Value="YColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="YColorPicker"/> + </Item17> + <Item18> + <Filename Value="mbColorPreview.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="mbColorPreview"/> + </Item18> + <Item19> + <Filename Value="Scanlines.pas"/> + <UnitName Value="Scanlines"/> + </Item19> + <Item20> + <Filename Value="mbColorPickerControl.pas"/> + <UnitName Value="mbColorPickerControl"/> + </Item20> + <Item21> + <Filename Value="BAxisColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="BAxisColorPicker"/> + </Item21> + <Item22> + <Filename Value="GAxisColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="GAxisColorPicker"/> + </Item22> + <Item23> + <Filename Value="RAxisColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="RAxisColorPicker"/> + </Item23> + <Item24> + <Filename Value="CIEAColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="CIEAColorPicker"/> + </Item24> + <Item25> + <Filename Value="CIEBColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="CIEBColorPicker"/> + </Item25> + <Item26> + <Filename Value="CIELColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="CIELColorPicker"/> + </Item26> + <Item27> + <Filename Value="HRingPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="HRingPicker"/> + </Item27> + <Item28> + <Filename Value="HexaColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="HexaColorPicker"/> + </Item28> + <Item29> + <Filename Value="HSColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="HSColorPicker"/> + </Item29> + <Item30> + <Filename Value="SLColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="SLColorPicker"/> + </Item30> + <Item31> + <Filename Value="SLHColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="SLHColorPicker"/> + </Item31> + <Item32> + <Filename Value="HSVColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="HSVColorPicker"/> + </Item32> + <Item33> + <Filename Value="SelPropUtils.pas"/> + <UnitName Value="SelPropUtils"/> + </Item33> + <Item34> + <Filename Value="mbOfficeColorDialog.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="mbOfficeColorDialog"/> + </Item34> + <Item35> + <Filename Value="OfficeMoreColorsDialog.pas"/> + <UnitName Value="OfficeMoreColorsDialog"/> + </Item35> + <Item36> + <Filename Value="HSLColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="HSLColorPicker"/> + </Item36> + <Item37> + <Filename Value="mbColorPalette.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="mbColorPalette"/> + </Item37> + <Item38> + <Filename Value="CColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="CColorPicker"/> + </Item38> + <Item39> + <Filename Value="SColorPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="SColorPicker"/> + </Item39> + <Item40> + <Filename Value="mbDeskPickerButton.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="mbDeskPickerButton"/> + </Item40> + <Item41> + <Filename Value="ScreenWin.pas"/> + <UnitName Value="ScreenWin"/> + </Item41> + <Item42> + <Filename Value="mbColorTree.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="mbColorTree"/> + </Item42> + <Item43> + <Filename Value="HSLRingPicker.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="HSLRingPicker"/> + </Item43> + </Files> + <RequiredPkgs Count="2"> + <Item1> + <PackageName Value="LCLBase"/> + </Item1> + <Item2> + <PackageName Value="FCL"/> + </Item2> + </RequiredPkgs> + <UsageOptions> + <UnitPath Value="$(PkgOutDir)"/> + </UsageOptions> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + </Package> +</CONFIG> diff --git a/components/mbColorLib/mxs.inc b/components/mbColorLib/mxs.inc new file mode 100644 index 000000000..fe0f1e6a9 --- /dev/null +++ b/components/mbColorLib/mxs.inc @@ -0,0 +1,44 @@ +{$IFDEF FPC} + {$DEFINE VER150} // Lazarus --> at least Delphi 7 } +{$ENDIF} + + {$ifdef VER180} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_8_UP} + {$define DELPHI_9_UP} + {$define DELPHI_10_UP} + {$endif} + + {$ifdef VER170} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_8_UP} + {$define DELPHI_9_UP} + {$endif} + + {$ifdef VER160} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_8_UP} + {$endif} + + {$ifdef VER150} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$endif} + + {$ifdef VER140} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$endif} + + {$ifdef VER130} + {$define DELPHI_5_UP} + {$endif} + + {.$DEFINE mbXP_Lib}