You've already forked lazarus-ccr
Move Industrial package from Lazarus sources to CCR.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5565 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
juhamanninen
371
components/industrialstuff/source/indled.pas
Normal file
371
components/industrialstuff/source/indled.pas
Normal file
@@ -0,0 +1,371 @@
|
||||
{ Component(s):
|
||||
TindLed ---> old cindy name tcyled
|
||||
|
||||
Description:
|
||||
A simple led with Group feature
|
||||
depending on the state: ON/OFF/DISABLE
|
||||
|
||||
|
||||
* ***** BEGIN LICENSE BLOCK *****
|
||||
*
|
||||
* Version: MPL 1.1
|
||||
*
|
||||
* The contents of this file are subject to the Mozilla Public License Version
|
||||
* 1.1 (the "License"); you may not use this file except in compliance with the
|
||||
* License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
|
||||
*
|
||||
* Software distributed under the License is distributed on an "AS IS" basis,
|
||||
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
|
||||
* the specific language governing rights and limitations under the License.
|
||||
*
|
||||
* The Initial Developer of the Original Code is Mauricio
|
||||
* (https://sourceforge.net/projects/tcycomponents/).
|
||||
*
|
||||
* No contributors for now ...
|
||||
*
|
||||
* Alternatively, the contents of this file may be used under the terms of
|
||||
* either the GNU General Public License Version 2 or later (the "GPL"), or the
|
||||
* GNU Lesser General Public License Version 2.1 or later (the "LGPL"), in which
|
||||
* case the provisions of the GPL or the LGPL are applicable instead of those
|
||||
* above. If you wish to allow use of your version of this file only under the
|
||||
* terms of either the GPL or the LGPL, and not to allow others to use your
|
||||
* version of this file under the terms of the MPL, indicate your decision by
|
||||
* deleting the provisions above and replace them with the notice and other
|
||||
* provisions required by the LGPL or the GPL. If you do not delete the
|
||||
* provisions above, a recipient may use your version of this file under the
|
||||
* terms of any one of the MPL, the GPL or the LGPL.
|
||||
*
|
||||
* ***** END LICENSE BLOCK *****
|
||||
|
||||
Modified by Jurassic Pork 2013 for package Industrial of Lazarus}
|
||||
|
||||
unit IndLed;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses Classes, Types, Controls, Graphics, indcyBaseLed, indcyTypes, indcyClasses, indcyGraphics;
|
||||
|
||||
type
|
||||
TShapeType = (stRectangle, stRoundRect, stEllipse);
|
||||
|
||||
TcyCustomLed = class(TcyBaseLed)
|
||||
private
|
||||
FLedColorOn: TColor;
|
||||
FLedColorOff: TColor;
|
||||
FLedColorDisabled: TColor;
|
||||
FShapeRoundRectX: Integer;
|
||||
FShapeRoundRectY: Integer;
|
||||
FShapeLedColorOn: TColor;
|
||||
FShapeLedColorOff: TColor;
|
||||
FShapeLedColorDisabled: TColor;
|
||||
FBevels: TcyBevels;
|
||||
FShapeType: TShapeType;
|
||||
FShapePenWidth: Word;
|
||||
FTransparent: boolean;
|
||||
procedure SetShapeLedColorOn(Value: TColor);
|
||||
procedure SetShapePenWidth(Value: Word);
|
||||
procedure SetShapeType(Value: TShapeType);
|
||||
procedure SetShapeRoundRectX(Value: Integer);
|
||||
procedure SetShapeRoundRectY(Value: Integer);
|
||||
procedure SetBevels(const Value: TcyBevels);
|
||||
procedure SetLedColorDisabled(Value: TColor);
|
||||
procedure SetLedColorOff(Value: TColor);
|
||||
procedure SetLedColorOn(Value: TColor);
|
||||
procedure SetTransparent(const Value: boolean);
|
||||
procedure SetShapeLedColorDisabled(const Value: TColor);
|
||||
procedure SetShapeLedColorOff(const Value: TColor);
|
||||
protected
|
||||
procedure Paint; override;
|
||||
function TransparentColorAtPos(Point: TPoint): boolean; override;
|
||||
property Transparent: boolean read FTransparent write SetTransparent default false;
|
||||
property LedColorOn: TColor read FLedColorOn write SetLedColorOn;
|
||||
property LedColorOff: TColor read FLedColorOff write SetLedColorOff;
|
||||
property LedColorDisabled: TColor read FLedColorDisabled write SetLedColorDisabled;
|
||||
property ShapeLedColorOn: TColor read FShapeLedColorOn write SetShapeLedColorOn;
|
||||
property ShapeLedColorOff: TColor read FShapeLedColorOff write SetShapeLedColorOff;
|
||||
property ShapeLedColorDisabled: TColor read FShapeLedColorDisabled write SetShapeLedColorDisabled;
|
||||
property ShapePenWidth: Word read FShapePenWidth write SetShapePenWidth default 1;
|
||||
property ShapeType: TShapeType read FShapeType write SetShapeType default stRectangle;
|
||||
property ShapeRoundRectX: Integer read FShapeRoundRectX write SetShapeRoundRectX default 10;
|
||||
property ShapeRoundRectY: Integer read FShapeRoundRectY write SetShapeRoundRectY default 10;
|
||||
property Bevels: TcyBevels read FBevels write SetBevels;
|
||||
property Height default 25;
|
||||
property Width default 25;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
end;
|
||||
|
||||
TindLed = class(TcyCustomLed)
|
||||
private
|
||||
protected
|
||||
public
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property Color;
|
||||
property Constraints;
|
||||
property Enabled;
|
||||
property Visible;
|
||||
property OnClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property ShowHint;
|
||||
// Herited from TcyBaseLed :
|
||||
property AllowAllOff;
|
||||
property GroupIndex;
|
||||
property LedValue;
|
||||
property ReadOnly;
|
||||
// Herited from TcyCustomLed :
|
||||
property Bevels;
|
||||
property LedColorOn;
|
||||
property LedColorOff;
|
||||
property LedColorDisabled;
|
||||
property ShapeLedColorOn;
|
||||
property ShapeLedColorOff;
|
||||
property ShapeLedColorDisabled;
|
||||
property ShapePenWidth;
|
||||
property ShapeType;
|
||||
property ShapeRoundRectX;
|
||||
property ShapeRoundRectY;
|
||||
property Transparent;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
constructor TcyCustomLed.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FBevels := TcyBevels.Create(self, TcyBevel);
|
||||
|
||||
// Determine at design time if
|
||||
// the form is loading or if we have just added the component at design time :
|
||||
if csDesigning in ComponentState
|
||||
then
|
||||
if Owner <> nil
|
||||
then
|
||||
if not (csLoading in Owner.ComponentState) // we have just added the component at design time
|
||||
then begin
|
||||
with FBevels.Add do // Frame
|
||||
begin
|
||||
HighlightColor := clBlack;
|
||||
ShadowColor := clBlack;
|
||||
end;
|
||||
|
||||
with FBevels.Add do // Inner 3D frame
|
||||
Width := 3;
|
||||
|
||||
with FBevels.Add do // Contrast Frame
|
||||
Style := bcLowered;
|
||||
|
||||
with FBevels.Add do // Border between Bevels and Shape
|
||||
begin
|
||||
HighlightColor := clBlack;
|
||||
ShadowColor := clBlack;
|
||||
Width := 1;
|
||||
end;
|
||||
end;
|
||||
|
||||
FTransparent := false;
|
||||
FShapeType := stRectangle;
|
||||
FShapePenWidth:= 1;
|
||||
FShapeRoundRectX := 10;
|
||||
FShapeRoundRectY := 10;
|
||||
FShapeLedColorOn := clGreen;
|
||||
FShapeLedColorOff := $00004000; // Dark green
|
||||
FShapeLedColorDisabled := $00003468; // Dark maroon
|
||||
FLedColorOn:= clLime;
|
||||
FLedColorOff:= clGreen;
|
||||
FLedColorDisabled:= $000059B3; // Maroon
|
||||
Height := 25;
|
||||
Width := 25;
|
||||
end;
|
||||
|
||||
destructor TcyCustomLed.Destroy;
|
||||
begin
|
||||
FBevels.Free;
|
||||
FBevels := Nil;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.Paint;
|
||||
var
|
||||
Rect: TRect;
|
||||
begin
|
||||
Rect := ClientRect;
|
||||
// Draw background :
|
||||
if not FTransparent
|
||||
then begin
|
||||
Canvas.Brush.Color := Color;
|
||||
Canvas.FillRect(Rect);
|
||||
end;
|
||||
|
||||
Bevels.DrawBevels(Canvas, Rect, false);
|
||||
|
||||
case ledStatus of
|
||||
lsOn: Canvas.Brush.Color := FLedColorOn;
|
||||
lsOff: Canvas.Brush.Color := FLedColorOff;
|
||||
lsDisabled: Canvas.Brush.Color := FLedColorDisabled;
|
||||
end;
|
||||
|
||||
if FShapePenWidth > 0
|
||||
then begin
|
||||
Rect := classes.Rect(Rect.Left + FShapePenWidth div 2,
|
||||
Rect.Top + FShapePenWidth div 2,
|
||||
Rect.Right - (FShapePenWidth-1) div 2,
|
||||
Rect.Bottom - (FShapePenWidth-1) div 2);
|
||||
|
||||
case ledStatus of
|
||||
lsOn: Canvas.Pen.Color := FShapeLedColorOn;
|
||||
lsOff: Canvas.Pen.Color := FShapeLedColorOff;
|
||||
lsDisabled: Canvas.Pen.Color := FShapeLedColorDisabled;
|
||||
end;
|
||||
|
||||
Canvas.Pen.Width := FShapePenWidth;
|
||||
end
|
||||
else begin
|
||||
Canvas.Pen.Color := Canvas.Brush.Color;
|
||||
Canvas.Pen.Width := 1;
|
||||
end;
|
||||
|
||||
case FShapeType of
|
||||
stRectangle: canvas.Rectangle(Rect);
|
||||
stRoundRect: canvas.RoundRect(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, ShapeRoundRectX, ShapeRoundRectY);
|
||||
stEllipse : canvas.Ellipse(Rect);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TcyCustomLed.TransparentColorAtPos(Point: TPoint): boolean;
|
||||
begin
|
||||
RESULT := false;
|
||||
|
||||
if FTransparent and (Bevels.Count = 0) and (FShapeType = stEllipse)
|
||||
then RESULT := not PointInEllipse(Point, ClientRect);
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetTransparent(const Value: boolean);
|
||||
begin
|
||||
if value <> FTransparent
|
||||
then begin
|
||||
FTransparent := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetShapeLedColorOn(Value: TColor);
|
||||
begin
|
||||
if value <> FShapeLedColorOn
|
||||
then begin
|
||||
FShapeLedColorOn := Value;
|
||||
|
||||
if GetLedStatus = lsOn
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetShapeLedColorOff(const Value: TColor);
|
||||
begin
|
||||
if value <> FShapeLedColorOff
|
||||
then begin
|
||||
FShapeLedColorOff := Value;
|
||||
|
||||
if GetLedStatus = lsOff
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetShapeLedColorDisabled(const Value: TColor);
|
||||
begin
|
||||
if value <> FShapeLedColorDisabled
|
||||
then begin
|
||||
FShapeLedColorDisabled := Value;
|
||||
|
||||
if GetLedStatus = lsDisabled
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetShapePenWidth(Value: Word);
|
||||
begin
|
||||
if value <> FShapePenWidth
|
||||
then begin
|
||||
FShapePenWidth := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetShapeRoundRectX(Value: Integer);
|
||||
begin
|
||||
if Value <> FShapeRoundRectX
|
||||
then begin
|
||||
FShapeRoundRectX := value;
|
||||
|
||||
if FShapeType = stRoundRect
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetShapeRoundRectY(Value: Integer);
|
||||
begin
|
||||
if Value <> FShapeRoundRectY
|
||||
then begin
|
||||
FShapeRoundRectY := value;
|
||||
|
||||
if FShapeType = stRoundRect
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetShapeType(Value: TShapeType);
|
||||
begin
|
||||
if value <> FShapeType
|
||||
then begin
|
||||
FShapeType := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetLedColorOn(Value: TColor);
|
||||
begin
|
||||
if value <> FLedColorOn
|
||||
then begin
|
||||
FLedColorOn := Value;
|
||||
|
||||
if GetLedStatus = lsOn
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetLedColorOff(Value: TColor);
|
||||
begin
|
||||
if value <> FLedColorOff
|
||||
then begin
|
||||
FLedColorOff := Value;
|
||||
|
||||
if GetLedStatus = lsOff
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetLedColorDisabled(Value: TColor);
|
||||
begin
|
||||
if value <> FLedColorDisabled
|
||||
then begin
|
||||
FLedColorDisabled := Value;
|
||||
|
||||
if GetLedStatus = lsDisabled
|
||||
then Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TcyCustomLed.SetBevels(const Value: TcyBevels);
|
||||
begin
|
||||
FBevels := Value;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user