mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-18 20:19:29 +02:00
arrow: changed unit line ending to unix, as it was before
git-svn-id: trunk@41223 -
This commit is contained in:
zeljko
parent
2c790f658b
commit
80c3c67cb8
2
.gitattributes
vendored
2
.gitattributes
vendored
@ -5776,7 +5776,7 @@ lcl/Makefile.compiled svneol=native#text/plain
|
|||||||
lcl/Makefile_win.compiled svneol=native#text/plain
|
lcl/Makefile_win.compiled svneol=native#text/plain
|
||||||
lcl/actnlist.pas svneol=native#text/pascal
|
lcl/actnlist.pas svneol=native#text/pascal
|
||||||
lcl/alllclunits.pp svneol=native#text/pascal
|
lcl/alllclunits.pp svneol=native#text/pascal
|
||||||
lcl/arrow.pp -text svneol=native#text/pascal
|
lcl/arrow.pp svneol=native#text/pascal
|
||||||
lcl/asyncprocess.pp svneol=native#text/plain
|
lcl/asyncprocess.pp svneol=native#text/plain
|
||||||
lcl/barchart.pp svneol=native#text/pascal
|
lcl/barchart.pp svneol=native#text/pascal
|
||||||
lcl/btn_icons.lrs svneol=native#text/pascal
|
lcl/btn_icons.lrs svneol=native#text/pascal
|
||||||
|
|||||||
480
lcl/arrow.pp
480
lcl/arrow.pp
@ -1,240 +1,240 @@
|
|||||||
{
|
{
|
||||||
Copyright (C) 2013 H. Page-Clark
|
Copyright (C) 2013 H. Page-Clark
|
||||||
|
|
||||||
This library is free software; you can redistribute it and/or modify it
|
This library is free software; you can redistribute it and/or modify it
|
||||||
under the terms of the GNU Library General Public License as published by
|
under the terms of the GNU Library General Public License as published by
|
||||||
the Free Software Foundation; either version 2 of the License, or (at your
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
option) any later version.
|
option) any later version.
|
||||||
|
|
||||||
This program is distributed in the hope that it will be useful, but WITHOUT
|
This program is distributed in the hope that it will be useful, but WITHOUT
|
||||||
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||||
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
|
||||||
for more details.
|
for more details.
|
||||||
|
|
||||||
You should have received a copy of the GNU Library General Public License
|
You should have received a copy of the GNU Library General Public License
|
||||||
along with this library; if not, write to the Free Software Foundation,
|
along with this library; if not, write to the Free Software Foundation,
|
||||||
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
}
|
}
|
||||||
|
|
||||||
unit Arrow;
|
unit Arrow;
|
||||||
|
|
||||||
{$mode objfpc}{$H+}
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
interface
|
interface
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, Controls, Graphics, types;
|
Classes, Controls, Graphics, types;
|
||||||
|
|
||||||
const Default_Height_Width = 10;
|
const Default_Height_Width = 10;
|
||||||
ArrowMinHeight = 8;
|
ArrowMinHeight = 8;
|
||||||
|
|
||||||
type
|
type
|
||||||
|
|
||||||
TArrowType = (atUp, atDown, atLeft, atRight);
|
TArrowType = (atUp, atDown, atLeft, atRight);
|
||||||
TShadowType = (stNone, stIn, stOut, stEtchedIn, stEtchedOut);
|
TShadowType = (stNone, stIn, stOut, stEtchedIn, stEtchedOut);
|
||||||
TTriPts = (ptA, ptB, ptC);
|
TTriPts = (ptA, ptB, ptC);
|
||||||
TTrianglePoints = array[TTriPts] of TPoint;
|
TTrianglePoints = array[TTriPts] of TPoint;
|
||||||
|
|
||||||
{ TArrow }
|
{ TArrow }
|
||||||
|
|
||||||
TArrow = class(TGraphicControl)
|
TArrow = class(TGraphicControl)
|
||||||
private
|
private
|
||||||
FArrowColor: TColor;
|
FArrowColor: TColor;
|
||||||
FArrowType: TArrowType;
|
FArrowType: TArrowType;
|
||||||
FR: TRect;
|
FR: TRect;
|
||||||
FShadowType: TShadowType;
|
FShadowType: TShadowType;
|
||||||
FT: TTrianglePoints;
|
FT: TTrianglePoints;
|
||||||
procedure CalcTrianglePoints;
|
procedure CalcTrianglePoints;
|
||||||
procedure GraphicChanged(Sender: TObject);
|
procedure GraphicChanged(Sender: TObject);
|
||||||
procedure SetArrowColor(AValue: TColor);
|
procedure SetArrowColor(AValue: TColor);
|
||||||
procedure SetArrowType(AValue: TArrowType);
|
procedure SetArrowType(AValue: TArrowType);
|
||||||
procedure SetShadowType(AValue: TShadowType);
|
procedure SetShadowType(AValue: TShadowType);
|
||||||
protected
|
protected
|
||||||
class function GetControlClassDefaultSize: TSize; override;
|
class function GetControlClassDefaultSize: TSize; override;
|
||||||
procedure Paint; override;
|
procedure Paint; override;
|
||||||
public
|
public
|
||||||
constructor Create(aOwner: TComponent); override;
|
constructor Create(aOwner: TComponent); override;
|
||||||
published
|
published
|
||||||
property Align;
|
property Align;
|
||||||
property Anchors;
|
property Anchors;
|
||||||
property ArrowColor: TColor read FArrowColor write SetArrowColor default clBlack;
|
property ArrowColor: TColor read FArrowColor write SetArrowColor default clBlack;
|
||||||
property ArrowType: TArrowType read FArrowType write SetArrowType default atLeft;
|
property ArrowType: TArrowType read FArrowType write SetArrowType default atLeft;
|
||||||
property BorderSpacing;
|
property BorderSpacing;
|
||||||
property Color;
|
property Color;
|
||||||
property Constraints;
|
property Constraints;
|
||||||
property OnChangeBounds;
|
property OnChangeBounds;
|
||||||
property OnClick;
|
property OnClick;
|
||||||
property OnContextPopup;
|
property OnContextPopup;
|
||||||
property OnDblClick;
|
property OnDblClick;
|
||||||
//property OnDragDrop;
|
//property OnDragDrop;
|
||||||
//property OnDragOver;
|
//property OnDragOver;
|
||||||
//property OnEndDrag;
|
//property OnEndDrag;
|
||||||
property OnMouseDown;
|
property OnMouseDown;
|
||||||
property OnMouseMove;
|
property OnMouseMove;
|
||||||
property OnMouseUp;
|
property OnMouseUp;
|
||||||
property OnPaint;
|
property OnPaint;
|
||||||
property OnResize;
|
property OnResize;
|
||||||
//property OnStartDrag;
|
//property OnStartDrag;
|
||||||
property ParentShowHint;
|
property ParentShowHint;
|
||||||
property PopupMenu;
|
property PopupMenu;
|
||||||
property ShadowType: TShadowType read FShadowType write SetShadowType default stEtchedIn;
|
property ShadowType: TShadowType read FShadowType write SetShadowType default stEtchedIn;
|
||||||
property Visible;
|
property Visible;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure Register;
|
procedure Register;
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
procedure Register;
|
procedure Register;
|
||||||
begin
|
begin
|
||||||
RegisterComponents('Industrial',[TArrow]);
|
RegisterComponents('Industrial',[TArrow]);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
{ TArrow }
|
{ TArrow }
|
||||||
|
|
||||||
procedure TArrow.CalcTrianglePoints;
|
procedure TArrow.CalcTrianglePoints;
|
||||||
var midY, midX, half: integer;
|
var midY, midX, half: integer;
|
||||||
sz: TSize;
|
sz: TSize;
|
||||||
square, tall: boolean;
|
square, tall: boolean;
|
||||||
begin
|
begin
|
||||||
FR:= ClientRect;
|
FR:= ClientRect;
|
||||||
InflateRect(FR, -2, -2);
|
InflateRect(FR, -2, -2);
|
||||||
sz:= Size(FR);
|
sz:= Size(FR);
|
||||||
square:= (sz.cx = sz.cy);
|
square:= (sz.cx = sz.cy);
|
||||||
if not square then
|
if not square then
|
||||||
begin
|
begin
|
||||||
tall:= (sz.cy > sz.cx);
|
tall:= (sz.cy > sz.cx);
|
||||||
case tall of
|
case tall of
|
||||||
False:InflateRect(FR, -((sz.cx - sz.cy) div 2), 0);
|
False:InflateRect(FR, -((sz.cx - sz.cy) div 2), 0);
|
||||||
True: InflateRect(FR, 0, -((sz.cy - sz.cx) div 2));
|
True: InflateRect(FR, 0, -((sz.cy - sz.cx) div 2));
|
||||||
end;
|
end;
|
||||||
sz:= Size(FR);
|
sz:= Size(FR);
|
||||||
end;
|
end;
|
||||||
half:= sz.cx div 2;
|
half:= sz.cx div 2;
|
||||||
midX:= FR.Left + half;
|
midX:= FR.Left + half;
|
||||||
midY:= FR.Top + half;
|
midY:= FR.Top + half;
|
||||||
case FArrowType of
|
case FArrowType of
|
||||||
atUp: begin
|
atUp: begin
|
||||||
FT[ptC] := Point(midX, FR.Top);
|
FT[ptC] := Point(midX, FR.Top);
|
||||||
FT[ptA] := Point(FR.Left, FR.Bottom);
|
FT[ptA] := Point(FR.Left, FR.Bottom);
|
||||||
FT[ptB] := FR.BottomRight;
|
FT[ptB] := FR.BottomRight;
|
||||||
end;
|
end;
|
||||||
atDown: begin
|
atDown: begin
|
||||||
FT[ptA] := FR.TopLeft;
|
FT[ptA] := FR.TopLeft;
|
||||||
FT[ptB] := Point(FR.Right, FR.Top);
|
FT[ptB] := Point(FR.Right, FR.Top);
|
||||||
FT[ptC] := Point(midX, FR.Bottom);
|
FT[ptC] := Point(midX, FR.Bottom);
|
||||||
end;
|
end;
|
||||||
atLeft: begin
|
atLeft: begin
|
||||||
FT[ptA] := Point(FR.Right, FR.Top);
|
FT[ptA] := Point(FR.Right, FR.Top);
|
||||||
FT[ptB] := FR.BottomRight;
|
FT[ptB] := FR.BottomRight;
|
||||||
FT[ptC] := Point(FR.Left, midY);
|
FT[ptC] := Point(FR.Left, midY);
|
||||||
end;
|
end;
|
||||||
atRight: begin
|
atRight: begin
|
||||||
FT[ptA] := FR.TopLeft;
|
FT[ptA] := FR.TopLeft;
|
||||||
FT[ptB] := Point(FR.Right, midY);
|
FT[ptB] := Point(FR.Right, midY);
|
||||||
FT[ptC] := Point(FR.Left, FR.Bottom);
|
FT[ptC] := Point(FR.Left, FR.Bottom);
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TArrow.GraphicChanged(Sender: TObject);
|
procedure TArrow.GraphicChanged(Sender: TObject);
|
||||||
begin
|
begin
|
||||||
if Assigned(Parent) and
|
if Assigned(Parent) and
|
||||||
(Visible or (csDesigning in ComponentState))
|
(Visible or (csDesigning in ComponentState))
|
||||||
then Invalidate;
|
then Invalidate;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TArrow.SetArrowColor(AValue: TColor);
|
procedure TArrow.SetArrowColor(AValue: TColor);
|
||||||
begin
|
begin
|
||||||
if FArrowColor=AValue then Exit;
|
if FArrowColor=AValue then Exit;
|
||||||
FArrowColor:=AValue;
|
FArrowColor:=AValue;
|
||||||
GraphicChanged(nil);
|
GraphicChanged(nil);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TArrow.SetArrowType(AValue: TArrowType);
|
procedure TArrow.SetArrowType(AValue: TArrowType);
|
||||||
begin
|
begin
|
||||||
if FArrowType=AValue then Exit;
|
if FArrowType=AValue then Exit;
|
||||||
FArrowType:=AValue;
|
FArrowType:=AValue;
|
||||||
GraphicChanged(nil);
|
GraphicChanged(nil);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TArrow.SetShadowType(AValue: TShadowType);
|
procedure TArrow.SetShadowType(AValue: TShadowType);
|
||||||
begin
|
begin
|
||||||
if FShadowType=AValue then Exit;
|
if FShadowType=AValue then Exit;
|
||||||
FShadowType:=AValue;
|
FShadowType:=AValue;
|
||||||
GraphicChanged(nil);
|
GraphicChanged(nil);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
class function TArrow.GetControlClassDefaultSize: TSize;
|
class function TArrow.GetControlClassDefaultSize: TSize;
|
||||||
begin
|
begin
|
||||||
Result.cx:=Default_Height_Width;
|
Result.cx:=Default_Height_Width;
|
||||||
Result.cy:=Default_Height_Width;
|
Result.cy:=Default_Height_Width;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TArrow.Paint;
|
procedure TArrow.Paint;
|
||||||
const
|
const
|
||||||
Colors: array[TShadowType] of TColor
|
Colors: array[TShadowType] of TColor
|
||||||
=(clWindow, cl3DShadow, cl3DShadow, cl3DHiLight, cl3DHiLight);
|
=(clWindow, cl3DShadow, cl3DShadow, cl3DHiLight, cl3DHiLight);
|
||||||
|
|
||||||
procedure Offset(var ptA, ptB: TPoint);
|
procedure Offset(var ptA, ptB: TPoint);
|
||||||
begin
|
begin
|
||||||
case FArrowType of
|
case FArrowType of
|
||||||
atUp: begin Inc(ptA.x); Dec(ptA.y); Inc(ptB.x); Dec(ptB.y); end;
|
atUp: begin Inc(ptA.x); Dec(ptA.y); Inc(ptB.x); Dec(ptB.y); end;
|
||||||
atDown: begin Inc(ptA.x); Inc(ptA.y); Inc(ptB.x); Inc(ptB.y); end;
|
atDown: begin Inc(ptA.x); Inc(ptA.y); Inc(ptB.x); Inc(ptB.y); end;
|
||||||
atLeft: begin Dec(ptA.x); Inc(ptA.y); Dec(ptB.x); Inc(ptB.y); end;
|
atLeft: begin Dec(ptA.x); Inc(ptA.y); Dec(ptB.x); Inc(ptB.y); end;
|
||||||
atRight: begin Inc(ptA.x); Inc(ptA.y); Inc(ptB.x); Inc(ptB.y); end;
|
atRight: begin Inc(ptA.x); Inc(ptA.y); Inc(ptB.x); Inc(ptB.y); end;
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure ShadowLine(p1, p2: TPoint);
|
procedure ShadowLine(p1, p2: TPoint);
|
||||||
begin
|
begin
|
||||||
Canvas.Pen.Color:= Colors[FShadowType];
|
Canvas.Pen.Color:= Colors[FShadowType];
|
||||||
Canvas.MoveTo(p1);
|
Canvas.MoveTo(p1);
|
||||||
Canvas.LineTo(p2);
|
Canvas.LineTo(p2);
|
||||||
Offset(p1, p2);
|
Offset(p1, p2);
|
||||||
Canvas.Pen.Color:= cl3DShadow;
|
Canvas.Pen.Color:= cl3DShadow;
|
||||||
Canvas.MoveTo(p1);
|
Canvas.MoveTo(p1);
|
||||||
Canvas.LineTo(p2);
|
Canvas.LineTo(p2);
|
||||||
if (Height>13) then
|
if (Height>13) then
|
||||||
begin
|
begin
|
||||||
Offset(p1, p2);
|
Offset(p1, p2);
|
||||||
Canvas.MoveTo(p1);
|
Canvas.MoveTo(p1);
|
||||||
Canvas.LineTo(p2);
|
Canvas.LineTo(p2);
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Canvas.Brush.Color := Color;
|
Canvas.Brush.Color := Color;
|
||||||
Canvas.FillRect(ClientRect);
|
Canvas.FillRect(ClientRect);
|
||||||
|
|
||||||
Canvas.Pen.Color:= FArrowColor;
|
Canvas.Pen.Color:= FArrowColor;
|
||||||
Canvas.Brush.Color:= FArrowColor;
|
Canvas.Brush.Color:= FArrowColor;
|
||||||
CalcTrianglePoints;
|
CalcTrianglePoints;
|
||||||
Canvas.Polygon(FT);
|
Canvas.Polygon(FT);
|
||||||
|
|
||||||
if (FShadowType <> stNone)
|
if (FShadowType <> stNone)
|
||||||
then ShadowLine(FT[ptB], FT[ptC]);
|
then ShadowLine(FT[ptB], FT[ptC]);
|
||||||
|
|
||||||
inherited Paint;
|
inherited Paint;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
constructor TArrow.Create(aOwner: TComponent);
|
constructor TArrow.Create(aOwner: TComponent);
|
||||||
begin
|
begin
|
||||||
inherited Create(aOwner);
|
inherited Create(aOwner);
|
||||||
Constraints.MinHeight:= ArrowMinHeight;
|
Constraints.MinHeight:= ArrowMinHeight;
|
||||||
Constraints.MinWidth:= ArrowMinHeight;
|
Constraints.MinWidth:= ArrowMinHeight;
|
||||||
with GetControlClassDefaultSize do
|
with GetControlClassDefaultSize do
|
||||||
SetInitialBounds(0, 0, cx, cy);
|
SetInitialBounds(0, 0, cx, cy);
|
||||||
ControlStyle := ControlStyle - [csSetCaption];
|
ControlStyle := ControlStyle - [csSetCaption];
|
||||||
FArrowType:= atLeft; // set defaults to match TArrow component
|
FArrowType:= atLeft; // set defaults to match TArrow component
|
||||||
FShadowType:= stEtchedIn;
|
FShadowType:= stEtchedIn;
|
||||||
FArrowColor:= clBlack;
|
FArrowColor:= clBlack;
|
||||||
Canvas.Pen.Color := clBlack;
|
Canvas.Pen.Color := clBlack;
|
||||||
if Assigned(Parent)
|
if Assigned(Parent)
|
||||||
then Color:= Parent.Color
|
then Color:= Parent.Color
|
||||||
else Color:= clBtnFace;
|
else Color:= clBtnFace;
|
||||||
Canvas.Brush.Color := Color;
|
Canvas.Brush.Color := Color;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
end.
|
end.
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user