You've already forked lazarus-ccr
mbColorLib: Initial commit (still some issues)
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5452 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
843
components/mbColorLib/mbTrackBarPicker.pas
Normal file
843
components/mbColorLib/mbTrackBarPicker.pas
Normal file
@ -0,0 +1,843 @@
|
||||
unit mbTrackBarPicker;
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
interface
|
||||
|
||||
{$I mxs.inc}
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}LCLIntf, LCLType, LMessages,
|
||||
{$ELSE} Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils;
|
||||
|
||||
const
|
||||
TBA_Resize = 0;
|
||||
TBA_Paint = 1;
|
||||
TBA_MouseMove = 2;
|
||||
TBA_MouseDown = 3;
|
||||
TBA_MouseUp = 4;
|
||||
TBA_WheelUp = 5;
|
||||
TBA_WheelDown = 6;
|
||||
TBA_VKUp = 7;
|
||||
TBA_VKCtrlUp = 8;
|
||||
TBA_VKDown = 9;
|
||||
TBA_VKCtrlDown = 10;
|
||||
TBA_VKLeft = 11;
|
||||
TBA_VKCtrlLeft = 12;
|
||||
TBA_VKRight = 13;
|
||||
TBA_VKCtrlRight = 14;
|
||||
TBA_RedoBMP = 15;
|
||||
|
||||
type
|
||||
TTrackBarLayout = (lyHorizontal, lyVertical);
|
||||
TSliderPlacement = (spBefore, spAfter, spBoth);
|
||||
TSelIndicator = (siArrows, siRect);
|
||||
|
||||
TmbTrackBarPicker = class(TCustomControl)
|
||||
private
|
||||
mx, my: integer;
|
||||
FOnChange: TNotifyEvent;
|
||||
FIncrement: integer;
|
||||
FHintFormat: string;
|
||||
FLayout: TTrackBarLayout;
|
||||
FPlacement: TSliderPlacement;
|
||||
FNewArrowStyle: boolean;
|
||||
Aw, Ah: integer;
|
||||
FDoChange: boolean;
|
||||
FSelIndicator: TSelIndicator;
|
||||
FWebSafe: boolean;
|
||||
FBevelInner: TBevelCut;
|
||||
FBevelOuter: TBevelCut;
|
||||
FBevelWidth: TBevelWidth;
|
||||
FBorderStyle: TBorderStyle;
|
||||
|
||||
procedure SetBevelInner(Value: TBevelCut);
|
||||
procedure SetBevelOuter(Value: TBevelCut);
|
||||
procedure SetBevelWidth(Value: TBevelWidth);
|
||||
procedure SetBorderStyle(Value: TBorderStyle);
|
||||
procedure SetWebSafe(s: boolean);
|
||||
function XToArrowPos(p: integer): integer;
|
||||
function YToArrowPos(p: integer): integer;
|
||||
procedure SetLayout(Value: TTrackBarLayout);
|
||||
procedure SetNewArrowStyle(s: boolean);
|
||||
procedure SetPlacement(Value: TSliderPlacement);
|
||||
procedure DrawMarker(p: integer);
|
||||
procedure SetSelIndicator(Value: TSelIndicator);
|
||||
procedure PaintParentBack;
|
||||
procedure CalcPickRect;
|
||||
protected
|
||||
FArrowPos: integer;
|
||||
FManual: boolean;
|
||||
FChange: boolean;
|
||||
FPickRect: TRect;
|
||||
FLimit: integer;
|
||||
|
||||
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
|
||||
message {$IFDEF FPC} LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
|
||||
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
|
||||
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); message CN_KEYDOWN;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure CMGotFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF}); message CM_ENTER;
|
||||
procedure CMLostFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF}); message CM_EXIT;
|
||||
procedure Paint; override;
|
||||
procedure DrawFrames; dynamic;
|
||||
procedure Resize; override;
|
||||
procedure CreateWnd; override;
|
||||
procedure Execute(tbaAction: integer); dynamic;
|
||||
function GetArrowPos: integer; dynamic;
|
||||
function GetHintStr: string;
|
||||
function GetSelectedValue: integer; virtual; abstract;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
property Manual: boolean read FManual;
|
||||
published
|
||||
property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone;
|
||||
property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvNone;
|
||||
property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1;
|
||||
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
|
||||
|
||||
property HintFormat: string read FHintFormat write FHintFormat;
|
||||
property Increment: integer read FIncrement write FIncrement default 1;
|
||||
property Layout: TTrackBarLayout read FLayout write SetLayout default lyHorizontal;
|
||||
property ArrowPlacement: TSliderPlacement read FPlacement write SetPlacement default spAfter;
|
||||
property NewArrowStyle: boolean read FNewArrowStyle write SetNewArrowStyle default false;
|
||||
property SelectionIndicator: TSelIndicator read FSelIndicator write SetSelIndicator default siArrows;
|
||||
property WebSafe: boolean read FWebSafe write SetWebSafe default false;
|
||||
property TabStop default true;
|
||||
property ShowHint;
|
||||
property Color;
|
||||
property ParentColor default true;
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
{$IFDEF DELPHI}
|
||||
property ParentBackground default true;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
property ParentShowHint default true;
|
||||
property Anchors;
|
||||
property Align;
|
||||
property Visible;
|
||||
property Enabled;
|
||||
property PopupMenu;
|
||||
property TabOrder;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property DragKind;
|
||||
property Constraints;
|
||||
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property OnContextPopup;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelUp;
|
||||
property OnMouseWheelDown;
|
||||
property OnKeyDown;
|
||||
property OnKeyPress;
|
||||
property OnKeyUp;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnResize;
|
||||
property OnStartDrag;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
{ 3D border styles }
|
||||
BDR_RAISEDOUTER = 1;
|
||||
BDR_SUNKENOUTER = 2;
|
||||
BDR_RAISEDINNER = 4;
|
||||
BDR_SUNKENINNER = 8;
|
||||
|
||||
BDR_OUTER = 3;
|
||||
BDR_INNER = 12;
|
||||
BDR_RAISED = 5;
|
||||
BDR_SUNKEN = 10;
|
||||
|
||||
{ Border flags }
|
||||
BF_LEFT = 1;
|
||||
BF_TOP = 2;
|
||||
BF_RIGHT = 4;
|
||||
BF_BOTTOM = 8;
|
||||
|
||||
BF_TOPLEFT = (BF_TOP or BF_LEFT);
|
||||
BF_TOPRIGHT = (BF_TOP or BF_RIGHT);
|
||||
BF_BOTTOMLEFT = (BF_BOTTOM or BF_LEFT);
|
||||
BF_BOTTOMRIGHT = (BF_BOTTOM or BF_RIGHT);
|
||||
BF_RECT = (BF_LEFT or BF_TOP or BF_RIGHT or BF_BOTTOM);
|
||||
|
||||
BF_DIAGONAL = $10;
|
||||
|
||||
|
||||
{TmbTrackBarPicker}
|
||||
|
||||
constructor TmbTrackBarPicker.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
|
||||
DoubleBuffered := true;
|
||||
ParentColor := true;
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
{$IFDEF DELPHI}
|
||||
ParentBackground := true;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
Width := 267;
|
||||
Height := 22;
|
||||
TabStop := true;
|
||||
ParentShowHint := true;
|
||||
mx := 0;
|
||||
my := 0;
|
||||
FIncrement := 1;
|
||||
FArrowPos := GetArrowPos;
|
||||
FHintFormat := '';
|
||||
OnMouseWheelUp := WheelUp;
|
||||
OnMouseWheelDown := WheelDown;
|
||||
FManual := false;
|
||||
FChange := true;
|
||||
FLayout := lyHorizontal;
|
||||
FNewArrowStyle := false;
|
||||
Aw := 6;
|
||||
Ah := 10;
|
||||
FPlacement := spAfter;
|
||||
FPickRect := Rect(Aw, 0, Width - Aw, Height - Ah);
|
||||
FDoChange := false;
|
||||
FSelIndicator := siArrows;
|
||||
FLimit := 7;
|
||||
FWebSafe := false;
|
||||
FBevelInner:= bvNone;
|
||||
FBevelOuter:= bvNone;
|
||||
FBevelWidth:= 1;
|
||||
FBorderStyle:= bsNone;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.CreateWnd;
|
||||
begin
|
||||
inherited;
|
||||
CalcPickRect;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.CalcPickRect;
|
||||
var
|
||||
f: integer;
|
||||
begin
|
||||
case FSelIndicator of
|
||||
siArrows:
|
||||
if not FNewArrowStyle then
|
||||
begin
|
||||
f := 0;
|
||||
Aw := 6;
|
||||
Ah := 10;
|
||||
FLimit := 7;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Aw := 8;
|
||||
Ah := 9;
|
||||
f := 2;
|
||||
FLimit := 7;
|
||||
end;
|
||||
siRect:
|
||||
begin
|
||||
f := 0;
|
||||
Aw := 4;
|
||||
Ah := 5;
|
||||
FLimit := 3;
|
||||
end
|
||||
else
|
||||
f := 0;
|
||||
end;
|
||||
case FLayout of
|
||||
lyHorizontal:
|
||||
case FSelIndicator of
|
||||
siArrows:
|
||||
case FPlacement of
|
||||
spAfter: FPickRect := Rect(Aw, 0, Width - Aw, Height - Ah - f);
|
||||
spBefore: FPickRect := Rect(Aw, Ah + f, Width - Aw, Height);
|
||||
spBoth: FPickRect := Rect(Aw, Ah + f, Width - Aw, Height - Ah - f);
|
||||
end;
|
||||
siRect: FPickRect := Rect(Aw, Ah, width - 2*Aw + 1, height - Ah);
|
||||
end;
|
||||
lyVertical:
|
||||
case FSelIndicator of
|
||||
siArrows:
|
||||
case FPlacement of
|
||||
spAfter: FPickRect := Rect(0, Aw, Width - Ah - f, Height - Aw);
|
||||
spBefore: FPickRect := Rect(Ah + f, Aw, Width, Height - Aw);
|
||||
spBoth: FPickRect := Rect(Ah + f, Aw, Width - Ah - f, Height - Aw);
|
||||
end;
|
||||
siRect: FPickRect := Rect(Ah, Aw, width - 5, height - 2*Aw + 1);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.Paint;
|
||||
begin
|
||||
CalcPickRect;
|
||||
PaintParentBack;
|
||||
FArrowPos := GetArrowPos;
|
||||
Execute(TBA_Paint);
|
||||
if FBorderStyle <> bsNone then
|
||||
DrawFrames;
|
||||
DrawMarker(FArrowPos);
|
||||
if FDoChange then
|
||||
begin
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
FDoChange := false;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.DrawFrames;
|
||||
var
|
||||
flags: cardinal;
|
||||
R: TRect;
|
||||
i: integer;
|
||||
begin
|
||||
flags := 0;
|
||||
if (FBorderStyle = bsNone) or (FBevelWidth = 0) then Exit;
|
||||
case FBevelInner of
|
||||
bvNone: flags := 0;
|
||||
bvRaised: flags := BDR_RAISEDINNER;
|
||||
bvLowered: flags := BDR_SUNKENINNER;
|
||||
bvSpace: flags := BDR_INNER;
|
||||
end;
|
||||
case FBevelOuter of
|
||||
bvRaised: flags := flags or BDR_RAISEDOUTER;
|
||||
bvLowered: flags := flags or BDR_SUNKENOUTER;
|
||||
bvSpace: flags := flags or BDR_OUTER;
|
||||
end;
|
||||
R := FPickRect;
|
||||
InflateRect(R, -FBevelWidth + 1, -FBevelWidth + 1);
|
||||
for i := 0 to FBevelWidth do
|
||||
begin
|
||||
DrawEdge(Canvas.Handle, R, flags, BF_RECT);
|
||||
InflateRect(R, 1, 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.DrawMarker(p: integer);
|
||||
var
|
||||
x, y: integer;
|
||||
R: TRect;
|
||||
begin
|
||||
case FSelIndicator of
|
||||
siRect:
|
||||
begin
|
||||
case FLayout of
|
||||
lyHorizontal:
|
||||
begin
|
||||
p := p + Aw;
|
||||
R := Rect(p - 2, 2, p + 3, Height - 2);
|
||||
end;
|
||||
lyVertical:
|
||||
begin
|
||||
p := p + Aw;
|
||||
R := Rect(2, p - 2, Width - 2, p + 3);
|
||||
end;
|
||||
end;
|
||||
Canvas.Pen.Mode := pmNot;
|
||||
Canvas.Brush.Style := bsClear;
|
||||
Canvas.Rectangle(R);
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
Canvas.Pen.Mode := pmCopy;
|
||||
end;
|
||||
siArrows:
|
||||
begin
|
||||
if not FNewArrowStyle then
|
||||
begin
|
||||
if Focused or (csDesigning in ComponentState)then
|
||||
begin
|
||||
Canvas.Brush.Color := clBlack;
|
||||
Canvas.Pen.Color := clBlack;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Canvas.Brush.Color := clGray;
|
||||
Canvas.Pen.Color := clGray;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Canvas.Brush.Color := clWindow;
|
||||
Canvas.Pen.Color := clBtnShadow;
|
||||
end;
|
||||
if FLayout = lyHorizontal then
|
||||
begin
|
||||
x := p + Aw;
|
||||
if x < Aw then x := Aw;
|
||||
if x > Width - Aw then x := Width - Aw;
|
||||
case FPlacement of
|
||||
spAfter:
|
||||
begin
|
||||
y := Height - Aw - 1;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x - 4, y + 6), Point(x + 4, y + 6)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x - 4, y + 4), Point(x - 4, y + 6),
|
||||
Point(x - 3, y + 7), Point(x + 3, y + 7),
|
||||
Point(x + 4, y + 6), Point(x + 4, y + 4)]);
|
||||
end;
|
||||
spBefore:
|
||||
begin
|
||||
y := Aw;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x - 4, y - 6), Point(x +4, y - 6)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 4, y - 6),
|
||||
Point(x + 3, y - 7), Point(x - 3, y - 7),
|
||||
Point(x - 4, y - 6), Point(x - 4, y - 4)]);
|
||||
end;
|
||||
spBoth:
|
||||
begin
|
||||
y := Height - Aw - 1;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x -4, y +6), Point(x +4, y + 6)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x - 4, y + 4), Point(x - 4, y + 6),
|
||||
Point(x - 3, y + 7), Point(x + 3, y + 7),
|
||||
Point(x + 4, y + 6), Point(x + 4, y + 4)]);
|
||||
y := Aw;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x - 4, y - 6), Point(x +4, y - 6)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 4, y - 6),
|
||||
Point(x + 3, y - 7), Point(x - 3, y - 7),
|
||||
Point(x - 4, y - 6), Point(x - 4, y - 4)]);
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if not FNewArrowStyle then
|
||||
y := p + Aw
|
||||
else
|
||||
y := p + Aw - 1;
|
||||
if y < Aw then y := Aw;
|
||||
if y > Height - Aw - 1 then y := Height - Aw - 1;
|
||||
case FPlacement of
|
||||
spAfter:
|
||||
begin
|
||||
x := width - Aw - 1;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x + 6, y - 4), Point(x + 6, y + 4)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 6, y - 4),
|
||||
Point(x + 7, y - 3), Point(x + 7, y + 3),
|
||||
Point(x + 6, y + 4), Point(x + 4, y + 4)]);
|
||||
end;
|
||||
spBefore:
|
||||
begin
|
||||
x := Aw;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x - 6, y - 4), Point(x - 6, y + 4)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x - 4, y - 4), Point(x - 6, y - 4),
|
||||
Point(x - 7, y + 1 - 4), Point(x - 7, y + 3),
|
||||
Point(x - 6, y + 4), Point(x - 4, y + 4)]);
|
||||
end;
|
||||
spBoth:
|
||||
begin
|
||||
x := width - Aw - 1;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x + 6, y - 4), Point(x + 6, y + 4)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x + 4, y - 4), Point(x + 6, y - 4),
|
||||
Point(x + 7, y - 3), Point(x + 7, y + 3),
|
||||
Point(x + 6, y + 4), Point(x + 4, y + 4)]);
|
||||
x := Aw;
|
||||
if not FNewArrowStyle then
|
||||
Canvas.Polygon([Point(x, y), Point(x - 6, y - 4), Point(x - 6, y + 4)])
|
||||
else
|
||||
Canvas.Polygon([Point(x, y), Point(x - 4, y - 4), Point(x - 6, y - 4),
|
||||
Point(x - 7, y + 1 - 4), Point(x - 7, y + 3),
|
||||
Point(x - 6, y + 4), Point(x - 4, y + 4)]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.Resize;
|
||||
begin
|
||||
inherited;
|
||||
FChange := false;
|
||||
Execute(TBA_Resize);
|
||||
FChange := true;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.PaintParentBack;
|
||||
var
|
||||
c: TColor;
|
||||
OffScreen: TBitmap;
|
||||
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
|
||||
MemDC: HDC;
|
||||
OldBMP: HBITMAP;
|
||||
{$ENDIF}{$ENDIF}
|
||||
begin
|
||||
Offscreen := TBitmap.Create;
|
||||
Offscreen.Width := Width;
|
||||
Offscreen.Height := Height;
|
||||
{$IFDEF FPC}
|
||||
if Color = clDefault then
|
||||
Offscreen.Canvas.Brush.Color := clForm else
|
||||
{$ENDIF}
|
||||
Offscreen.Canvas.Brush.Color := Color;
|
||||
Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect);
|
||||
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
|
||||
if ParentBackground then
|
||||
with ThemeServices do
|
||||
if ThemesEnabled then
|
||||
begin
|
||||
MemDC := CreateCompatibleDC(0);
|
||||
OldBMP := SelectObject(MemDC, OffScreen.Handle);
|
||||
DrawParentBackground(Handle, MemDC, nil, False);
|
||||
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
|
||||
if MemDC <> 0 then DeleteDC(MemDC);
|
||||
end;
|
||||
{$ENDIF}{$ENDIF}
|
||||
Canvas.Draw(0, 0, Offscreen);
|
||||
Offscreen.Free;
|
||||
end;
|
||||
|
||||
function TmbTrackBarPicker.XToArrowPos(p: integer): integer;
|
||||
var
|
||||
pos: integer;
|
||||
begin
|
||||
pos := p - Aw;
|
||||
if pos < 0 then pos := 0;
|
||||
if pos > Width - Aw - 1 then pos := Width - Aw - 1;
|
||||
Result := pos;
|
||||
end;
|
||||
|
||||
function TmbTrackBarPicker.YToArrowPos(p: integer): integer;
|
||||
var
|
||||
pos: integer;
|
||||
begin
|
||||
pos := p - Aw;
|
||||
if pos < 0 then pos := 0;
|
||||
if pos > Height - Aw - 1 then pos := Height - Aw - 1;
|
||||
Result := pos;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
var
|
||||
R: TRect;
|
||||
begin
|
||||
if ssLeft in shift then
|
||||
begin
|
||||
R := ClientRect;
|
||||
R.TopLeft := ClientToScreen(R.TopLeft);
|
||||
R.BottomRight := ClientToScreen(R.BottomRight);
|
||||
{$IFDEF DELPHI}
|
||||
ClipCursor(@R);
|
||||
{$ENDIF}
|
||||
mx := x;
|
||||
my := y;
|
||||
if FLayout = lyHorizontal then
|
||||
FArrowPos := XToArrowPos(x)
|
||||
else
|
||||
FArrowPos := YToArrowPos(y);
|
||||
Execute(TBA_MouseMove);
|
||||
FManual := true;
|
||||
FDoChange := true;
|
||||
Invalidate;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
if Button <> mbLeft then Exit;
|
||||
mx := x;
|
||||
my := y;
|
||||
SetFocus;
|
||||
if FLayout = lyHorizontal then
|
||||
FArrowPos := XToArrowPos(x)
|
||||
else
|
||||
FArrowPos := YToArrowPos(y);
|
||||
Execute(TBA_MouseDown);
|
||||
FManual := true;
|
||||
FDoChange := true;
|
||||
Invalidate;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
{$IFDEF DELPHI}
|
||||
ClipCursor(nil);
|
||||
{$ENDIF}
|
||||
if Button <> mbLeft then Exit;
|
||||
mx := x;
|
||||
my := y;
|
||||
if FLayout = lyHorizontal then
|
||||
FArrowPos := XToArrowPos(x)
|
||||
else
|
||||
FArrowPos := YToArrowPos(y);
|
||||
Execute(TBA_MouseUp);
|
||||
FManual := true;
|
||||
FDoChange := true;
|
||||
Invalidate;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.CNKeyDown(
|
||||
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
|
||||
var
|
||||
Shift: TShiftState;
|
||||
FInherited: boolean;
|
||||
begin
|
||||
FInherited := false;
|
||||
Shift := KeyDataToShiftState(Message.KeyData);
|
||||
case Message.CharCode of
|
||||
VK_UP:
|
||||
begin
|
||||
if FLayout = lyHorizontal then
|
||||
begin
|
||||
inherited;
|
||||
Exit;
|
||||
end;
|
||||
FChange := false;
|
||||
if not (ssCtrl in Shift) then
|
||||
Execute(TBA_VKUp)
|
||||
else
|
||||
Execute(TBA_VKCtrlUp);
|
||||
FManual := true;
|
||||
FChange := true;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
VK_LEFT:
|
||||
begin
|
||||
if FLayout = lyVertical then
|
||||
begin
|
||||
inherited;
|
||||
Exit;
|
||||
end;
|
||||
FChange := false;
|
||||
if not (ssCtrl in Shift) then
|
||||
Execute(TBA_VKLeft)
|
||||
else
|
||||
Execute(TBA_VKCtrlLeft);
|
||||
FManual := true;
|
||||
FChange := true;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
VK_RIGHT:
|
||||
begin
|
||||
if FLayout = lyVertical then
|
||||
begin
|
||||
inherited;
|
||||
Exit;
|
||||
end;
|
||||
FChange := false;
|
||||
if not (ssCtrl in Shift) then
|
||||
Execute(TBA_VKRight)
|
||||
else
|
||||
Execute(TBA_VKCtrlRight);
|
||||
FManual := true;
|
||||
FChange := true;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
VK_DOWN:
|
||||
begin
|
||||
if FLayout = lyHorizontal then
|
||||
begin
|
||||
inherited;
|
||||
Exit;
|
||||
end;
|
||||
FChange := false;
|
||||
if not (ssCtrl in Shift) then
|
||||
Execute(TBA_VKDown)
|
||||
else
|
||||
Execute(TBA_VKCtrlDown);
|
||||
FManual := true;
|
||||
FChange := true;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end
|
||||
else
|
||||
begin
|
||||
FInherited := true;
|
||||
inherited;
|
||||
end;
|
||||
end;
|
||||
if not FInherited then
|
||||
if Assigned(OnKeyDown) then
|
||||
OnKeyDown(Self, Message.CharCode, Shift);
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.CMHintShow(var Message: TCMHintShow);
|
||||
begin
|
||||
with TCMHintShow(Message) do
|
||||
if not ShowHint then
|
||||
Message.Result := 1
|
||||
else
|
||||
with HintInfo^ do
|
||||
begin
|
||||
Result := 0;
|
||||
ReshowTimeout := 1;
|
||||
HideTimeout := 5000;
|
||||
if FLayout = lyHorizontal then
|
||||
HintPos := ClientToScreen(Point(CursorPos.X - 8, Height + 2))
|
||||
else
|
||||
HintPos := ClientToScreen(Point(Width + 2, CursorPos.Y - 8));
|
||||
HintStr := GetHintStr;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.CMGotFocus(
|
||||
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
|
||||
begin
|
||||
inherited;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.CMLostFocus(
|
||||
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF});
|
||||
begin
|
||||
inherited;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.WMEraseBkgnd(
|
||||
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
|
||||
begin
|
||||
Message.Result := 1;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.WheelUp(Sender: TObject; Shift: TShiftState;
|
||||
MousePos: TPoint; var Handled: Boolean);
|
||||
begin
|
||||
Handled := true;
|
||||
FChange := false;
|
||||
Execute(TBA_WheelUp);
|
||||
FManual := true;
|
||||
FChange := true;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
begin
|
||||
Handled := true;
|
||||
FChange := false;
|
||||
Execute(TBA_WheelDown);
|
||||
FManual := true;
|
||||
FChange := true;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetLayout(Value: TTrackBarLayout);
|
||||
begin
|
||||
if FLayout <> Value then
|
||||
begin
|
||||
FLayout := Value;
|
||||
Execute(TBA_RedoBMP);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetPlacement(Value: TSliderPlacement);
|
||||
begin
|
||||
if FPlacement <> Value then
|
||||
begin
|
||||
FPlacement := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetNewArrowStyle(s: boolean);
|
||||
begin
|
||||
if FNewArrowStyle <> s then
|
||||
begin
|
||||
FNewArrowStyle := s;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetSelIndicator(Value: TSelIndicator);
|
||||
begin
|
||||
if FSelIndicator <> Value then
|
||||
begin
|
||||
FSelIndicator := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetWebSafe(s: boolean);
|
||||
begin
|
||||
if FWebSafe <> s then
|
||||
begin
|
||||
FWebSafe := s;
|
||||
Execute(TBA_RedoBMP);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.Execute(tbaAction: integer);
|
||||
begin
|
||||
//handled in descendants
|
||||
end;
|
||||
|
||||
function TmbTrackBarPicker.GetArrowPos: integer;
|
||||
begin
|
||||
Result := 0;
|
||||
//handled in descendants
|
||||
end;
|
||||
|
||||
function TmbTrackBarPicker.GetHintStr: string;
|
||||
begin
|
||||
Result := ReplaceFlags(FHintFormat, ['%value', '%h', '%s', '%l', '%v', '%c',
|
||||
'%m', '%y', '%k', '%r', '%g', '%b'], GetSelectedValue);
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetBevelInner(Value: TBevelCut);
|
||||
begin
|
||||
if FBevelInner <> Value then
|
||||
begin
|
||||
FBevelInner := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetBevelOuter(Value: TBevelCut);
|
||||
begin
|
||||
if FBevelOuter <> Value then
|
||||
begin
|
||||
FBevelOuter := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetBevelWidth(Value: TBevelWidth);
|
||||
begin
|
||||
if FBevelWidth <> Value then
|
||||
begin
|
||||
FBevelWidth := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbTrackBarPicker.SetBorderStyle(Value: TBorderStyle);
|
||||
begin
|
||||
if FBorderStyle <> Value then
|
||||
begin
|
||||
FBorderStyle := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user