pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

mbColorLib: Fix painting issues of mbColorPalette

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5516 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-16 14:22:33 +00:00
parent 88b3257b59
commit 8baa12ec3b
6 changed files with 129 additions and 59 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
components/mbColorLib/HexaColorPicker.pas
View File

@ -104,7 +104,6 @@ type
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
// procedure KeyDownInterface(var Key: Word; Shift: TShiftState); override;
procedure Paint; override;
procedure Resize; override;
@ -347,7 +346,7 @@ begin
try
// OffScreen.PixelFormat := pf32bit;
OffScreen.Width := Width;
OffScreen.Height := HeightOf(FColorCombRect) + HeightOf(FBWCombRect);
OffScreen.Height := HeightOfRect(FColorCombRect) + HeightOfRect(FBWCombRect);
//Parent background
{$IFDEF FPC}
if Color = clDefault then

19
components/mbColorLib/examples/fulldemo/main.lfm
View File

@ -42,9 +42,9 @@ object Form1: TForm1
Height = 363
Top = 6
Width = 403
ActivePage = TabSheet2
ActivePage = TabSheet3
Anchors = [akTop, akLeft, akRight, akBottom]
TabIndex = 1
TabIndex = 2
TabOrder = 0
OnMouseMove = PageControl1MouseMove
object TabSheet1: TTabSheet
@ -56,7 +56,7 @@ object Form1: TForm1
Height = 287
Top = 8
Width = 377
SelectedColor = 553990
SelectedColor = 685062
HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex'
LPickerHintFormat = 'Luminance: %l'
Anchors = [akTop, akLeft, akRight, akBottom]
@ -208,8 +208,8 @@ object Form1: TForm1
Height = 253
Top = 8
Width = 385
HorzScrollBar.Page = 75
VertScrollBar.Page = 234
HorzScrollBar.Page = 385
VertScrollBar.Page = 250
Anchors = [akTop, akLeft, akRight, akBottom]
BorderStyle = bsNone
ClientHeight = 253
@ -217,10 +217,10 @@ object Form1: TForm1
TabOrder = 3
object mbColorPalette1: TmbColorPalette
Left = 0
Height = 234
Height = 250
Top = 0
Width = 385
Align = alTop
Anchors = [akTop, akLeft, akRight, akBottom]
Colors.Strings = (
'clBlack'
'$00330000'
@ -481,7 +481,6 @@ object Form1: TForm1
)
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h'
AutoHeight = True
CellStyle = csCorel
TabOrder = 0
OnSelColorChange = mbColorPalette1SelColorChange
OnMouseMove = mbColorPalette1MouseMove
@ -505,7 +504,7 @@ object Form1: TForm1
Text = 'soAscending'
end
object ComboBox3: TComboBox
Left = 124
Left = 127
Height = 23
Top = 300
Width = 87
@ -561,7 +560,7 @@ object Form1: TForm1
Width = 15
Anchors = [akLeft, akBottom]
Min = 0
OnChanging = UpDown1Changing
OnChangingEx = UpDown1ChangingEx
Position = 18
TabOrder = 7
Thousands = False

17
components/mbColorLib/examples/fulldemo/main.pas
View File

@ -140,6 +140,8 @@ type
procedure HRingPicker1Change(Sender: TObject);
procedure HRingPicker1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure UpDown1ChangingEx(Sender: TObject; var AllowChange: Boolean;
NewValue: SmallInt; Direction: TUpDownDirection);
procedure VColorPicker2Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
@ -149,7 +151,6 @@ type
procedure ComboBox2Change(Sender: TObject);
procedure ComboBox3Change(Sender: TObject);
procedure ComboBox4Change(Sender: TObject);
procedure UpDown1Changing(Sender: TObject; var AllowChange: Boolean);
procedure CbWebSsafeClick(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure CbSwatchStyleClick(Sender: TObject);
@ -167,6 +168,9 @@ implementation
{$R *.lfm}
{$R mxico.res} //MXS icon resource file, for internet shortcut only
uses
RGBHSLUtils;
procedure TForm1.tb1Change(Sender: TObject);
begin
sc.opacity := tb1.position;
@ -314,6 +318,9 @@ end;
// only for internet shortcuts
procedure TForm1.FormCreate(Sender: TObject);
begin
MaxHue := 360;
MaxSat := 240;
MaxLum := 240;
with TIniFile.Create(ExtractFilePath(Application.ExeName) + '\MXS Website.url') do
try
WriteString('InternetShortcut','URL', 'http://mxs.bergsoft.net');
@ -360,11 +367,11 @@ begin
mbcolorpalette1.CellStyle := tcellstyle(combobox4.ItemIndex);
end;
procedure TForm1.UpDown1Changing(Sender: TObject;
var AllowChange: Boolean);
procedure TForm1.UpDown1ChangingEx(Sender: TObject; var AllowChange: Boolean;
NewValue: SmallInt; Direction: TUpDownDirection);
begin
allowchange := true;
mbcolorpalette1.CellSize := abs(updown1.Position);
allowchange := true;
mbcolorpalette1.CellSize := abs(NewValue);
end;
procedure TForm1.CbWebSsafeClick(Sender: TObject);

31
components/mbColorLib/mbBasicPicker.pas
View File

@ -38,6 +38,7 @@ type
function MouseOnPicker(X, Y: Integer): Boolean; virtual;
procedure PaintParentBack; virtual; overload;
procedure PaintParentBack(ACanvas: TCanvas); overload;
procedure PaintParentBack(ACanvas: TCanvas; ARect: TRect); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload;
function ShowHintWindow(APoint: TPoint; AText: String): Boolean; virtual;
{$IFDEF DELPHI}
@ -58,7 +59,7 @@ type
implementation
uses
LCLIntf;
LCLIntf, mbUtils;
const
HINT_SHOW_DELAY = 50;
@ -183,7 +184,6 @@ begin
{$ENDIF}
ABitmap.Canvas.Brush.Color := Color;
ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect);
// Canvas.Draw(0, 0, ABitmap);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
@ -200,6 +200,12 @@ begin
end;
procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas);
var
R: TRect;
begin
R := Rect(0, 0, Width, Height);
PaintParentBack(ACanvas, R);
(*
var
OffScreen: TBitmap;
begin
@ -217,6 +223,27 @@ begin
finally
Offscreen.Free;
end;
*)
end;
procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas; ARect: TRect);
var
OffScreen: TBitmap;
begin
Offscreen := TBitmap.Create;
try
// Offscreen.PixelFormat := pf32bit;
if Color = clDefault then begin
Offscreen.Transparent := true;
Offscreen.TransparentColor := clForm; //GetDefaultColor(dctBrush);
end;
Offscreen.Width := WidthOfRect(ARect);
Offscreen.Height := HeightOfRect(ARect);
PaintParentBack(Offscreen);
ACanvas.Draw(ARect.Left, ARect.Top, Offscreen);
finally
Offscreen.Free;
end;
end;
// Build and show the hint window

101
components/mbColorLib/mbColorPalette.pas
View File

@ -33,7 +33,6 @@ type
FMouseLoc: TMouseLoc;
FMouseOver, FMouseDown, FAutoHeight: boolean;
FColCount, FRowCount, FTop, FLeft, FIndex, FCheckedIndex, FCellSize, FTotalCells: integer;
FTempBmp: TBitmap;
//PBack: TBitmap;
FState: TColorCellState;
FColors, FNames: TStrings;
@ -72,13 +71,13 @@ type
protected
procedure Paint; override;
procedure PaintTransparentGlyph(ACanvas: TCanvas; R: TRect);
procedure DrawCell(clr: string);
procedure DrawCell(ACanvas: TCanvas; AColor: string);
procedure DrawCellBack(ACanvas: TCanvas; R: TRect; AIndex: integer);
procedure ColorsChange(Sender: TObject);
procedure Click; override;
procedure Resize; override;
procedure SelectCell(i: integer);
procedure CreateWnd; override;
// 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;
@ -173,25 +172,25 @@ type
implementation
uses
mbUtils;
{ TmbColorPalette }
constructor TmbColorPalette.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
// DoubleBuffered := true;
// PBack := TBitmap.Create;
// PBack.PixelFormat := pf32bit;
FTempBmp := TBitmap.Create;
//FTempBmp.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF} {$ENDIF}
TabStop := true;
ParentShowHint := true;
ShowHint := false;
Width := 180;
Height := 126;
SetInitialBounds(0, 0, 180, 126);
FMouseLoc := mlNone;
FMouseOver := false;
FMouseDown := false;
@ -221,7 +220,7 @@ end;
destructor TmbColorPalette.Destroy;
begin
//PBack.Free;
FTempBmp.Free;
FBufferBmp.Free;
FNames.Free;
FColors.Free;
inherited Destroy;
@ -232,6 +231,7 @@ begin
if Parent = nil then
exit;
FColCount := Width div FCellSize;
{7
if FAutoHeight and (FColCount <> 0) then
begin
if FColors.Count mod FColCount > 0 then
@ -240,8 +240,11 @@ begin
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;
@ -251,13 +254,16 @@ begin
else
Result := 0;
end;
(*
procedure TmbColorPalette.CreateWnd;
begin
inherited;
{
CalcAutoHeight;
Invalidate;
}
end;
*)
(*
procedure TmbColorPalette.PaintParentBack;
{$IFDEF DELPHI_7_UP}
@ -297,15 +303,19 @@ end; *)
procedure TmbColorPalette.Paint;
var
i: integer;
bmp: TBitmap;
begin
{ PBack.Width := Width;
PBack.Height := Height;
PaintParentBack(PBack);
}
//make bmp
FTempBmp.Width := Width;
FTempBmp.Height := Height;
PaintParentBack(FTempBmp);
if FBufferBmp = nil then
FBufferBmp := TBitmap.Create;
FBufferBmp.Width := Width;
FBufferBmp.Height := Height;
PaintParentBack(FBufferBmp);
FBufferBmp.Transparent := false; // a transparent bitmap does not show the selection ?!
//reset counters
FTotalCells := FColors.Count - 1;
@ -316,12 +326,29 @@ begin
for i := 0 to FColors.Count - 1 do
begin
if FColors.Strings[i] <> '' then
DrawCell(FColors.Strings[i]);
DrawCell(FBufferBmp.Canvas, FColors.Strings[i]);
Inc(FLeft);
end;
//draw the bmp
Canvas.Draw(0, 0, FTempBmp);
if Color = clDefault then
begin
// Use temporary bitmap to draw the buffer bitmap transparently
bmp := TBitmap.Create;
try
bmp.SetSize(Width, Height);
if Color = clDefault then begin
bmp.Transparent := true;
bmp.TransparentColor := clForm;
end;
bmp.Canvas.Draw(0, 0, FBufferBmp);
Canvas.Draw(0, 0, bmp);
finally
bmp.Free;
end;
end
else
Canvas.Draw(0, 0, FBufferBmp);
//csDesiging border
if csDesigning in ComponentState then
@ -335,7 +362,7 @@ begin
end;
end;
procedure TmbColorPalette.DrawCell(clr: string);
procedure TmbColorPalette.DrawCell(ACanvas: TCanvas; AColor: string);
var
R: Trect;
FCurrentIndex: integer;
@ -343,7 +370,7 @@ var
Handled: boolean;
begin
// set props
if (FLeft + 1) * FCellSize > FTempBmp.Width then
if (FLeft + 1) * FCellSize > Width then
begin
Inc(FTop);
FLeft := 0;
@ -377,41 +404,42 @@ begin
FState := ccsNone;
//paint
DrawCellBack(FTempBmp.Canvas, R, FCurrentIndex);
DrawCellBack(ACanvas, R, FCurrentIndex);
// fire the event
Handled := false;
c := mbStringToColor(AColor);
if Assigned(FOnPaintCell) then
case FCellStyle of
csDefault:
FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled);
FOnPaintCell(ACanvas, R, c, FCurrentIndex, FState, FTStyle, Handled);
csCorel:
if FColCount = 1 then
FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled)
FOnPaintCell(ACanvas, R, c, FCurrentIndex, FState, FTStyle, Handled)
else
FOnPaintCell(FTempBmp.Canvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled);
FOnPaintCell(ACanvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), c,
FCurrentIndex, FState, FTStyle, Handled);
end;
if not Handled then
begin
// if standard colors draw the rect
c := mbStringToColor(clr);
if not SameText(clr, 'clCustom') and not SameText(clr, 'clTransparent') then
if not SameText(AColor, 'clCustom') and not SameText(AColor, 'clTransparent') then
case FCellStyle of
csDefault:
begin
InflateRect(R, -3, -3);
if Enabled then
begin
FTempBmp.Canvas.Brush.Color := c;
FTempBmp.Canvas.Pen.Color := clBtnShadow;
ACanvas.Brush.Color := c;
ACanvas.Pen.Color := clBtnShadow;
end
else
begin
FTempBmp.Canvas.Brush.Color := clGray;
FTempBmp.Canvas.Pen.Color := clGray;
ACanvas.Brush.Color := clGray;
ACanvas.Pen.Color := clGray;
end;
FTempBmp.Canvas.Rectangle(R);
ACanvas.Rectangle(R);
Exit;
end;
@ -429,17 +457,17 @@ begin
Dec(R.Right);
end;
if Enabled then
FTempBmp.Canvas.Brush.Color := c
ACanvas.Brush.Color := c
else
FTempBmp.Canvas.Brush.Color := clGray;
FTempBmp.Canvas.FillRect(R);
ACanvas.Brush.Color := clGray;
ACanvas.FillRect(R);
Exit;
end;
end;
//if transparent draw the glyph
if SameText(clr, 'clTransparent') then
PaintTransparentGlyph(FTempBmp.Canvas, R);
if SameText(AColor, 'clTransparent') then
PaintTransparentGlyph(ACanvas, R);
end;
end;
@ -454,8 +482,8 @@ begin
with ThemeServices do
if Enabled then
case FState of
ccsNone: ;
//ccsNone: ACanvas.CopyRect(R, PBack.Canvas, R);
ccsNone: ; //PaintParentBack(ACanvas, R);
// 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);
@ -586,6 +614,7 @@ begin
else if FColCount > 1 then
Inc(R.Right);
end;
with ACanvas do
case FTStyle of
tsPhotoshop:
@ -660,7 +689,7 @@ end;
procedure TmbColorPalette.Resize;
begin
inherited;
//CalcAutoHeight; // wp: will cause a ChangedBounds endless loop
CalcAutoHeight; // wp: will cause a ChangedBounds endless loop
Invalidate;
end;

17
components/mbColorLib/mbutils.pas
View File

@ -15,8 +15,12 @@ function PtInCircle(p, ctr: TPoint; Radius: Integer): Boolean;
function HighContrastColor(AColor: TColor): TColor;
function HeightOf(R: TRect): Integer;
function WidthOf(R: TRect): Integer;
function HeightOfRect(R: TRect): Integer;
function WidthOfRect(R: TRect): Integer;
function IsEmptyRect(R: TRect): Boolean;
const
EMPTY_RECT: TRect = (Left: -1; Top: -1; Right: -1; Bottom: -1);
implementation
@ -53,16 +57,21 @@ begin
Result := sqr(p.x - ctr.x) + sqr(p.y - ctr.y) <= sqr(Radius);
end;
function HeightOf(R: TRect): Integer;
function HeightOfRect(R: TRect): Integer;
begin
Result := R.Bottom - R.Top;
end;
function WidthOf(R: TRect): Integer;
function WidthOfRect(R: TRect): Integer;
begin
Result := R.Right - R.Left;
end;
function IsEmptyRect(R: TRect): Boolean;
begin
Result := (R.Left = -1) and (R.Top = -1) and (R.Right = -1) and (R.Bottom = -1);
end;
function HighContrastColor(AColor: TColor): TColor;
begin
if GetRValue(AColor) + GetGValue(AColor) + GetBValue(AColor) > 3*128 then