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

mbColorLib: several bug fixes. Refactoring of gradient painting.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5456 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-09 23:47:46 +00:00
parent 49d960779c
commit b8a19cf29b
29 changed files with 3053 additions and 2819 deletions
Download Patch File Download Diff File Expand all files Collapse all files

96
components/mbColorLib/BColorPicker.pas
View File

@@ -13,30 +13,29 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors, Scanlines;
mbTrackBarPicker, HTMLColors;
type
{ TBColorPicker }
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 GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Red: integer read FRed write SetRed default 122;
property Green: integer read FGreen write SetGreen default 122;
@@ -63,11 +62,13 @@ end;
constructor TBColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(12, 256);
FGradientWidth := 256;
FGradientHeight := 12;
SetInitialBounds(0, 0, 22, 268);
{
Width := 22;
Height := 268;
}
Layout := lyVertical;
FRed := 122;
FGreen := 122;
@@ -80,18 +81,7 @@ begin
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;
@@ -130,6 +120,11 @@ begin
row[j] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, FGreen, 255-i)));
end;
end;
end; *)
function TBColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(FRed, FGreen, AValue);
end;
procedure TBColorPicker.SetRed(r: integer);
@@ -140,10 +135,9 @@ begin
begin
FRed := r;
FManual := false;
CreateBGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -155,10 +149,9 @@ begin
begin
FGreen := g;
FManual := false;
CreateBGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -172,8 +165,7 @@ begin
FArrowPos := ArrowPosFromBlue(b);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -242,22 +234,36 @@ 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;
TBA_Resize:
SetBlue(FBlue);
TBA_MouseMove:
FBlue := BlueFromArrowPos(FArrowPos);
TBA_MouseDown:
FBlue := BlueFromArrowPos(FArrowPos);
TBA_MouseUp:
FBlue := BlueFromArrowPos(FArrowPos);
TBA_WheelUp:
SetBlue(FBlue + Increment);
TBA_WheelDown:
SetBlue(FBlue - Increment);
TBA_VKRight:
SetBlue(FBlue + Increment);
TBA_VKCtrlRight:
SetBlue(255);
TBA_VKLeft:
SetBlue(FBlue - Increment);
TBA_VKCtrlLeft:
SetBlue(0);
TBA_VKUp:
SetBlue(FBlue + Increment);
TBA_VKCtrlUp:
SetBlue(255);
TBA_VKDown:
SetBlue(FBlue - Increment);
TBA_VKCtrlDown:
SetBlue(0);
else
inherited;
end;
end;

103
components/mbColorLib/CColorPicker.pas
View File

@@ -8,36 +8,32 @@ interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
LCLIntf, LCLType,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines;
RGBCMYKUtils, mbTrackBarPicker, HTMLColors;
type
TCColorPicker = class(TmbTrackBarPicker)
private
FCyan, FMagenta, FYellow, FBlack: integer;
FCBmp: TBitmap;
function ArrowPosFromCyan(c: integer): integer;
function CyanFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateCGradient;
procedure SetCyan(c: integer);
procedure SetMagenta(m: integer);
procedure SetYellow(y: integer);
procedure SetBlack(k: integer);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; 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;
@@ -65,11 +61,11 @@ end;
constructor TCColorPicker.Create(AOwner: TComponent);
begin
inherited;
FCBmp := TBitmap.Create;
FCBmp.PixelFormat := pf32bit;
FCBmp.SetSize(12, 255);
Width := 22;
Height := 267;
FGradientWidth := 256;
FGradientHeight := 12;
SetInitialBounds(0, 0, 22, 267);
//Width := 22;
//Height := 267;
Layout := lyVertical;
FCyan := 255;
FMagenta := 0;
@@ -83,18 +79,7 @@ begin
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;
@@ -134,6 +119,12 @@ begin
end;
end;
end;
*)
function TCColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(AValue, FMagenta, FYellow, FBlack);
end;
procedure TCColorPicker.SetCyan(C: integer);
begin
@@ -145,8 +136,7 @@ begin
FArrowPos := ArrowPosFromCyan(c);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -158,10 +148,9 @@ begin
begin
FMagenta := m;
FManual := false;
CreateCGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -173,10 +162,9 @@ begin
begin
FYellow := y;
FManual := false;
CreateCGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -188,10 +176,9 @@ begin
begin
FBlack := k;
FManual := false;
CreateCGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -264,22 +251,36 @@ 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;
TBA_Resize:
SetCyan(FCyan);
TBA_MouseMove:
FCyan := CyanFromArrowPos(FArrowPos);
TBA_MouseDown:
FCyan := CyanFromArrowPos(FArrowPos);
TBA_MouseUp:
FCyan := CyanFromArrowPos(FArrowPos);
TBA_WheelUp:
SetCyan(FCyan + Increment);
TBA_WheelDown:
SetCyan(FCyan - Increment);
TBA_VKRight:
SetCyan(FCyan + Increment);
TBA_VKCtrlRight:
SetCyan(255);
TBA_VKLeft:
SetCyan(FCyan - Increment);
TBA_VKCtrlLeft:
SetCyan(0);
TBA_VKUp:
SetCyan(FCyan + Increment);
TBA_VKCtrlUp:
SetCyan(255);
TBA_VKDown:
SetCyan(FCyan - Increment);
TBA_VKCtrlDown:
SetCyan(0);
else
inherited;
end;
end;

7
components/mbColorLib/Demo/Demo.lpi
View File

@@ -58,13 +58,6 @@
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">

278
components/mbColorLib/Demo/main.lfm
View File

@@ -1,64 +1,61 @@
object Form1: TForm1
Left = 222
Height = 338
Top = 89
Width = 541
Left = 255
Height = 344
Top = 107
Width = 543
Caption = 'mbColor Lib v2.0.1 Demo'
ClientHeight = 338
ClientWidth = 541
Color = clBtnFace
ClientHeight = 344
ClientWidth = 543
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Shell Dlg 2'
OnCreate = FormCreate
ShowHint = True
LCLVersion = '1.7'
object Label1: TLabel
Left = 412
Height = 13
Height = 15
Top = 8
Width = 66
Width = 73
Anchors = [akTop, akRight]
Caption = 'SelectedColor'
ParentColor = False
end
object Label2: TLabel
Left = 410
Height = 13
Left = 412
Height = 15
Top = 112
Width = 86
Width = 96
Anchors = [akTop, akRight]
Caption = 'ColorUnderCursor'
ParentColor = False
end
object Label5: TLabel
Left = 410
Height = 65
Left = 412
Height = 75
Top = 238
Width = 92
Width = 99
Anchors = [akTop, akRight]
Caption = 'Aditional controls:'#13#13'- Arrow keys'#13'- Ctrl + Arrow keys'#13'- Mouse wheel'
ParentColor = False
end
object PageControl1: TPageControl
Left = 6
Height = 325
Height = 331
Top = 6
Width = 397
ActivePage = TabSheet8
Width = 399
ActivePage = TabSheet11
Anchors = [akTop, akLeft, akRight, akBottom]
TabIndex = 8
TabIndex = 6
TabOrder = 0
object TabSheet1: TTabSheet
Caption = 'HSLColorPicker'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 303
ClientWidth = 391
object HSLColorPicker1: THSLColorPicker
Left = 8
Height = 283
Height = 287
Top = 8
Width = 375
SelectedColor = 639239
Width = 377
SelectedColor = 562183
HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex'
LPickerHintFormat = 'Luminance: %l'
Anchors = [akTop, akLeft, akRight, akBottom]
@@ -69,23 +66,24 @@ object Form1: TForm1
end
object TabSheet2: TTabSheet
Caption = 'HexaColorPicker'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 303
ClientWidth = 391
ImageIndex = 1
object Label4: TLabel
Left = 82
Height = 13
Top = 278
Width = 37
Anchors = [akLeft, akBottom]
AnchorSideTop.Control = ComboBox1
AnchorSideTop.Side = asrCenter
Left = 112
Height = 15
Top = 282
Width = 40
Caption = 'Marker:'
ParentColor = False
end
object HexaColorPicker1: THexaColorPicker
Left = 48
Height = 267
Height = 271
Top = 4
Width = 283
Width = 285
Anchors = [akTop, akLeft, akRight, akBottom]
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h'
IntensityText = 'Intensity'
@@ -96,11 +94,12 @@ object Form1: TForm1
OnMouseMove = HexaColorPicker1MouseMove
end
object CheckBox1: TCheckBox
AnchorSideTop.Control = ComboBox1
AnchorSideTop.Side = asrCenter
Left = 4
Height = 17
Top = 274
Width = 75
Anchors = [akLeft, akBottom]
Height = 19
Top = 280
Width = 83
Caption = 'SliderVisible'
Checked = True
OnClick = CheckBox1Click
@@ -108,12 +107,12 @@ object Form1: TForm1
TabOrder = 1
end
object ComboBox1: TComboBox
Left = 124
Height = 21
Top = 274
Left = 160
Height = 23
Top = 278
Width = 71
Anchors = [akLeft, akBottom]
ItemHeight = 13
ItemHeight = 15
ItemIndex = 0
Items.Strings = (
'smArrow'
@@ -125,11 +124,13 @@ object Form1: TForm1
Text = 'smArrow'
end
object CheckBox2: TCheckBox
Left = 200
Height = 17
Top = 276
Width = 97
Anchors = [akLeft, akBottom]
AnchorSideTop.Control = ComboBox1
AnchorSideTop.Side = asrCenter
Left = 256
Height = 20
Top = 279
Width = 101
Anchors = [akTop, akLeft, akBottom]
Caption = 'NewArrowStyle'
OnClick = CheckBox2Click
TabOrder = 3
@@ -137,40 +138,43 @@ object Form1: TForm1
end
object TabSheet3: TTabSheet
Caption = 'mbColorPalette'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 303
ClientWidth = 391
ImageIndex = 2
object Label3: TLabel
AnchorSideTop.Control = ComboBox2
AnchorSideTop.Side = asrCenter
Left = 6
Height = 13
Height = 15
Top = 272
Width = 24
Anchors = [akLeft, akBottom]
Caption = 'Sort:'
ParentColor = False
end
object Label6: TLabel
Left = 214
Height = 13
AnchorSideTop.Control = ComboBox4
AnchorSideTop.Side = asrCenter
Left = 224
Height = 15
Top = 272
Width = 28
Anchors = [akLeft, akBottom]
Caption = 'Style:'
ParentColor = False
end
object Label7: TLabel
Left = 320
Height = 13
AnchorSideTop.Control = UpDown1
AnchorSideTop.Side = asrCenter
Left = 336
Height = 15
Top = 272
Width = 23
Anchors = [akLeft, akBottom]
Caption = 'Size:'
ParentColor = False
end
object Button1: TButton
Left = 6
Height = 25
Top = 232
Top = 236
Width = 107
Anchors = [akLeft, akBottom]
Caption = 'Generate blue pal'
@@ -180,7 +184,7 @@ object Form1: TForm1
object Button2: TButton
Left = 120
Height = 25
Top = 232
Top = 236
Width = 135
Anchors = [akLeft, akBottom]
Caption = 'Generate gradient pal'
@@ -190,7 +194,7 @@ object Form1: TForm1
object Button4: TButton
Left = 262
Height = 25
Top = 232
Top = 236
Width = 121
Anchors = [akLeft, akBottom]
Caption = 'Load palette from file'
@@ -199,15 +203,15 @@ object Form1: TForm1
end
object ScrollBox1: TScrollBox
Left = 6
Height = 217
Height = 221
Top = 8
Width = 379
Width = 381
HorzScrollBar.Page = 75
VertScrollBar.Page = 217
VertScrollBar.Page = 221
Anchors = [akTop, akLeft, akRight, akBottom]
BorderStyle = bsNone
ClientHeight = 217
ClientWidth = 362
ClientHeight = 221
ClientWidth = 364
TabOrder = 3
object mbColorPalette1: TmbColorPalette
Left = 0
@@ -482,11 +486,11 @@ object Form1: TForm1
end
object ComboBox2: TComboBox
Left = 34
Height = 21
Top = 266
Height = 23
Top = 268
Width = 87
Anchors = [akLeft, akBottom]
ItemHeight = 13
ItemHeight = 15
ItemIndex = 0
Items.Strings = (
'soAscending'
@@ -499,11 +503,11 @@ object Form1: TForm1
end
object ComboBox3: TComboBox
Left = 124
Height = 21
Top = 266
Height = 23
Top = 268
Width = 87
Anchors = [akLeft, akBottom]
ItemHeight = 13
ItemHeight = 15
ItemIndex = 7
Items.Strings = (
'smRed'
@@ -531,12 +535,12 @@ object Form1: TForm1
Text = 'smNone'
end
object ComboBox4: TComboBox
Left = 244
Height = 21
Top = 266
Left = 256
Height = 23
Top = 268
Width = 71
Anchors = [akLeft, akBottom]
ItemHeight = 13
ItemHeight = 15
ItemIndex = 0
Items.Strings = (
'csDefault'
@@ -548,10 +552,10 @@ object Form1: TForm1
Text = 'csDefault'
end
object UpDown1: TUpDown
Left = 348
Height = 21
Top = 266
Width = 31
Left = 364
Height = 23
Top = 268
Width = 15
Anchors = [akLeft, akBottom]
Min = 0
OnChanging = UpDown1Changing
@@ -563,14 +567,14 @@ object Form1: TForm1
end
object TabSheet4: TTabSheet
Caption = 'HSLRingPicker'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 303
ClientWidth = 391
ImageIndex = 3
object HSLRingPicker1: THSLRingPicker
Left = 50
Height = 285
Height = 289
Top = 6
Width = 291
Width = 293
RingPickerHintFormat = 'Hue: %h'
SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex'
Anchors = [akTop, akLeft, akRight, akBottom]
@@ -581,8 +585,8 @@ object Form1: TForm1
end
object TabSheet5: TTabSheet
Caption = 'HSVColorPicker'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 299
ClientWidth = 389
ImageIndex = 4
object HSVColorPicker1: THSVColorPicker
Left = 24
@@ -610,11 +614,11 @@ object Form1: TForm1
end
object TabSheet6: TTabSheet
Caption = 'SLHColorPicker'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 299
ClientWidth = 389
ImageIndex = 5
object SLHColorPicker1: TSLHColorPicker
Left = 6
Left = 5
Height = 287
Top = 6
Width = 379
@@ -628,8 +632,8 @@ object Form1: TForm1
end
object TabSheet11: TTabSheet
Caption = 'Lists && Trees'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 303
ClientWidth = 391
ImageIndex = 10
object mbColorList1: TmbColorList
Left = 192
@@ -661,14 +665,14 @@ object Form1: TForm1
end
object TabSheet7: TTabSheet
Caption = 'More'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 303
ClientWidth = 391
ImageIndex = 6
object Label9: TLabel
Left = 118
Height = 13
Left = 128
Height = 15
Top = 8
Width = 103
Width = 113
Caption = 'HintFormat variables:'
ParentColor = False
end
@@ -676,7 +680,7 @@ object Form1: TForm1
Left = 8
Height = 25
Top = 8
Width = 93
Width = 104
Caption = 'Pick from screen'
TabOrder = 0
OnSelColorChange = mbDeskPickerButton1SelColorChange
@@ -686,19 +690,20 @@ object Form1: TForm1
Left = 8
Height = 25
Top = 40
Width = 93
Width = 104
Caption = 'OfficeColorDialog'
OnClick = Button3Click
TabOrder = 1
end
object LColorPicker1: TLColorPicker
Left = 36
Left = 34
Height = 25
Top = 148
Width = 329
Top = 192
Width = 343
HintFormat = 'Luminance: %l'
Layout = lyHorizontal
SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 2
Saturation = 238
Luminance = 60
@@ -707,13 +712,14 @@ object Form1: TForm1
object VColorPicker1: TVColorPicker
Left = 34
Height = 21
Top = 116
Width = 335
Top = 160
Width = 343
HintFormat = 'Value: %v'
Layout = lyHorizontal
ArrowPlacement = spBefore
NewArrowStyle = True
SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 3
Hue = 240
Saturation = 255
@@ -721,21 +727,22 @@ object Form1: TForm1
SelectedColor = 2621440
end
object HColorPicker1: THColorPicker
Left = 36
Left = 34
Height = 61
Top = 178
Width = 335
Top = 231
Width = 343
HintFormat = 'Hue: %h'
Increment = 5
ArrowPlacement = spBoth
SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 4
Saturation = 120
SelectedColor = 8882175
end
object SColorPicker1: TSColorPicker
Left = 8
Height = 214
Height = 222
Top = 70
Width = 19
HintFormat = 'Saturation: %s'
@@ -743,19 +750,20 @@ object Form1: TForm1
ArrowPlacement = spBefore
NewArrowStyle = True
SelectionIndicator = siRect
Anchors = [akTop, akLeft, akBottom]
TabOrder = 5
Hue = 60
Saturation = 80
SelectedColor = 11534335
end
object Memo1: TMemo
Left = 118
Height = 75
Top = 24
Width = 247
Left = 128
Height = 118
Top = 26
Width = 249
Anchors = [akTop, akLeft, akRight, akBottom]
Lines.Strings = (
'The following variables will be replaced in the '
'hint at runtime:'
'The following variables will be replaced in the hint at runtime:'
''
'%hex = HTML HEX color value'
''
@@ -797,8 +805,8 @@ object Form1: TForm1
end
object TabSheet8: TTabSheet
Caption = 'Other'
ClientHeight = 299
ClientWidth = 389
ClientHeight = 292
ClientWidth = 372
ImageIndex = 7
object HSColorPicker1: THSColorPicker
Left = 6
@@ -837,14 +845,14 @@ object Form1: TForm1
end
object TabSheet9: TTabSheet
Caption = 'Even more'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 292
ClientWidth = 372
ImageIndex = 8
object Label8: TLabel
Left = 6
Height = 13
Height = 15
Top = 4
Width = 128
Width = 136
Caption = 'New: border styles added.'
ParentColor = False
end
@@ -870,7 +878,7 @@ object Form1: TForm1
object YColorPicker1: TYColorPicker
Left = 68
Height = 267
Top = 18
Top = 19
Width = 31
HintFormat = 'Yellow: %y'
ArrowPlacement = spBoth
@@ -983,8 +991,8 @@ object Form1: TForm1
end
object TabSheet10: TTabSheet
Caption = 'Yet even more'
ClientHeight = 0
ClientWidth = 0
ClientHeight = 299
ClientWidth = 389
ImageIndex = 9
object RAxisColorPicker1: TRAxisColorPicker
Left = 10
@@ -1052,15 +1060,15 @@ object Form1: TForm1
end
end
object sc: TmbColorPreview
Left = 410
Left = 412
Height = 62
Top = 24
Top = 25
Width = 108
Color = clNone
Anchors = [akTop, akRight]
end
object uc: TmbColorPreview
Left = 410
Left = 412
Height = 62
Top = 130
Width = 108
@@ -1068,7 +1076,7 @@ object Form1: TForm1
Anchors = [akTop, akRight]
end
object tb1: TTrackBar
Left = 410
Left = 412
Height = 20
Hint = 'Opacity'
Top = 90
@@ -1081,7 +1089,7 @@ object Form1: TForm1
TabOrder = 3
end
object tb2: TTrackBar
Left = 410
Left = 412
Height = 20
Top = 196
Width = 108
@@ -1093,20 +1101,20 @@ object Form1: TForm1
TabOrder = 4
end
object CheckBox3: TCheckBox
Left = 443
Left = 412
Height = 19
Top = 308
Width = 64
Top = 320
Width = 66
Anchors = [akTop, akRight]
Caption = 'WebSafe'
OnClick = CheckBox3Click
TabOrder = 5
end
object CheckBox4: TCheckBox
Left = 428
Left = 412
Height = 19
Top = 218
Width = 79
Width = 83
Anchors = [akTop, akRight]
Caption = 'SwatchStyle'
OnClick = CheckBox4Click
@@ -1114,12 +1122,12 @@ object Form1: TForm1
end
object mbOfficeColorDialog1: TmbOfficeColorDialog
UseHints = True
left = 472
top = 302
left = 448
top = 136
end
object OpenDialog1: TOpenDialog
Filter = 'JASC PAL (*.pal)|*.pal|Photoshop (*.act; *.aco)|*.act;*.aco'
left = 440
top = 304
top = 40
end
end

96
components/mbColorLib/GColorPicker.pas
View File

@@ -11,30 +11,26 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors, Scanlines;
mbTrackBarPicker, HTMLColors;
type
TGColorPicker = class(TmbTrackBarPicker)
private
FRed, FGreen, FBlue: integer;
FBmp: TBitmap;
function ArrowPosFromGreen(g: integer): integer;
function GreenFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateGGradient;
procedure SetRed(r: integer);
procedure SetGreen(g: integer);
procedure SetBlue(b: integer);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Red: integer read FRed write SetRed default 122;
property Green: integer read FGreen write SetGreen default 255;
@@ -61,11 +57,11 @@ end;
constructor TGColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(12, 256);
Width := 22;
Height := 268;
FGradientWidth := 256;
FGradientHeight := 12;
SetInitialBounds(0, 0, 22, 268);
//Width := 22;
//Height := 268;
Layout := lyVertical;
FRed := 122;
FGreen := 255;
@@ -78,18 +74,7 @@ begin
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;
@@ -131,6 +116,12 @@ begin
end;
end;
end;
*)
function TGColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(FRed, AValue, FBlue);
end;
procedure TGColorPicker.SetRed(r: integer);
begin
@@ -140,10 +131,9 @@ begin
begin
FRed := r;
FManual := false;
CreateGGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -157,8 +147,7 @@ begin
FArrowPos := ArrowPosFromGreen(g);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -170,10 +159,9 @@ begin
begin
FBlue := b;
FManual := false;
CreateGGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -242,22 +230,36 @@ 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;
TBA_Resize:
SetGreen(FGreen);
TBA_MouseMove:
FGreen := GreenFromArrowPos(FArrowPos);
TBA_MouseDown:
FGreen := GreenFromArrowPos(FArrowPos);
TBA_MouseUp:
FGreen := GreenFromArrowPos(FArrowPos);
TBA_WheelUp:
SetGreen(FGreen + Increment);
TBA_WheelDown:
SetGreen(FGreen - Increment);
TBA_VKRight:
SetGreen(FGreen + Increment);
TBA_VKCtrlRight:
SetGreen(255);
TBA_VKLeft:
SetGreen(FGreen - Increment);
TBA_VKCtrlLeft:
SetGreen(0);
TBA_VKUp:
SetGreen(FGreen + Increment);
TBA_VKCtrlUp:
SetGreen(255);
TBA_VKDown:
SetGreen(FGreen - Increment);
TBA_VKCtrlDown:
SetGreen(0);
else
inherited;
end;
end;

95
components/mbColorLib/HColorPicker.pas
View File

@@ -13,30 +13,26 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines;
RGBHSVUtils, mbTrackBarPicker, HTMLColors;
type
THColorPicker = class(TmbTrackBarPicker)
private
FVal, FSat, FHue: integer;
FHBmp: TBitmap;
function ArrowPosFromHue(h: integer): integer;
function HueFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateHGradient;
procedure SetHue(h: integer);
procedure SetSat(s: integer);
procedure SetValue(v: integer);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 255;
@@ -62,10 +58,11 @@ end;
constructor THColorPicker.Create(AOwner: TComponent);
begin
inherited;
FHBmp := TBitmap.Create;
FHBmp.PixelFormat := pf32bit;
Width := 267;
Height := 22;
FGradientWidth := 256;
FGradientHeight := 12;
SetInitialBounds(0, 0, 267, 22);
//Width := 267;
//Height := 22;
FSat := 255;
FVal := 255;
FArrowPos := ArrowPosFromHue(0);
@@ -76,18 +73,7 @@ begin
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;
@@ -129,6 +115,12 @@ begin
end;
end;
end;
*)
function THColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := HSVtoColor(AValue, FSat, FVal);
end;
procedure THColorPicker.SetValue(v: integer);
begin
@@ -138,10 +130,9 @@ begin
begin
FVal := v;
FManual := false;
CreateHGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -155,8 +146,7 @@ begin
FArrowPos := ArrowPosFromHue(h);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -168,10 +158,9 @@ begin
begin
FSat := s;
FManual := false;
CreateHGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -242,22 +231,36 @@ 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;
TBA_Resize:
SetHue(FHue);
TBA_MouseMove:
FHue := HueFromArrowPos(FArrowPos);
TBA_MouseDown:
FHue := HueFromArrowPos(FArrowPos);
TBA_MouseUp:
FHue := HueFromArrowPos(FArrowPos);
TBA_WheelUp:
SetHue(FHue + Increment);
TBA_WheelDown:
SetHue(FHue - Increment);
TBA_VKLeft:
SetHue(FHue - Increment);
TBA_VKCtrlLeft:
SetHue(0);
TBA_VKRight:
SetHue(FHue + Increment);
TBA_VKCtrlRight:
SetHue(360);
TBA_VKUp:
SetHue(FHue - Increment);
TBA_VKCtrlUp:
SetHue(0);
TBA_VKDown:
SetHue(FHue + Increment);
TBA_VKCtrlDown:
SetHue(360);
else
inherited;
end;
end;

79
components/mbColorLib/HRingPicker.pas
View File

@@ -75,6 +75,9 @@ implementation
{$IFDEF FPC}
{$R HRingPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@@ -118,47 +121,74 @@ procedure THRingPicker.CreateHSVCircle;
var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer;
row: pRGBQuadArray;
tc: TColor;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
if FBMP = nil then
if FBmp = nil then
begin
FBMP := TBitmap.Create;
FBMP.PixelFormat := pf32bit;
FBmp := 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);
FBmp.Width := size;
FBmp.Height := size;
PaintParentBack(FBmp);
radius := size div 2;
radiusSquared := radius * radius;
V := FValue;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
begin
Y := Size - 1 - j - Radius;
row := FBMP.Scanline[Size - 1 - j];
Y := Size - 1 - j - radius;
{$IFDEF FPC}
row := intfImg.GetDataLineStart(size - 1 - j);
{$ELSE}
row := FBmp.Scanline(size - 1 - j);
{$ENDIF}
for i := 0 to size - 1 do
begin
X := i - Radius;
X := i - radius;
dSquared := X*X + Y*Y;
if dSquared <= RadiusSquared then
if dSquared <= radiusSquared then
begin
if Radius <> 0 then
S := ROUND((255*SQRT(dSquared))/Radius)
S := round((255 * sqrt(dSquared)) / radius)
else
S := 0;
H := ROUND( 180 * (1 + ArcTan2(X, Y) / PI));
H := round( 180 * (1 + arctan2(X, Y) / PI)); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
tc := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc));
c := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
end
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end;
procedure THRingPicker.Resize;
@@ -269,18 +299,25 @@ procedure THRingPicker.Paint;
var
rgn, r1, r2: HRGN;
r: TRect;
size: Integer;
ringwidth: Integer;
begin
PaintParentBack(Canvas);
size := Min(Width, Height); // diameter of circle
ringwidth := size div 2 - FRadius; // FRadius is inner radius
r := ClientRect;
r.Right := R.Left + Min(Width, Height);
R.Bottom := R.Top + Min(Width, Height);
r.Right := R.Left + size;
R.Bottom := R.Top + size;
r1 := CreateEllipticRgnIndirect(R);
if ringwidth > 0 then
begin
rgn := r1;
InflateRect(R, - Min(Width, Height) + FRadius, - Min(Width, Height) + FRadius);
InflateRect(R, -ringwidth, - ringwidth);
r2 := CreateEllipticRgnIndirect(R);
CombineRgn(rgn, r1, r2, RGN_DIFF);
end;
SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FBMP);
Canvas.Draw(0, 0, FBmp);
DeleteObject(rgn);
DrawHueLine;
if FDoChange then

43
components/mbColorLib/HSColorPicker.pas
View File

@@ -10,10 +10,10 @@ uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
Windows, Messages, Scanlines,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines;
RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl;
type
THSColorPicker = class(TmbColorPickerControl)
@@ -66,6 +66,9 @@ implementation
{$IFDEF FPC}
{$R HSColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@@ -109,6 +112,7 @@ begin
CreateHSLGradient;
end;
{$IFDEF DELPHI}
procedure THSColorPicker.CreateHSLGradient;
var
Hue, Sat : integer;
@@ -133,6 +137,41 @@ begin
// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
end;
end;
{$ELSE}
procedure THSColorPicker.CreateHSLGradient;
var
Hue, Sat: Integer;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
c: TColor;
begin
if FHSLBmp = nil then
begin
FHSLBmp := TBitmap.Create;
FHSLBmp.PixelFormat := pf32Bit;
FHSLBmp.Width := 240;
FHSLBmp.Height := 241;
end;
intfimg := TLazIntfImage.Create(FHSLBmp.Width, FHSLBmp.Height);
try
intfImg.LoadFromBitmap(FHSLBmp.Handle, FHSLBmp.MaskHandle);
for Hue := 0 to 239 do
for Sat := 0 to 240 do
begin
if not WebSafe then
c := HSLRangeToRGB(Hue, Sat, 120)
else
c := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
intfimg.Colors[Hue, 240-Sat] := TColorToFPColor(c);
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSLBmp.Handle := imgHandle;
FHSLBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
end;
{$ENDIF}
procedure THSColorPicker.CorrectCoords(var x, y: integer);
begin

60
components/mbColorLib/HSLColorPicker.pas
View File

@@ -16,10 +16,10 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF}
RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors;
RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors, mbBasicPicker;
type
THSLColorPicker = class(TCustomControl)
THSLColorPicker = class(TmbBasicPicker)
private
FOnChange: TNotifyEvent;
FHSPicker: THSColorPicker;
@@ -48,14 +48,12 @@ type
procedure SetHSMenu(m: TPopupMenu);
procedure SetHSCursor(c: TCursor);
procedure SetLCursor(c: TCursor);
procedure PaintParentBack;
procedure SetSelectedColor(Value: TColor);
protected
procedure CreateWnd; override;
procedure Resize; override;
procedure Paint; override;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure PaintParentBack; override;
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
@@ -124,14 +122,14 @@ 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;
SetInitialBounds(0, 0, 206, 146);
//Width := 206;
//Height := 146;
TabStop := true;
FSelectedColor := clRed;
FHSPicker := THSColorPicker.Create(Self);
@@ -141,10 +139,13 @@ begin
FLCursor := crDefault;
with FHSPicker do
begin
SetInitialBounds(0, 6, 174, 134);
{
Height := 134;
Width := 174;
Top := 6;
Left := 0;
}
Anchors := [akLeft, akTop, akRight, akBottom];
Visible := true;
OnChange := HSPickerChange;
@@ -154,9 +155,12 @@ begin
InsertControl(FLPicker);
with FLPicker do
begin
SetInitialBounds(184, 0, 25, 146);
{
Height := 146;
Top := 0;
Left := 184;
}
Anchors := [akRight, akTop, akBottom];
Visible := true;
OnChange := LPickerChange;
@@ -328,11 +332,6 @@ begin
end;
procedure THSLColorPicker.PaintParentBack;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
var
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF} {$ENDIF}
begin
if PBack = nil then
begin
@@ -341,31 +340,22 @@ begin
end;
PBack.Width := Width;
PBack.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
PBack.Canvas.Brush.Color := clForm
else
{$ENDIF}
PBack.Canvas.Brush.Color := Color;
PBack.Canvas.FillRect(PBack.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, PBack.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF} {$ENDIF}
PaintParentBack(PBack);
end;
procedure THSLColorPicker.Resize;
begin
inherited;
PaintParentBack;
if (FHSPicker = nil) or (FLPicker = nil) then
exit;
FHSPicker.Width := Width - FLPicker.Width - 15;
FHSPicker.Height := Height - 12;
FLPicker.Left := Width - FLPicker.Width - 2;
FLPicker.Height := Height; // - 12;
end;
procedure THSLColorPicker.CreateWnd;
@@ -380,12 +370,6 @@ begin
Canvas.Draw(0, 0, PBack);
end;
procedure THSLColorPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF} );
begin
Message.Result := 1;
end;
procedure THSLColorPicker.SetSelectedColor(Value: TColor);
begin
if FSelectedColor <> Value then

71
components/mbColorLib/HSLRingPicker.pas
View File

@@ -16,10 +16,10 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus, Math,
{$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors;
RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors, mbBasicPicker;
type
THSLRingPicker = class(TCustomControl)
THSLRingPicker = class(TmbBasicPicker)
private
FOnChange: TNotifyEvent;
FRingPicker: THRingPicker;
@@ -46,7 +46,6 @@ type
procedure SetRingMenu(m: TPopupMenu);
procedure SetRingCursor(c: TCursor);
procedure SetSLCursor(c: TCursor);
procedure PaintParentBack;
protected
procedure CreateWnd; override;
procedure Paint; override;
@@ -56,10 +55,8 @@ type
procedure DoChange;
procedure Resize; override;
{$IFDEF DELPHI}
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
{$ELSE}
procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
{$ENDIF}
public
@@ -123,7 +120,6 @@ begin
inherited;
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
DoubleBuffered := true;
ParentColor := true;
PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
@@ -143,6 +139,7 @@ begin
Width := 246;
Top := 0;
Left := 0;
Radius := 100;
Align := alClient;
Visible := true;
Saturation := 255;
@@ -182,16 +179,33 @@ begin
end;
procedure THSLRingPicker.Resize;
var
circ: TPoint;
ctr: double;
begin
inherited;
if (FRingPicker = nil) or (FSLPicker = nil) then
exit;
ctr := Min(Width, Height)/100;
circ.x := Min(Width, Height) div 2;
circ.y := circ.x;
FRingPicker.Radius := circ.x - round(12*ctr);
FSLPicker.Left := circ.x - FSLPicker.Width div 2;
FSLPicker.Top := circ.y - FSLPicker.Height div 2;
FSLPicker.Width := round(50*ctr);
FSLPicker.Height := FSLPicker.Width;
(*
FRingPicker.Radius := (Min(Width, Height)*30) div 245;
FSLPicker.Left := (21*FRingPicker.Radius) div 10;
FSLPicker.Top := (21*FRingPicker.Radius) div 10;
FSLPicker.Width := 4*FRingPicker.Radius;
FSLPicker.Height := 4*FRingPicker.Radius;
PaintParentBack;
*)
PaintParentBack(PBack);
end;
procedure THSLRingPicker.RingPickerChange(Sender: TObject);
@@ -351,55 +365,16 @@ begin
Result := FRingPicker.Manual or FSLPicker.Manual;
end;
procedure THSLRingPicker.PaintParentBack;
var
MemDC: HDC;
OldBMP: HBITMAP;
begin
if PBack = nil then
begin
PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit;
end;
PBack.Width := Width;
PBack.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
PBack.Canvas.Brush.Color := clForm
else
{$ENDIF}
PBack.Canvas.Brush.Color := Color;
PBack.Canvas.FillRect(PBack.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, PBack.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF} {$ENDIF}
end;
procedure THSLRingPicker.Paint;
begin
PaintParentBack;
PaintParentBack(PBack);
Canvas.Draw(0, 0, PBack);
end;
procedure THSLRingPicker.CreateWnd;
begin
inherited;
PaintParentBack;
end;
procedure THSLRingPicker.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} );
begin
Message.Result := 1;
PaintParentBack(PBack);
end;
end.

59
components/mbColorLib/HSVColorPicker.pas
View File

@@ -85,6 +85,9 @@ implementation
{$IFDEF FPC}
{$R HSVColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@@ -153,28 +156,43 @@ end;
procedure THSVColorPicker.CreateHSVCircle;
var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer;
dSquared, H, S, V, i, j, radius, radiusSquared, x, y, size: integer;
row: pRGBQuadArray;
tc: TColor;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
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);
radius := size div 2;
radiusSquared := radius * radius;
V := FValue;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FHSVBmp.Width, FHSVBmp.Height);
try
intfImg.LoadFromBitmap(FHSVBmp.Handle, FHSVBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
begin
Y := Size - 1 - j - Radius;
row := FHSVBmp.Scanline[Size - 1 - j];
Y := size - 1 - j - Radius;
{$IFDEF FPC}
row := intfImg.GetDataLineStart(size - 1 - j);
{$ELSE}
row := FHSVBmp.Scanline(size - 1 - j);
{$ENDIF}
for i := 0 to size - 1 do
begin
X := i - Radius;
@@ -182,23 +200,40 @@ begin
if dSquared <= RadiusSquared then
begin
if Radius <> 0 then
S := ROUND((255*SQRT(dSquared))/Radius)
S := round(255.0 * sqrt(dSquared) / radius)
else
S := 0;
H := ROUND(180*(1 + ArcTan2(X, Y)/PI));
H := round(180 * (1 + arctan2(X, Y) / pi)); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
{$IFDEF FPC}
c := HSVtoColor(H, S, V);
if WebSafe then
c := GetWebSafe(c);
row^[i].rgbRed := GetRValue(c);
row^[i].rgbGreen := GetGValue(c);
row^[i].rgbBlue := GetBValue(c);
{$ELSE}
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
tc := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc));
c := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
end
{$ENDIF}
end;
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSVBmp.Handle := imgHandle;
FHSVBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end;
procedure THSVColorPicker.Resize;
begin

83
components/mbColorLib/HexaColorPicker.pas
View File

@@ -16,7 +16,7 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, StdCtrls, Forms,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math,
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils;
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker;
const
CustomCell = -2;
@@ -43,7 +43,7 @@ type
TSelectionMode = (smNone, smColor, smBW, smRamp);
THexaColorPicker = class(TCustomControl)
THexaColorPicker = class(TmbBasicPicker)
private
FIncrement: integer;
FSelectedCombIndex: integer;
@@ -60,7 +60,7 @@ type
FCenterColor: TRGBrec;
FCenterIntensity: Single;
FSliderWidth: integer;
FCustomIndex, // If FSelectedIndex contains CustomCell then this index shows
FCustomIndex: Integer; // If FSelectedIndex contains CustomCell then this index shows
// which index in the custom area has been selected.
// Positive values indicate the color comb and negative values
// indicate the B&W combs (complement). This value is offset with
@@ -84,7 +84,6 @@ type
procedure DrawAll;
procedure SetSelectedColor(const Value: TColor);
procedure DrawCombControls;
procedure PaintParentBack;
procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer);
procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF});
procedure CalculateCombLayout;
@@ -101,23 +100,25 @@ type
function GetNextCombIndex(i: integer): integer;
function GetPreviousCombIndex(i: integer): integer;
protected
procedure CreateWnd; override;
procedure Paint; override;
procedure Resize; override;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
procedure CMHintShow(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
message CM_HINTSHOW;
procedure WMLButtonDown(var Message: {$IFDEF FPC}TLMLButtonDown{$ELSE}TWMLButtonDown{$ENDIF});
message {$IFDEF FPC}LM_LBUTTONDOWN{$ELSE}WM_LBUTTONDOWN{$ENDIF};
procedure WMLButtonUp(var Message: {$IFDEF FPC}TLMLButtonUp{$ELSE}TWMLButtonUp{$ENDIF});
message {$IFDEF FPC}LM_LBUTTONUP{$ELSE}WM_LBUTTONUP{$ENDIF};
procedure WMMouseMove(var Message: {$IFDEF FPC}TLMMouseMove{$ELSE}TWMMouseMove{$ENDIF});
message {$IFDEF FPC}LM_MOUSEMOVE{$ELSE}WM_MOUSEMOVE{$ENDIF};
procedure Paint; override;
procedure CreateWnd; override;
procedure Resize; override;
{$IFDEF DELPHI}
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
{$ELSE}
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
@@ -145,12 +146,12 @@ type
property Visible;
property Enabled;
property PopupMenu;
property ParentColor default true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true;
{$ENDIF}{$ENDIF}
property TabOrder;
property Color;
property ParentColor;
property SliderWidth: integer read FSliderWidth write SetSliderWidth default 12;
property DragCursor;
property DragMode;
@@ -214,7 +215,6 @@ begin
FRadius := 90;
FSliderWidth := 12;
DoubleBuffered := true;
ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
@@ -453,47 +453,6 @@ begin
EnumerateCombs;
end;
procedure THexaColorPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
begin
Message.Result := 1;
end;
procedure THexaColorPicker.PaintParentBack;
var
OffScreen: TBitmap;
{$IFDEF DELPHI_7_UP}
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF}
begin
Offscreen := TBitmap.Create;
Offscreen.PixelFormat := pf32bit;
Offscreen.Width := Width;
Offscreen.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
Offscreen.Canvas.Brush.Color := clForm
else
{$ENDIF}
Offscreen.Canvas.Brush.Color := Color;
Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, OffScreen.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
Canvas.Draw(0, 0, Offscreen);
Offscreen.Free;
end;
procedure THexaColorPicker.Paint;
begin
PaintParentBack;

101
components/mbColorLib/KColorPicker.pas
View File

@@ -13,31 +13,27 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines;
RGBCMYKUtils, mbTrackBarPicker, HTMLColors;
type
TKColorPicker = class(TmbTrackBarPicker)
private
FCyan, FMagenta, FYellow, FBlack: integer;
FKBmp: TBitmap;
function ArrowPosFromBlack(k: integer): integer;
function BlackFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateKGradient;
procedure SetCyan(c: integer);
procedure SetMagenta(m: integer);
procedure SetYellow(y: integer);
procedure SetBlack(k: integer);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; 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;
@@ -65,11 +61,11 @@ end;
constructor TKColorPicker.Create(AOwner: TComponent);
begin
inherited;
FKBmp := TBitmap.Create;
FKBmp.PixelFormat := pf32bit;
FKBmp.SetSize(12, 255);
Width := 22;
Height := 267;
FGradientWidth := 256;
FGradientHeight := 12;
SetInitialBounds(0, 0, 22, 267);
//Width := 22;
//Height := 267;
Layout := lyVertical;
FCyan := 0;
FMagenta := 0;
@@ -83,18 +79,7 @@ begin
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;
@@ -138,6 +123,12 @@ begin
end;
end;
end;
*)
function TKColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(FCyan, FMagenta, FYellow, AValue);
end;
procedure TKColorPicker.SetBlack(k: integer);
begin
@@ -149,8 +140,7 @@ begin
FArrowPos := ArrowPosFromBlack(k);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -162,10 +152,9 @@ begin
begin
FMagenta := m;
FManual := false;
CreateKGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -177,10 +166,9 @@ begin
begin
FYellow := y;
FManual := false;
CreateKGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -192,10 +180,9 @@ begin
begin
FCyan := c;
FManual := false;
CreateKGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -268,22 +255,36 @@ 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;
TBA_Resize:
SetBlack(FBlack);
TBA_MouseMove:
FBlack := BlackFromArrowPos(FArrowPos);
TBA_MouseDown:
FBlack := BlackFromArrowPos(FArrowPos);
TBA_MouseUp:
FBlack := BlackFromArrowPos(FArrowPos);
TBA_WheelUp:
SetBlack(FBlack + Increment);
TBA_WheelDown:
SetBlack(FBlack - Increment);
TBA_VKRight:
SetBlack(FBlack + Increment);
TBA_VKCtrlRight:
SetBlack(255);
TBA_VKLeft:
SetBlack(FBlack - Increment);
TBA_VKCtrlLeft:
SetBlack(0);
TBA_VKUp:
SetBlack(FBlack + Increment);
TBA_VKCtrlUp:
SetBlack(255);
TBA_VKDown:
SetBlack(FBlack - Increment);
TBA_VKCtrlDown:
SetBlack(0);
else
inherited;
end;
end;

99
components/mbColorLib/LColorPicker.pas
View File

@@ -13,30 +13,26 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, HTMLColors, Scanlines;
RGBHSLUtils, mbTrackBarPicker, HTMLColors;
type
TLColorPicker = class(TmbTrackBarPicker)
private
FHue, FSat, FLuminance: integer;
FLBmp: TBitmap;
function ArrowPosFromLum(l: integer): integer;
function LumFromArrowPos(p: integer): integer;
procedure CreateLGradient;
procedure SetHue(h: integer);
procedure SetSat(s: integer);
procedure SetLuminance(l: integer);
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 240;
@@ -63,33 +59,20 @@ end;
constructor TLColorPicker.Create(AOwner: TComponent);
begin
inherited;
FLBmp := TBitmap.Create;
FLBmp.PixelFormat := pf32bit;
Width := 22;
Height := 252;
FGradientWidth := 256;
FGradientHeight := 12;
Layout := lyVertical;
FHue := 0;
FSat := MaxSat;
FArrowPos := ArrowPosFromLum(MaxLum div 2);
Fchange := false;
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;
@@ -133,6 +116,12 @@ begin
end;
end;
end;
*)
function TLColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := HSLRangeToRGB(FHue, FSat, AValue);
end;
procedure TLColorPicker.SetHue(h: integer);
begin
@@ -142,10 +131,9 @@ begin
begin
FHue := h;
FManual := false;
CreateLGradient;
CreateGradient;
Invalidate;
if Fchange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -157,10 +145,9 @@ begin
begin
FSat := s;
FManual := false;
CreateLGradient;
CreateGradient;
Invalidate;
if Fchange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -206,8 +193,7 @@ begin
FArrowPos := ArrowPosFromLum(l);
FManual := false;
Invalidate;
if Fchange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -234,10 +220,9 @@ begin
SetHue(h1);
SetSat(s1);
SetLuminance(l1);
Fchange := true;
FChange := true;
FManual := false;
if Fchange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
function TLColorPicker.GetArrowPos: integer;
@@ -248,22 +233,36 @@ 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;
TBA_Resize:
SetLuminance(FLuminance);
TBA_MouseMove:
FLuminance := LumFromArrowPos(FArrowPos);
TBA_MouseDown:
Fluminance := LumFromArrowPos(FArrowPos);
TBA_MouseUp:
Fluminance := LumFromArrowPos(FArrowPos);
TBA_WheelUp:
SetLuminance(FLuminance + Increment);
TBA_WheelDown:
SetLuminance(FLuminance - Increment);
TBA_VKRight:
SetLuminance(FLuminance + Increment);
TBA_VKCtrlRight:
SetLuminance(MaxLum);
TBA_VKLeft:
SetLuminance(FLuminance - Increment);
TBA_VKCtrlLeft:
SetLuminance(0);
TBA_VKUp:
SetLuminance(FLuminance + Increment);
TBA_VKCtrlUp:
SetLuminance(MaxLum);
TBA_VKDown:
SetLuminance(FLuminance - Increment);
TBA_VKCtrlDown:
SetLuminance(0);
else
inherited;
end;
end;

95
components/mbColorLib/MColorPicker.pas
View File

@@ -13,31 +13,27 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines;
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 GetGradientColor(AValue: Integer): TColor; 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;
@@ -65,9 +61,8 @@ end;
constructor TMColorPicker.Create(AOwner: TComponent);
begin
inherited;
FMBmp := TBitmap.Create;
FMBmp.PixelFormat := pf32bit;
FMBmp.SetSize(12, 255);
FGradientWidth := 256;
FGradientHeight := 12;
Width := 22;
Height := 267;
Layout := lyVertical;
@@ -83,18 +78,7 @@ begin
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;
@@ -138,6 +122,11 @@ begin
end;
end;
end;
*)
function TMColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(FCyan, AValue, FYellow, FBlack);
end;
procedure TMColorPicker.SetMagenta(m: integer);
begin
@@ -149,8 +138,7 @@ begin
FArrowPos := ArrowPosFromMagenta(m);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -162,10 +150,9 @@ begin
begin
FCyan := c;
FManual := false;
CreateMGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -177,10 +164,9 @@ begin
begin
FYellow := y;
FManual := false;
CreateMGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -192,10 +178,9 @@ begin
begin
FBlack := k;
FManual := false;
CreateMGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -268,22 +253,36 @@ 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;
TBA_Resize:
SetMagenta(FMagenta);
TBA_MouseMove:
FMagenta := MagentaFromArrowPos(FArrowPos);
TBA_MouseDown:
FMagenta := MagentaFromArrowPos(FArrowPos);
TBA_MouseUp:
FMagenta := MagentaFromArrowPos(FArrowPos);
TBA_WheelUp:
SetMagenta(FMagenta + Increment);
TBA_WheelDown:
SetMagenta(FMagenta - Increment);
TBA_VKRight:
SetMagenta(FMagenta + Increment);
TBA_VKCtrlRight:
SetMagenta(255);
TBA_VKLeft:
SetMagenta(FMagenta - Increment);
TBA_VKCtrlLeft:
SetMagenta(0);
TBA_VKUp:
SetMagenta(FMagenta + Increment);
TBA_VKCtrlUp:
SetMagenta(255);
TBA_VKDown:
SetMagenta(FMagenta - Increment);
TBA_VKCtrlDown:
SetMagenta(0);
else
inherited;
end;
end;

91
components/mbColorLib/RColorPicker.pas
View File

@@ -16,27 +16,26 @@ uses
mbTrackBarPicker, HTMLColors, Scanlines;
type
{ TRColorPicker }
TRColorPicker = class(TmbTrackBarPicker)
private
FRed, FGreen, FBlue: integer;
FBmp: TBitmap;
function ArrowPosFromRed(r: integer): integer;
function RedFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateRGradient;
procedure SetRed(r: integer);
procedure SetGreen(g: integer);
procedure SetBlue(b: integer);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Red: integer read FRed write SetRed default 255;
property Green: integer read FGreen write SetGreen default 122;
@@ -63,9 +62,8 @@ end;
constructor TRColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(12, 256);
FGradientWidth := 256;
FGradientHeight := 12;
Width := 22;
Height := 268;
Layout := lyVertical;
@@ -80,18 +78,7 @@ begin
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;
@@ -134,6 +121,11 @@ begin
// FBmp.Canvas.Pixels[j, i] := GetWebSafe(RGB(255-i, FGreen, FBlue));
end;
end;
end; *)
function TRColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(AValue, FGreen, FBlue);
end;
procedure TRColorPicker.SetRed(r: integer);
@@ -146,8 +138,7 @@ begin
FArrowPos := ArrowPosFromRed(r);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -159,10 +150,9 @@ begin
begin
FGreen := g;
FManual := false;
CreateRGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -174,10 +164,9 @@ begin
begin
FBlue := b;
FManual := false;
CreateRGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -246,22 +235,36 @@ 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;
TBA_Resize:
SetRed(FRed);
TBA_MouseMove:
FRed := RedFromArrowPos(FArrowPos);
TBA_MouseDown:
FRed := RedFromArrowPos(FArrowPos);
TBA_MouseUp:
FRed := RedFromArrowPos(FArrowPos);
TBA_WheelUp:
SetRed(FRed + Increment);
TBA_WheelDown:
SetRed(FRed - Increment);
TBA_VKRight:
SetRed(FRed + Increment);
TBA_VKCtrlRight:
SetRed(255);
TBA_VKLeft:
SetRed(FRed - Increment);
TBA_VKCtrlLeft:
SetRed(0);
TBA_VKUp:
SetRed(FRed + Increment);
TBA_VKCtrlUp:
SetRed(255);
TBA_VKDown:
SetRed(FRed - Increment);
TBA_VKCtrlDown:
SetRed(0);
else
inherited;
end;
end;

88
components/mbColorLib/SColorPicker.pas
View File

@@ -19,24 +19,20 @@ type
TSColorPicker = class(TmbTrackBarPicker)
private
FVal, FHue, FSat: integer;
FSBmp: TBitmap;
function ArrowPosFromSat(s: integer): integer;
function SatFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateSGradient;
procedure SetHue(h: integer);
procedure SetSat(s: integer);
procedure SetValue(v: integer);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 255;
@@ -62,8 +58,8 @@ end;
constructor TSColorPicker.Create(AOwner: TComponent);
begin
inherited;
FSBmp := TBitmap.Create;
FSBmp.PixelFormat := pf32bit;
FGradientWidth := 256;
FGradientHeight := 12;
Width := 267;
Height := 22;
FHue := 0;
@@ -76,18 +72,7 @@ begin
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;
@@ -131,6 +116,12 @@ begin
end;
end;
end;
*)
function TSColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := HSVtoColor(FHue, AValue, FVal);
end;
procedure TSColorPicker.SetValue(v: integer);
begin
@@ -140,10 +131,9 @@ begin
begin
FVal := v;
FManual := false;
CreateSGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -154,11 +144,10 @@ begin
if FHue <> h then
begin
FHue := h;
CreateSGradient;
CreateGradient;
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -172,8 +161,7 @@ begin
FManual := false;
FArrowPos := ArrowPosFromSat(s);
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -245,22 +233,36 @@ 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;
TBA_Resize:
SetSat(FSat);
TBA_MouseMove:
FSat := SatFromArrowPos(FArrowPos);
TBA_MouseDown:
FSat := SatFromArrowPos(FArrowPos);
TBA_MouseUp:
FSat := SatFromArrowPos(FArrowPos);
TBA_WheelUp:
SetSat(FSat + Increment);
TBA_WheelDown:
SetSat(FSat - Increment);
TBA_VKLeft:
SetSat(FSat - Increment);
TBA_VKCtrlLeft:
SetSat(0);
TBA_VKRight:
SetSat(FSat + Increment);
TBA_VKCtrlRight:
SetSat(255);
TBA_VKUp:
SetSat(FSat + Increment);
TBA_VKCtrlUp:
SetSat(255);
TBA_VKDown:
SetSat(FSat - Increment);
TBA_VKCtrlDown:
SetSat(0);
else
inherited;
end;
end;

84
components/mbColorLib/SLColorPicker.pas
View File

@@ -65,6 +65,9 @@ implementation
{$IFDEF FPC}
{$R SLColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@@ -96,35 +99,98 @@ begin
inherited;
end;
//{$IFDEF DELPHI}
procedure TSLColorPicker.CreateSLGradient;
var
x, y, skip: integer;
row: pRGBQuadArray;
tc: TColor;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
if FBMP = nil then
if FBmp = nil then
begin
FBMP := TBitmap.Create;
FBMP.PixelFormat := pf32bit;
FBMP.Width := 256;
FBMP.Height := 256;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
{$ENDIF}
{
row := FBMP.ScanLine[0];
skip := integer(FBMP.ScanLine[1]) - Integer(row);
}
for y := 0 to 255 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(y);
{$ELSE}
row := FHSVBmp.Scanline(y);
{$ENDIF}
for x := 0 to 255 do
if not WebSafe then
row[x] := HSLtoRGBQuad(FHue, x, 255 - y)
else
begin
tc := GetWebSafe(RGBTripleToTColor(HSLToRGBTriple(FHue, x, 255 - y)));
row[x] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc));
c := GetWebSafe(RGBTripleToTColor(HSLToRGBTriple(FHue, x, 255 - y)));
row[x] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
row := pRGBQuadArray(Integer(row) + skip);
// row := pRGBQuadArray(Integer(row) + skip);
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end;
(*
{$ELSE}
procedure TSLColorPicker.CreateSLGradient;
var
x, y: Integer;
c: TColor;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
begin
if FBmp = nil then
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32Bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
for y := 0 to 255 do // y = L
for x := 0 to 255 do // x = S
begin
c := HSLRangeToRGB(FHue, x, 255-y);
if WebSafe then
c := GetWebSafe(c);
intfImg.Colors[x, y] := TColorToFPColor(c);
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
end;
{$ENDIF}
*)
procedure TSLColorPicker.Resize;
begin
inherited;

70
components/mbColorLib/SLHColorPicker.pas
View File

@@ -16,10 +16,10 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors;
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, mbBasicPicker;
type
TSLHColorPicker = class(TCustomControl)
TSLHColorPicker = class(TmbBasicPicker)
private
FOnChange: TNotifyEvent;
FSLPicker: TSLColorPicker;
@@ -46,13 +46,11 @@ type
procedure SetHMenu(m: TPopupMenu);
procedure SetHCursor(c: TCursor);
procedure SetSLCursor(c: TCursor);
procedure PaintParentBack;
protected
procedure CreateWnd; override;
procedure Resize; override;
procedure Paint; override;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure PaintParentBack; override;
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
@@ -126,20 +124,26 @@ begin
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
Width := 297;
Height := 271;
SetInitialBounds(0, 0, 297, 271);
// Width := 297;
// Height := 271;
TabStop := true;
FSelectedColor := clRed;
FHPicker := THColorPicker.Create(Self);
InsertControl(FHPicker);
FHCursor := crDefault;
FSLCursor := crDefault;
// Hue picker
with FHPicker do
begin
SetInitialBounds(257, 0, 40, 271);
{
Height := 271;
Width := 40;
Top := 0;
Left := 257;
}
Anchors := [akTop, akRight, akBottom];
Visible := true;
Layout := lyVertical;
@@ -148,15 +152,20 @@ begin
OnChange := HPickerChange;
OnMouseMove := DoMouseMove;
end;
// Saturation-Lightness picker
FSLPicker := TSLColorPicker.Create(Self);
InsertControl(FSLPicker);
with FSLPicker do
begin
SetInitialBounds(0, 0, 255, 271);
{
Width := 255;
Height := 255;
Top := 8;
Height := 271; //255;
Top := 0; //8;
Left := 0;
Anchors := [akRight, akTop, akBottom, akLeft];
}
Anchors := [akLeft, akRight, akTop, akBottom];
Visible := true;
SelectedColor := clRed;
OnChange := SLPickerChange;
@@ -322,14 +331,20 @@ procedure TSLHColorPicker.Resize;
begin
inherited;
PaintParentBack;
if FSLPicker = nil then
exit;
if FHPicker = nil then
exit;
FSLPicker.Width := Width - FHPicker.Width - 10;
FSLPicker.Height := Height - 2;
FHPicker.Left := Width - FHPicker.Width - 2;
FHPicker.Height := Height - 2;
end;
procedure TSLHColorPicker.PaintParentBack;
{$IFDEF DELPHI_7_UP}
var
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF}
begin
if PBack = nil then
begin
@@ -338,24 +353,7 @@ begin
end;
PBack.Width := Width;
PBack.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
PBack.Canvas.Brush.Color := clForm else
{$ENDIF}
PBack.Canvas.Brush.Color := Color;
PBack.Canvas.FillRect(PBack.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, PBack.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
PaintParentBack(PBack);
end;
procedure TSLHColorPicker.Paint;
@@ -370,10 +368,4 @@ begin
PaintParentBack;
end;
procedure TSLHColorPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF} );
begin
Message.Result := 1;
end;
end.

7
components/mbColorLib/Scanlines.pas
View File

@@ -7,14 +7,17 @@ unit Scanlines;
interface
uses
{$IFDEF FPC}LCLIntf, LCLType,
{$ELSE}Windows,
{$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;

134
components/mbColorLib/VColorPicker.pas
View File

@@ -19,24 +19,24 @@ type
TVColorPicker = class(TmbTrackBarPicker)
private
FHue, FSat, FVal: integer;
FVBmp: TBitmap;
// FVBmp: TBitmap;
function ArrowPosFromVal(l: integer): integer;
function ValFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateVGradient;
// 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 GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// destructor Destroy; override;
published
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0;
@@ -51,6 +51,9 @@ implementation
{$IFDEF FPC}
{$R VColorPicker.dcr}
{uses
IntfGraphics, fpimage;}
{$ENDIF}
procedure Register;
@@ -63,11 +66,16 @@ end;
constructor TVColorPicker.Create(AOwner: TComponent);
begin
inherited;
FGradientWidth := 256;
FGradientHeight := 12;
{
FVBmp := TBitmap.Create;
FVBmp.PixelFormat := pf32bit;
FVBmp.SetSize(12, 255);
Width := 22;
Height := 267;
}
// Width := 22;
// Height := 267;
SetInitialBounds(0, 0, 22, 267);
Layout := lyVertical;
FHue := 0;
FSat := 0;
@@ -79,60 +87,9 @@ begin
FChange := true;
end;
destructor TVColorPicker.Destroy;
function TVColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
FVBmp.Free;
inherited Destroy;
end;
procedure TVColorPicker.CreateWnd;
begin
inherited;
CreateVGradient;
end;
procedure TVColorPicker.CreateVGradient;
var
i,j: integer;
row: pRGBQuadArray;
begin
if FVBmp = nil then
begin
FVBmp := TBitmap.Create;
FVBmp.PixelFormat := pf32bit;
end;
if Layout = lyHorizontal then
begin
FVBmp.width := 255;
FVBmp.height := 12;
for i := 0 to 254 do
for j := 0 to 11 do
begin
row := FVBmp.Scanline[j];
if not WebSafe then
row[i] := RGBToRGBQuad(HSVtoColor(FHue, FSat, i))
// FVBmp.Canvas.Pixels[i, j] := HSVtoColor(FHue, FSat, i)
else
row[i] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, FSat, i)));
// FVBmp.Canvas.Pixels[i, j] := GetWebSafe(HSVtoColor(FHue, FSat, i));
end;
end
else
begin
FVBmp.width := 12;
FVBmp.height := 255;
for i := 0 to 254 do
begin
row := FVBmp.ScanLine[i];
for j := 0 to 11 do
if not WebSafe then
row[j] := RGBToRGBQuad(HSVtoColor(FHue, FSat, 255 - i))
// FVBmp.Canvas.Pixels[j, i] := HSVtoColor(FHue, FSat, 255 - i)
else
row[j] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, FSat, 255 - i)));
// FVBmp.Canvas.Pixels[j, i] := GetWebSafe(HSVtoColor(FHue, FSat, 255 - i));
end;
end;
Result := HSVtoColor(FHue, FSat, AValue);
end;
procedure TVColorPicker.SetHue(h: integer);
@@ -143,10 +100,9 @@ begin
begin
FHue := h;
FManual := false;
CreateVGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -158,10 +114,9 @@ begin
begin
FSat := s;
FManual := false;
CreateVGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -207,8 +162,7 @@ begin
FArrowPos := ArrowPosFromVal(v);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -248,22 +202,36 @@ 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;
TBA_Resize:
SetValue(FVal);
TBA_MouseMove:
FVal := ValFromArrowPos(FArrowPos);
TBA_MouseDown:
FVal := ValFromArrowPos(FArrowPos);
TBA_MouseUp:
FVal := ValFromArrowPos(FArrowPos);
TBA_WheelUp:
SetValue(FVal + Increment);
TBA_WheelDown:
SetValue(FVal - Increment);
TBA_VKRight:
SetValue(FVal + Increment);
TBA_VKCtrlRight:
SetValue(255);
TBA_VKLeft:
SetValue(FVal - Increment);
TBA_VKCtrlLeft:
SetValue(0);
TBA_VKUp:
SetValue(FVal + Increment);
TBA_VKCtrlUp:
SetValue(255);
TBA_VKDown:
SetValue(FVal - Increment);
TBA_VKCtrlDown:
SetValue(0);
else
inherited;
end;
end;

92
components/mbColorLib/YColorPicker.pas
View File

@@ -19,25 +19,22 @@ type
TYColorPicker = class(TmbTrackBarPicker)
private
FYellow, FMagenta, FCyan, FBlack: integer;
FYBmp: TBitmap;
function ArrowPosFromYellow(y: integer): integer;
function YellowFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure CreateYGradient;
procedure SetYellow(y: integer);
procedure SetMagenta(m: integer);
procedure SetCyan(c: integer);
procedure SetBlack(k: integer);
protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Yellow: integer read FYellow write SetYellow default 255;
property Magenta: integer read FMagenta write SetMagenta default 0;
@@ -65,9 +62,8 @@ end;
constructor TYColorPicker.Create(AOwner: TComponent);
begin
inherited;
FYBmp := TBitmap.Create;
FYBmp.PixelFormat := pf32bit;
FYBmp.SetSize(12, 255);
FGradientWidth := 255;
FGradientHeight := 12;
Width := 22;
Height := 267;
Layout := lyVertical;
@@ -83,18 +79,8 @@ begin
FChange := true;
end;
destructor TYColorPicker.Destroy;
begin
FYBmp.Free;
inherited Destroy;
end;
procedure TYColorPicker.CreateWnd;
begin
inherited;
CreateYGradient;
end;
(*
procedure TYColorPicker.CreateYGradient;
var
i,j: integer;
@@ -138,6 +124,12 @@ begin
end;
end;
end;
*)
function TYColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(FCyan, FMagenta, AValue, FBlack);
end;
procedure TYColorPicker.SetYellow(y: integer);
begin
@@ -149,8 +141,7 @@ begin
FArrowPos := ArrowPosFromYellow(y);
FManual := false;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -162,10 +153,9 @@ begin
begin
FMagenta := m;
FManual := false;
CreateYGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -177,10 +167,9 @@ begin
begin
FCyan := c;
FManual := false;
CreateYGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -192,10 +181,9 @@ begin
begin
FBlack := k;
FManual := false;
CreateYGradient;
CreateGradient;
Invalidate;
if FChange then
if Assigned(OnChange) then OnChange(Self);
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
@@ -268,22 +256,36 @@ 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;
TBA_Resize:
SetYellow(FYellow);
TBA_MouseMove:
FYellow := YellowFromArrowPos(FArrowPos);
TBA_MouseDown:
FYellow := YellowFromArrowPos(FArrowPos);
TBA_MouseUp:
FYellow := YellowFromArrowPos(FArrowPos);
TBA_WheelUp:
SetYellow(FYellow + Increment);
TBA_WheelDown:
SetYellow(FYellow - Increment);
TBA_VKRight:
SetYellow(FYellow + Increment);
TBA_VKCtrlRight:
SetYellow(255);
TBA_VKLeft:
SetYellow(FYellow - Increment);
TBA_VKCtrlLeft:
SetYellow(0);
TBA_VKUp:
SetYellow(FYellow + Increment);
TBA_VKCtrlUp:
SetYellow(255);
TBA_VKDown:
SetYellow(FYellow - Increment);
TBA_VKCtrlDown:
SetYellow(0);
else
inherited;
end;
end;

111
components/mbColorLib/mbBasicPicker.pas Normal file
View File

@@ -0,0 +1,111 @@
unit mbBasicPicker;
{$mode objfpc}{$H+}
interface
uses
{$IFDEF FPC}
LMessages,
{$ELSE}
Messages,
{$ENDIF}
Classes, SysUtils, Graphics, Controls;
type
TmbBasicPicker = class(TCustomControl)
protected
procedure PaintParentBack; virtual; overload;
procedure PaintParentBack(ACanvas: TCanvas); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload;
{$IFDEF DELPHI}
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
{$ELSE}
procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED;
procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override;
published
property ParentColor default true;
end;
implementation
constructor TmbBasicPicker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle - [csOpaque];
ParentColor := true;
end;
procedure TmbBasicPicker.CMParentColorChanged(var Message: TLMessage);
begin
if ParentColor then
ControlStyle := ControlStyle - [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque];
inherited;
end;
function TmbBasicPicker.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor;
begin
result := inherited GetDefaultColor(DefaultColorType);
end;
procedure TmbBasicPicker.PaintParentBack;
begin
PaintParentBack(Canvas);
end;
procedure TmbBasicPicker.PaintParentBack(ABitmap: TBitmap);
begin
{$IFNDEF DELPHI}
if Color = clDefault then
ABitmap.Canvas.Brush.Color := GetDefaultColor(dctBrush)
else
{$ENDIF}
ABitmap.Canvas.Brush.Color := Color;
ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, ABitmap.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
end;
procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas);
var
OffScreen: TBitmap;
begin
Offscreen := TBitmap.Create;
try
Offscreen.PixelFormat := pf32bit;
Offscreen.Width := Width;
Offscreen.Height := Height;
PaintParentBack(Offscreen);
ACanvas.Draw(0, 0, Offscreen);
finally
Offscreen.Free;
end;
end;
procedure TmbBasicPicker.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} );
begin
inherited;
// Message.Result := 1;
end;
end.

115
components/mbColorLib/mbColorPalette.pas
View File

@@ -15,7 +15,7 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF}
Forms, HTMLColors, PalUtils, Dialogs;
Forms, HTMLColors, PalUtils, Dialogs, mbBasicPicker;
type
TMouseLoc = (mlNone, mlOver, mlDown);
@@ -28,7 +28,7 @@ type
TGetHintTextEvent = procedure (AColor: TColor; Index: integer; var HintStr: string; var Handled: boolean) of object;
TArrowKeyEvent = procedure (Key: Word; Shift: TShiftState) of object;
TmbColorPalette = class(TCustomControl)
TmbColorPalette = class(TmbBasicPicker)
private
FMouseLoc: TMouseLoc;
FMouseOver, FMouseDown, FAutoHeight: boolean;
@@ -77,13 +77,11 @@ type
procedure Click; override;
procedure Resize; override;
procedure SelectCell(i: integer);
procedure PaintParentBack;
procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
{$IFDEF DELPHI}
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
@@ -92,7 +90,6 @@ type
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
{$ELSE}
procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure CMMouseEnter(var Message: TLMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
@@ -101,6 +98,7 @@ type
procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
@@ -116,6 +114,7 @@ type
procedure SaveColorsAsPalette(FileName: TFileName);
procedure GeneratePalette(BaseColor: TColor);
procedure GenerateGradientPalette(Colors: array of TColor);
published
property Align;
property Anchors;
@@ -141,8 +140,6 @@ type
property TabOrder;
property ShowHint default false;
property Constraints;
property Color;
property ParentColor;
property ParentShowHint default true;
property PopupMenu;
property Visible;
@@ -193,6 +190,8 @@ begin
DoubleBuffered := true;
PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit;
FTempBmp := TBitmap.Create;
FTempBmp.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF} {$ENDIF}
@@ -230,6 +229,7 @@ end;
destructor TmbColorPalette.Destroy;
begin
PBack.Free;
FTempBmp.Free;
FNames.Free;
FColors.Free;
inherited Destroy;
@@ -266,7 +266,7 @@ begin
CalcAutoHeight;
Invalidate;
end;
(*
procedure TmbColorPalette.PaintParentBack;
{$IFDEF DELPHI_7_UP}
var
@@ -283,7 +283,7 @@ begin
PBack.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
PBack.Canvas.Brush.Color := clForm
PBack.Canvas.Brush.Color := GetDefaultColor(dctBrush)
else
{$ENDIF}
PBack.Canvas.Brush.Color := Color;
@@ -300,39 +300,26 @@ begin
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF} {$ENDIF}
end;
end; *)
procedure TmbColorPalette.Paint;
var
i: integer;
begin
PaintParentBack;
PBack.Width := Width;
PBack.Height := Height;
PaintParentBack(PBack);
//make bmp
FTempBmp := TBitmap.Create;
try
FTempBmp.PixelFormat := pf32bit;
FTempBmp.Width := Width;
FTempBmp.Height := Height;
PaintParentBack(FTempBmp);
{$IFDEF FPC}
if Color = clDefault then
FTempBmp.Canvas.Brush.Color := clForm
else
{$ENDIF}
FTempBmp.Canvas.Brush.Color := Color;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
if not ParentBackground then
{$ENDIF} {$ENDIF}
FTempBmp.Canvas.FillRect(FTempBmp.Canvas.ClipRect)
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
else
FTempBmp.Canvas.Draw(0, 0, PBack){$ENDIF} {$ENDIF};
FTotalCells := FColors.Count - 1;
//reset counters
FTotalCells := FColors.Count - 1;
FTop := 0;
FLeft := 0;
//draw the cells
for i := 0 to FColors.Count - 1 do
begin
@@ -340,9 +327,11 @@ begin
DrawCell(FColors.Strings[i]);
Inc(FLeft);
end;
//draw the result
//draw the bmp
Canvas.Draw(0, 0, FTempBmp);
//csDesiginng border
//csDesiging border
if csDesigning in ComponentState then
begin
Canvas.Brush.Style := bsClear;
@@ -352,9 +341,6 @@ begin
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Style := psSolid;
end;
finally
FTempBmp.Free;
end;
end;
procedure TmbColorPalette.DrawCell(clr: string);
@@ -365,21 +351,17 @@ var
Handled: boolean;
begin
// set props
if (FLeft + 1) * FCellSize > FTempBmp.width then
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
@@ -409,35 +391,38 @@ begin
Handled := false;
if Assigned(FOnPaintCell) then
case FCellStyle of
csDefault: FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled);
csDefault:
FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled);
csCorel:
if FColCount = 1 then
FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled)
else
FOnPaintCell(FTempBmp.Canvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled);
end;
if not Handled then
begin
// if standard colors draw the rect
c := mbStringToColor(clr);
if not SameText(clr, 'clCustom') and not SameText(clr, 'clTransparent') then
case FCellStyle of
csDefault:
begin
InflateRect(R, -3, -3);
c := mbStringToColor(clr);
if Enabled then
begin
Brush.Color := c;
Pen.Color := clBtnShadow;
FTempBmp.Canvas.Brush.Color := c;
FTempBmp.Canvas.Pen.Color := clBtnShadow;
end
else
begin
Brush.Color := clGray;
Pen.Color := clGray;
FTempBmp.Canvas.Brush.Color := clGray;
FTempBmp.Canvas.Pen.Color := clGray;
end;
Rectangle(R);
FTempBmp.Canvas.Rectangle(R);
Exit;
end;
csCorel:
begin
if (FState <> ccsNone) then
@@ -451,19 +436,18 @@ begin
if R.Right = Width then
Dec(R.Right);
end;
c := mbStringToColor(clr);
if Enabled then
Brush.Color := c
FTempBmp.Canvas.Brush.Color := c
else
Brush.Color := clGray;
FillRect(R);
FTempBmp.Canvas.Brush.Color := clGray;
FTempBmp.Canvas.FillRect(R);
Exit;
end;
end;
//if transparent draw the glyph
if SameText(clr, 'clTransparent') then PaintTransparentGlyph(FTempBmp.Canvas, R);
end;
if SameText(clr, 'clTransparent') then
PaintTransparentGlyph(FTempBmp.Canvas, R);
end;
end;
@@ -588,6 +572,10 @@ begin
else
{$ENDIF}
begin
{$IFDEF FPC}
if Color = clDefault then
ACanvas.Brush.Color := GetDefaultColor(dctBrush) else
{$ENDIF}
ACanvas.Brush.Color := Color;
ACanvas.FillRect(R);
end;
@@ -680,7 +668,7 @@ end;
procedure TmbColorPalette.Resize;
begin
inherited;
CalcAutoHeight;
//CalcAutoHeight; // wp: will cause a ChangedBounds endless loop
Invalidate;
end;
@@ -704,10 +692,13 @@ begin
end;
procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer);
var
newIndex: Integer;
begin
if FIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then
newIndex := (y div FCellSize) * FColCount + (x div FCellSize);
if FIndex <> newIndex then
begin
FIndex := (y div FCellSize)* FColCount + (x div FCellSize);
FIndex := newIndex;
if FIndex > FTotalCells then FIndex := -1;
Invalidate;
end;
@@ -786,12 +777,6 @@ begin
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

66
components/mbColorLib/mbColorPickerControl.pas
View File

@@ -16,39 +16,37 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes,{$ENDIF}
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors;
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker;
type
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
TmbCustomPicker = class(TCustomControl)
TmbCustomPicker = class(TmbBasicPicker)
private
FHintFormat: string;
FMarkerStyle: TMarkerStyle;
FWebSafe: boolean;
procedure SetMarkerStyle(s: TMarkerStyle);
procedure SetWebSafe(s: boolean);
protected
mx, my, mdx, mdy: integer;
function GetSelectedColor: TColor; virtual;
procedure SetSelectedColor(C: TColor); virtual;
procedure WebSafeChanged; dynamic;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC} LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure CMGotFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
message CM_ENTER;
procedure CMLostFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF});
message CM_EXIT;
procedure CMMouseLeave(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
message CM_MOUSELEAVE;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure PaintParentBack(ACanvas: TCanvas);
procedure CreateWnd; override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
{$IFDEF DELPHI}
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
{$ELSE}
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
{$ENDIF}
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
public
constructor Create(AOwner: TComponent); override;
@@ -112,7 +110,6 @@ begin
ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
DoubleBuffered := true;
TabStop := true;
ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
@@ -129,39 +126,6 @@ begin
inherited;
end;
procedure TmbCustomPicker.PaintParentBack(ACanvas: TCanvas);
var
OffScreen: TBitmap;
{$IFDEF DELPHI_7_UP}
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF}
begin
Offscreen := TBitmap.Create;
Offscreen.Width := Width;
Offscreen.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
Offscreen.Canvas.Brush.Color := clForm else
{$ENDIF}
Offscreen.Canvas.Brush.Color := Color;
Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, OffScreen.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
ACanvas.Draw(0, 0, Offscreen);
Offscreen.Free;
end;
procedure TmbCustomPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} );
begin
@@ -176,12 +140,6 @@ begin
Invalidate;
end;
procedure TmbCustomPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
begin
Message.Result := 1;
end;
procedure TmbCustomPicker.CMMouseLeave(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
begin

18
components/mbColorLib/mbColorTree.pas
View File

@@ -44,10 +44,10 @@ type
FGetHint: TGetHintEvent;
FOnStartDrag: TStartDragEvent;
FOnEndDrag: TEndDragEvent;
procedure SetInfo1(Value: string);
procedure SetInfo2(Value: string);
procedure SetInfoLabel(Value: string);
protected
function CanChange(Node: TTreeNode): Boolean; override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
@@ -59,6 +59,9 @@ type
procedure DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); dynamic;
procedure DrawInfoItem(R: TRect; Index: integer); dynamic;
procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
{$IFDEF FPC}
procedure WMHScroll(var Msg: TLMScroll); message LM_HSCROLL;
{$ENDIF}
public
Colors: array of TmbColor;
@@ -357,10 +360,11 @@ begin
if Selected then
Brush.Color := clHighlight
else
Brush.Color := clBtnFace;
Brush.Color := Color; //clBtnFace;
FillRect(R);
MoveTo(R.Left, R.Bottom - 1);
LineTo(R.Right, R.Bottom - 1);
//swatches
SR := Rect(R.Left + 6, R.Top + 6, R.Left + 42, R.Top + 42);
Brush.Color := Self.Colors[Index].value;
@@ -445,7 +449,9 @@ begin
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);
SetBkMode(Canvas.Handle, TRANSPARENT);
DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS);
SetBkMode(Canvas.Handle, OPAQUE);
if R.Right > 60 then
begin
if Expanded then
@@ -683,4 +689,12 @@ if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
inherited;
end;
{$IFDEF FPC}
procedure TmbColorTree.WMHScroll(var Msg: TLMScroll);
begin
inherited;
//Invalidate;
end;
{$ENDIF}
end.

269
components/mbColorLib/mbTrackBarPicker.pas
View File

@@ -13,7 +13,7 @@ uses
{$ELSE} Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils;
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils, mbBasicPicker;
const
TBA_Resize = 0;
@@ -38,7 +38,7 @@ type
TSliderPlacement = (spBefore, spAfter, spBoth);
TSelIndicator = (siArrows, siRect);
TmbTrackBarPicker = class(TCustomControl)
TmbTrackBarPicker = class(TmbBasicPicker)
private
mx, my: integer;
FOnChange: TNotifyEvent;
@@ -68,7 +68,6 @@ type
procedure SetPlacement(Value: TSliderPlacement);
procedure DrawMarker(p: integer);
procedure SetSelIndicator(Value: TSelIndicator);
procedure PaintParentBack;
procedure CalcPickRect;
protected
FArrowPos: integer;
@@ -76,18 +75,12 @@ type
FChange: boolean;
FPickRect: TRect;
FLimit: integer;
FGradientBmp: TBitmap;
FGradientWidth: Integer;
FGradientHeight: Integer;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC} LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); message CN_KEYDOWN;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CMGotFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF}); message CM_ENTER;
procedure CMLostFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF}); message CM_EXIT;
procedure CreateGradient;
function GetGradientColor(AValue: Integer): TColor; virtual;
procedure Paint; override;
procedure DrawFrames; dynamic;
procedure Resize; override;
@@ -96,9 +89,28 @@ type
function GetArrowPos: integer; dynamic;
function GetHintStr: string;
function GetSelectedValue: integer; virtual; abstract;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
{$IFDEF DELPHI}
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT;
{$ELSE}
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Manual: boolean read FManual;
published
property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone;
property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvNone;
@@ -115,7 +127,7 @@ type
property TabStop default true;
property ShowHint;
property Color;
property ParentColor default true;
property ParentColor;
{$IFDEF DELPHI_7_UP}
{$IFDEF DELPHI}
property ParentBackground default true;
@@ -155,6 +167,12 @@ type
implementation
uses
{$IFDEF FPC}
IntfGraphics, fpimage,
{$ENDIF}
ScanLines, HTMLColors;
const
{ 3D border styles }
BDR_RAISEDOUTER = 1;
@@ -189,16 +207,17 @@ begin
inherited;
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
DoubleBuffered := true;
ParentColor := true;
{$IFDEF DELPHI_7_UP}
{$IFDEF DELPHI}
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}
{$ENDIF}
{$ENDIF} {$ENDIF}
Width := 267;
Height := 22;
TabStop := true;
ParentShowHint := true;
FGradientWidth := 256;
FGradientHeight := 12;
FGradientBmp := TBitmap.Create;
FGradientBmp.PixelFormat := pf32bit;
mx := 0;
my := 0;
FIncrement := 1;
@@ -224,10 +243,98 @@ begin
FBorderStyle:= bsNone;
end;
destructor TmbTrackbarPicker.Destroy;
begin
FGradientBmp.Free;
inherited;
end;
function TmbTrackbarPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := clDefault;
end;
{ AWidth and AHeight are seen for horizontal arrangement of the bar }
procedure TmbTrackbarPicker.CreateGradient;
var
i,j: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
if FGradientBmp = nil then
exit;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(0, 0);
try
{$ENDIF}
if Layout = lyHorizontal then
begin
FGradientBmp.Width := FGradientWidth;
FGradientBmp.Height := FGradientHeight;
{$IFDEF FPC}
intfImg.LoadFromBitmap(FGradientBmp.Handle, FGradientBmp.MaskHandle);
{$ENDIF}
for i := 0 to FGradientBmp.Width-1 do
begin
c := GetGradientColor(i);
for j := 0 to FGradientBmp.Height-1 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(j);
{$ELSE}
row := FGradientBmp.ScanLine[j];
{$ENDIF}
if not WebSafe then
row[i] := RGBtoRGBQuad(c)
else
row[i] := RGBtoRGBQuad(GetWebSafe(c));
end;
end;
end
else
begin
FGradientBmp.Width := FGradientHeight;
FGradientBmp.Height := FGradientWidth;
{$IFDEF FPC}
intfImg.LoadFromBitmap(FGradientBmp.Handle, FGradientBmp.MaskHandle);
{$ENDIF}
for i := 0 to FGradientBmp.Height-1 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(i);
{$ELSE}
row := FGradientBmp.ScanLine[i];
{$ENDIF}
c := GetGradientColor(FGradientBmp.Height - 1 - i);
for j := 0 to FGradientBmp.Width-1 do
if not WebSafe then
row[j] := RGBtoRGBQuad(c)
else
row[j] := RGBtoRGBQuad(GetWebSafe(c));
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FGradientBmp.Handle := imgHandle;
FGradientBmp.MaskHandle := imgMaskHandle;
finally
intfImg.Free;
end;
{$ENDIF}
end;
procedure TmbTrackBarPicker.CreateWnd;
begin
inherited;
CalcPickRect;
CreateGradient;
end;
procedure TmbTrackBarPicker.CalcPickRect;
@@ -250,6 +357,7 @@ begin
f := 2;
FLimit := 7;
end;
siRect:
begin
f := 0;
@@ -257,29 +365,39 @@ begin
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);
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);
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);
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);
siRect:
FPickRect := Rect(Ah, Aw, width - 5, height - 2*Aw + 1);
end;
end;
end;
@@ -354,6 +472,7 @@ begin
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Mode := pmCopy;
end;
siArrows:
begin
if not FNewArrowStyle then
@@ -374,6 +493,7 @@ begin
Canvas.Brush.Color := clWindow;
Canvas.Pen.Color := clBtnShadow;
end;
if FLayout = lyHorizontal then
begin
x := p + Aw;
@@ -387,18 +507,19 @@ begin
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)]);
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)])
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)]);
Point(x + 3, y - 7), Point(x - 3, y - 7), Point(x - 4, y - 6),
Point(x - 4, y - 4) ]);
end;
spBoth:
begin
@@ -407,18 +528,18 @@ begin
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)]);
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)]);
Point(x + 3, y - 7), Point(x - 3, y - 7), Point(x - 4, y - 6),
Point(x - 4, y - 4) ]);
end;
end;
end
end; // case FPlacement
end // if FLayout
else
begin
if not FNewArrowStyle then
@@ -435,8 +556,8 @@ begin
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)]);
Point(x + 7, y - 3), Point(x + 7, y + 3), Point(x + 6, y + 4),
Point(x + 4, y + 4)]);
end;
spBefore:
begin
@@ -445,8 +566,8 @@ begin
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)]);
Point(x - 7, y + 1 - 4), Point(x - 7, y + 3), Point(x - 6, y + 4),
Point(x - 4, y + 4)]);
end;
spBoth:
begin
@@ -455,20 +576,20 @@ begin
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)]);
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;
Point(x - 7, y + 1 - 4), Point(x - 7, y + 3), Point(x - 6, y + 4),
Point(x - 4, y + 4)]);
end;
end; // case FPlacement
end; // else (if FLayout)
end; // siArrow
end; // case FSelIndicator
end;
procedure TmbTrackBarPicker.Resize;
@@ -479,40 +600,6 @@ begin
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;
@@ -713,12 +800,6 @@ begin
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
@@ -789,7 +870,11 @@ end;
procedure TmbTrackBarPicker.Execute(tbaAction: integer);
begin
//handled in descendants
case tbaAction of
TBA_Paint : Canvas.StretchDraw(FPickRect, FGradientBmp);
TBA_RedoBMP : CreateGradient;
// Rest handled in descendants
end;
end;
function TmbTrackBarPicker.GetArrowPos: integer;

6
components/mbColorLib/mbcolorliblaz.lpk
View File

@@ -15,7 +15,7 @@
<Description Value="Comprehensive color selection library with more than 30 components"/>
<License Value="License is granted to use, modify and redistribute these units in your applications as you see fit. You are given COMPLETE FREEDOM with the sources found in this pack; you're free to use it in ANY kind of app without even mentioning my name, my site or any other stuff, that depends on your good will and nothing else. I will accept any modifications and incorporate them in this pack if they'll help make it better. You are under NO obligation to pay for these components to neither me nor anyone else trying to sell them in their current form. If you wish to support development of these components you can do so by contributing some source or making a donation, again this solely depends on your good will."/>
<Version Major="2" Release="2"/>
<Files Count="43">
<Files Count="44">
<Item1>
<Filename Value="PalUtils.pas"/>
<UnitName Value="PalUtils"/>
@@ -219,6 +219,10 @@
<HasRegisterProc Value="True"/>
<UnitName Value="HSLRingPicker"/>
</Item43>
<Item44>
<Filename Value="mbBasicPicker.pas"/>
<UnitName Value="mbBasicPicker"/>
</Item44>
</Files>
<RequiredPkgs Count="2">
<Item1>