unit HSVColorPicker; {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} interface uses LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms, Themes, RGBHSVUtils, Scanlines, HTMLColors, mbColorPickerControl; type THSVColorPicker = class(TmbColorPickerControl) private FHue, FSat, FValue: Double; FMaxHue, FMaxSat, FMaxValue: Integer; FSatCircColor, FHueLineColor: TColor; FSelectedColor: TColor; FShowSatCirc: boolean; FShowHueLine: boolean; FShowSelCirc: boolean; function RadHue(New: integer): integer; function GetHue: Integer; function GetSat: Integer; function GetValue: Integer; function GetRed: Integer; function GetGreen: Integer; function GetBlue: Integer; procedure SetMaxHue(h: Integer); procedure SetMaxSat(s: Integer); procedure SetMaxValue(v: Integer); procedure SetHue(h: integer); procedure SetSat(s: integer); procedure SetValue(V: integer); procedure SetRed(r: Integer); procedure SetGreen(g: Integer); procedure SetBlue(b: Integer); procedure SetSatCircColor(c: TColor); procedure SetHueLineColor(c: TColor); procedure DrawSatCirc; procedure DrawHueLine; procedure DrawMarker(x, y: integer); procedure SetShowSatCirc(s: boolean); procedure SetShowSelCirc(s: boolean); procedure SetShowHueLine(s: boolean); procedure UpdateCoords; protected procedure CreateGradient; override; procedure CreateWnd; override; function GetGradientColor2D(X, Y: Integer): TColor; override; function GetSelectedColor: TColor; override; procedure Paint; override; procedure Resize; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; 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 SelectColor(x, y: integer); procedure SetSelectedColor(c: TColor); override; public constructor Create(AOwner: TComponent); override; function GetColorAtPoint(x, y: integer): TColor; override; property Red: Integer read GetRed write SetRed; property Green: Integer read GetGreen write SetGreen; property Blue: Integer read GetBlue write SetBlue; published property SelectedColor default clRed; property Hue: integer read GetHue write SetHue default 0; property Saturation: integer read GetSat write SetSat default 255; property Value: integer read GetValue write SetValue default 255; property MaxHue: Integer read FMaxHue write SetMaxHue default 359; property MaxSaturation: Integer read FMaxSat write SetMaxSat default 255; property MaxValue: Integer read FMaxValue write SetMaxValue default 255; property SaturationCircleColor: TColor read FSatCircColor write SetSatCircColor default clSilver; property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray; 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; end; implementation uses mbUtils; { THSVColorPicker } constructor THSVColorPicker.Create(AOwner: TComponent); begin inherited; SetInitialBounds(0, 0, 204, 204); FMaxHue := 359; FMaxSat := 255; FMaxValue := 255; FHue := 0; FSat := 1.0; FValue := 1.0; FSatCircColor := clSilver; FHueLineColor := clGray; FSelectedColor := clRed; FManual := false; FShowSatCirc := true; FShowHueLine := true; FShowSelCirc := true; MarkerStyle := msCrossCirc; end; procedure THSVColorPicker.CreateGradient; begin FGradientWidth := Min(Width, Height); FGradientHeight := FGradientWidth; inherited; end; procedure THSVColorPicker.CreateWnd; begin inherited; CreateGradient; UpdateCoords; end; procedure THSVColorPicker.DrawSatCirc; var delta: integer; radius: integer; begin if not FShowSatCirc then exit; if (FSat > 0) and (FSat < 1.0) then begin radius := Min(Width, Height) div 2; Canvas.Pen.Color := FSatCircColor; Canvas.Brush.Style := bsClear; delta := round(radius * FSat); Canvas.Ellipse(radius - delta, radius - delta, radius + delta, radius + delta); end; end; procedure THSVColorPicker.DrawHueLine; var angle: double; sinAngle, cosAngle: Double; radius: integer; begin if not FShowHueLine then exit; radius := Min(Width, Height) div 2; if (FHue >= 0) and (FHue <= 1.0) then begin angle := -FHue * 2 * pi; SinCos(angle, sinAngle, cosAngle); Canvas.Pen.Color := FHueLineColor; Canvas.MoveTo(radius, radius); Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle)); 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; InternalDrawMarker(x, y, c); end; function THSVColorPicker.GetBlue: Integer; begin Result := GetBValue(FSelectedColor); end; function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor; var angle: Double; dx, dy, r, radius: integer; h, s: double; begin radius := Min(Width, Height) div 2; dx := x - Radius; dy := y - Radius; r := round(sqrt(sqr(dx) + sqr(dy))); if r <= radius then begin angle := 360 + 180 * arctan2(-dy, dx) / pi; if angle < 0 then angle := angle + 360 else if angle > 360 then angle := angle - 360; h := angle / 360; s := r / radius; Result := HSVtoColor(h, s, FValue); if WebSafe then Result := GetWebSafe(Result); end else Result := clNone; end; { Outer loop: Y, Inner loop: X } function THSVColorPicker.GetGradientColor2D(X, Y: Integer): TColor; var dx, dy: Integer; dSq, radiusSq: Integer; radius, size: Integer; S, H, V: Double; q: TRGBQuad; begin size := FGradientWidth; // or Height, they are the same... radius := size div 2; radiusSq := sqr(radius); dx := X - radius; dy := Y - radius; dSq := sqr(dx) + sqr(dy); if dSq <= radiusSq then begin if radius <> 0 then S := sqrt(dSq) / radius else S := 0; H := 180 * (1 + arctan2(dx, dy) / pi); // wp: order (x,y) is correct! H := H + 90; if H > 360 then H := H - 360; Result := HSVtoColor(H/360, S, FValue); if WebSafe then Result := GetWebSafe(Result); end else Result := GetDefaultColor(dctBrush); end; function THSVColorPicker.GetGreen: Integer; begin Result := GetGValue(FSelectedColor); end; function THSVColorPicker.GetHue: Integer; begin Result := round(FHue * FMaxHue); end; function THSVColorPicker.GetRed: Integer; begin Result := GetRValue(FSelectedColor); end; function THSVColorPicker.GetSat: Integer; begin Result := round(FSat * FMaxSat); end; function THSVColorPicker.GetSelectedColor: TColor; begin if FSelectedColor <> clNone then begin Result := HSVtoColor(FHue, FSat, FValue); if WebSafe then Result := GetWebSafe(Result); end else Result := clNone; end; function THSVColorPicker.GetValue: Integer; begin Result := round(FValue * FMaxValue); end; procedure THSVColorPicker.KeyDown(var Key: Word; Shift: TShiftState); var eraseKey: Boolean; delta: Integer; begin eraseKey := true; delta := IfThen(ssCtrl in shift, 10, 1); case Key of VK_LEFT : SetHue(RadHue(GetHue() + delta)); VK_RIGHT : SetHue(RadHue(GetHue() - delta)); VK_UP : SetSat(GetSat() + delta); VK_DOWN : SetSat(GetSat() - delta); else eraseKey := false; end; if eraseKey then Key := 0; inherited; end; procedure THSVColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if csDesigning in ComponentState then exit; if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then SelectColor(X, Y); SetFocus; end; procedure THSVColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; if csDesigning in ComponentState then exit; if (ssLeft in Shift) and PointInCircle(Point(x, y), Min(Width, Height)) then SelectColor(X, Y); end; procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if csDesigning in ComponentState then exit; if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then SelectColor(X, Y); 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); InflateRect(R, -1, -1); // Avoid spurious black pixels at the border rgn := CreateEllipticRgnIndirect(R); SelectClipRgn(Canvas.Handle, rgn); Canvas.Draw(0, 0, FBufferBmp); DeleteObject(rgn); DrawSatCirc; DrawHueLine; DrawMarker(mx, my); end; function THSVColorPicker.RadHue(New: integer): integer; begin if New < 0 then New := New + (FMaxHue + 1); if New > (FMaxHue + 1) then New := New - (FMaxHue + 1); Result := New; end; procedure THSVColorPicker.Resize; begin inherited; CreateGradient; UpdateCoords; end; procedure THSVColorPicker.SelectColor(x, y: integer); var angle: Double; dx, dy, r, radius: integer; H, S: Double; begin mx := x; my := y; radius := Min(Width, Height) div 2; dx := x - radius; dy := y - radius; r := round(sqrt(sqr(dx) + sqr(dy))); if r > radius then // point outside circle begin SetSelectedColor(clNone); exit; end; //FSelectedColor := clWhite; // ???? angle := 360 + 180*arctan2(-dy, dx) / pi; // wp: "-y, x" correct? The others have "x, y" if angle < 0 then angle := angle + 360 else if angle > 360 then angle := angle - 360; H := angle / 360; if r > radius then S := 1.0 else S := r / radius; if (H = FHue) and (S = FSat) then exit; FHue := H; FSat := S; FSelectedColor := HSVToColor(FHue, FSat, FValue); UpdateCoords; Invalidate; DoChange; end; procedure THSVColorPicker.SetBlue(b: Integer); var c: TColor; begin Clamp(b, 0, 255); if b = GetBValue(FSelectedColor) then exit; c := RgbToColor(GetRValue(FSelectedColor), GetGValue(FSelectedColor), b); SetSelectedColor(c); end; procedure THSVColorPicker.SetGreen(g: Integer); var c: TColor; begin Clamp(g, 0, 255); if g = GetGValue(FSelectedColor) then exit; c := RgbToColor(GetRValue(FSelectedColor), g, GetBValue(FSelectedColor)); SetSelectedColor(c); end; procedure THSVColorPicker.SetHue(h: integer); begin if h > FMaxHue then h := h - (FMaxHue + 1); if h < 0 then h := h + (FMaxHue + 1); if GetHue() <> h then begin FHue := h / FMaxHue; FSelectedColor := HSVToColor(FHue, FSat, FValue); UpdateCoords; Invalidate; DoChange; end; end; procedure THSVColorPicker.SetHueLineColor(c: TColor); begin if FHueLineColor <> c then begin FHueLineColor := c; Invalidate; end; end; procedure THSVColorPicker.SetMaxHue(h: Integer); begin if h = FMaxHue then exit; FMaxHue := h; CreateGradient; //if FChange and Assigned(OnChange) then OnChange(Self); Invalidate; end; procedure THSVColorPicker.SetMaxSat(s: Integer); begin if s = FMaxSat then exit; FMaxSat := s; CreateGradient; //if FChange and Assigned(OnChange) then OnChange(Self); Invalidate; end; procedure THSVColorPicker.SetMaxValue(v: Integer); begin if v = FMaxValue then exit; FMaxValue := v; CreateGradient; //if FChange and Assigned(OnChange) then OnChange(Self); Invalidate; end; procedure THSVColorPicker.SetRed(r: Integer); var c: TColor; begin Clamp(r, 0, 255); if r = GetRValue(FSelectedColor) then exit; c := RgbToColor(r, GetGValue(FSelectedColor), GetBValue(FSelectedColor)); SetSelectedColor(c); end; procedure THSVColorPicker.SetSat(s: integer); begin Clamp(s, 0, FMaxSat); if GetSat() <> s then begin FSat := s / FMaxSat; FSelectedColor := HSVToColor(FHue, FSat, FValue); UpdateCoords; Invalidate; DoChange; end; end; procedure THSVColorPicker.SetSatCircColor(c: TColor); begin if FSatCircColor <> c then begin FSatCircColor := c; Invalidate; end; end; procedure THSVColorPicker.SetSelectedColor(c: TColor); var h, s, v: Double; begin if WebSafe then c := GetWebSafe(c); if c = FSelectedColor then exit; RGBtoHSV(GetRValue(c), GetGValue(c), GetBValue(c), FHue, FSat, FValue); FSelectedColor := c; UpdateCoords; Invalidate; DoChange; end; procedure THSVColorPicker.SetShowHueLine(s: boolean); begin if FShowHueLine <> s then begin FShowHueLine := s; 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.SetValue(V: integer); begin Clamp(V, 0, FMaxValue); if GetValue() <> V then begin FValue := V / FMaxValue; FSelectedColor := HSVToColor(FHue, FSat, FValue); CreateGradient; Invalidate; DoChange; end; end; procedure THSVColorPicker.UpdateCoords; var r, angle: double; sinAngle, cosAngle: Double; radius: integer; begin radius := Min(Width, Height) div 2; r := -FSat * radius; angle := -(FHue * 2 + 1) * pi; SinCos(angle, sinAngle, cosAngle); mx := round(cosAngle * r) + radius; my := round(sinAngle * r) + radius; end; end.