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

Move Industrial package from Lazarus sources to CCR.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5565 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
juhamanninen
2016-12-28 18:43:45 +00:00
parent 26d73deff8
commit 560a1e5ba2
44 changed files with 3581 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
components/industrialstuff/Example/ButtonSamples/CMP_Button_Disa.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.3 KiB

BIN
components/industrialstuff/Example/ButtonSamples/CMP_Button_Off.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.3 KiB

BIN
components/industrialstuff/Example/ButtonSamples/CMP_Button_On.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.7 KiB

105
components/industrialstuff/Example/Ex_IndustrialStuff.lpi Normal file
View File

@@ -0,0 +1,105 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="Ex_IndustrialStuff"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="industrial"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="Ex_IndustrialStuff.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Ex_IndustrialStuff"/>
</Unit0>
<Unit1>
<Filename Value="u_industrial.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="u_industrial"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="Ex_IndustrialStuff"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<Optimizations>
<OptimizationLevel Value="2"/>
</Optimizations>
</CodeGeneration>
<Linking>
<LinkSmart Value="True"/>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
components/industrialstuff/Example/Ex_IndustrialStuff.lpr Normal file
View File

@@ -0,0 +1,21 @@
program Ex_IndustrialStuff;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, u_industrial
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

BIN
components/industrialstuff/Example/Ex_IndustrialStuff.res Normal file
View File

Binary file not shown.

134
components/industrialstuff/Example/u_industrial.lfm Normal file
View File

@@ -0,0 +1,134 @@
object Form1: TForm1
Left = 123
Height = 166
Top = 95
Width = 568
Caption = 'IndustrialStuff Example'
ClientHeight = 166
ClientWidth = 568
LCLVersion = '1.1'
object indLed1: TindLed
Left = 200
Height = 35
Top = 33
Width = 34
LedValue = False
Bevels = <
item
HighlightColor = clBlack
ShadowColor = clBlack
end
item
Width = 3
end
item
Style = bcLowered
end
item
HighlightColor = clBlack
ShadowColor = clBlack
end>
LedColorOn = clLime
LedColorOff = clGreen
LedColorDisabled = 22963
ShapeLedColorOn = clGreen
ShapeLedColorOff = 16384
ShapeLedColorDisabled = 13416
end
object StopLightSensor1: TStopLightSensor
Left = 96
Height = 59
Top = 24
Width = 25
Center = True
Picture.Data = {
1754506F727461626C654E6574776F726B47726170686963EF00000089504E47
0D0A1A0A0000000D49484452000000150000002B08020000001805541C000000
B649444154789CED94010E84200C04FBF47B9A3FE304142AB5AD5B721763DCA0
21C1D9D6BA919639D17A7DA24A296D3CE15AC11FF3ADCF089F5F8FA8AED3072C
9EC39A85CA77389FAB161E5F15E7C5FA173F3B3F69017FBF6611CF8FABFBE7BF
DCFB1EE08FF0B985959F8A9523D5C2E22B9C7F6FAC0B8017CDE3F5A505967F1B
76F8C1E2CD3FCEEFD363FBEB3C87350B277F54226C58983CCB7FB3C0F2CF2B47
EA4B0B2CFF36ECF083C5F3F3BF84B4F169427D48317D01F81FF539473C105700
00000049454E44AE426082
}
State = slRED
end
object LEDNumber1: TLEDNumber
Left = 32
Height = 28
Top = 116
Width = 177
Caption = 'Lazarus'
OffColor = 930866
OnColor = clLime
end
object AnalogSensor1: TAnalogSensor
Left = 256
Height = 136
Top = 8
Width = 153
BorderWidth = 2
BorderStyle = bsSingle
Caption = 'level : '
ClientHeight = 132
ClientWidth = 149
Font.Height = -16
Font.Name = 'Arial'
ParentColor = False
ParentFont = False
TabOrder = 0
ShowText = True
ShowLevel = True
ColorFore = clLime
ColorBack = clBlack
Value = 20
ValueMin = 0
ValueMax = 100
ValueRed = 30
ValueYellow = 60
AnalogKind = akVertical
end
object indGnouMeter1: TindGnouMeter
Left = 424
Height = 129
Top = 17
Width = 120
Caption = 'indGnouMeter1'
Value = 70
Color = clPurple
ParentColor = False
ColorFore = clRed
ColorBack = clInactiveCaption
SignalUnit = 'Units'
ValueMin = 0
ValueMax = 100
Digits = 0
Increment = 10
ShowIncrements = True
Transparent = True
GapTop = 20
GapBottom = 10
BarThickness = 5
MarkerColor = clBlue
ShowMarker = True
end
object Arrow1: TArrow
Left = 48
Height = 20
Top = 41
Width = 20
Constraints.MinHeight = 8
Constraints.MinWidth = 8
end
object AdvLed1: TAdvLed
Left = 152
Height = 24
Top = 40
Width = 24
Kind = lkYellowLight
State = lsOn
Blink = False
AutoSize = True
end
end

39
components/industrialstuff/Example/u_industrial.pas Normal file
View File

@@ -0,0 +1,39 @@
unit u_industrial;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, IndLed, Sensors, LedNumber,
IndGnouMeter, AdvLed, Forms, Controls, Graphics, Dialogs, Arrow;
type
{ TForm1 }
TForm1 = class(TForm)
AdvLed1: TAdvLed;
AnalogSensor1: TAnalogSensor;
Arrow1: TArrow;
indGnouMeter1: TindGnouMeter;
indLed1: TindLed;
LEDNumber1: TLEDNumber;
StopLightSensor1: TStopLightSensor;
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
end.

95
components/industrialstuff/industrial.lpk Normal file
View File

@@ -0,0 +1,95 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="industrial"/>
<Author Value="Jurassic Pork"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="source"/>
<OtherUnitFiles Value="source"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
<Optimizations>
<OptimizationLevel Value="2"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="Industrial-themed (IPV/PCV) components and gauges (e.g. LEDs)."/>
<License Value="MPL + GPL "/>
<Version Minor="1"/>
<Files Count="10">
<Item1>
<Filename Value="source\indled.pas"/>
<UnitName Value="IndLed"/>
</Item1>
<Item2>
<Filename Value="source\sensors.pas"/>
<UnitName Value="Sensors"/>
</Item2>
<Item3>
<Filename Value="source\AllIndustrialRegister.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="AllIndustrialRegister"/>
</Item3>
<Item4>
<Filename Value="source\lednumber.pas"/>
<UnitName Value="LedNumber"/>
</Item4>
<Item5>
<Filename Value="source\indgnoumeter.pas"/>
<UnitName Value="IndGnouMeter"/>
</Item5>
<Item6>
<Filename Value="source\AdvLed.pas"/>
<UnitName Value="AdvLed"/>
</Item6>
<Item7>
<Filename Value="source\indcyBaseLed.pas"/>
<UnitName Value="indcyBaseLed"/>
</Item7>
<Item8>
<Filename Value="source\indcyClasses.pas"/>
<UnitName Value="indcyClasses"/>
</Item8>
<Item9>
<Filename Value="source\indcyGraphics.pas"/>
<UnitName Value="indcyGraphics"/>
</Item9>
<Item10>
<Filename Value="source\indcyTypes.pas"/>
<UnitName Value="indcyTypes"/>
</Item10>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package>
</CONFIG>

23
components/industrialstuff/industrial.pas Normal file
View File

@@ -0,0 +1,23 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit industrial;
{$warn 5023 off : no warning about unused units}
interface
uses
IndLed, Sensors, AllIndustrialRegister, LedNumber, indGnouMeter, AdvLed,
indcyBaseLed, indcyClasses, indcyGraphics, indcyTypes, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('AllIndustrialRegister', @AllIndustrialRegister.Register);
end;
initialization
RegisterPackage('industrial', @Register);
end.

BIN
components/industrialstuff/resources/black.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 775 B

3
components/industrialstuff/resources/build.bat Normal file
View File

@@ -0,0 +1,3 @@
..\..\..\tools\lazres ..\source\sensors.res @sensors.txt
..\..\..\tools\lazres ..\source\industrial_icons.res @industrial_icons.txt
..\..\..\tools\lazres ..\source\ledbuttons.res @ledbuttons.txt

34
components/industrialstuff/resources/bulboff.xpm Normal file
View File

@@ -0,0 +1,34 @@
/* XPM */
static char * LEDBULBOFF[] = {
"15 15 16 1",
" c #000000",
". c #800000",
"+ c #008000",
"@ c #808000",
"# c #000080",
"$ c #800080",
"% c #008080",
"& c #808080",
"* c #C0C0C0",
"= c #FF0000",
"- c #00FF00",
"; c #FFFF00",
"> c #0000FF",
", c #FF00FF",
"' c #00FFFF",
") c #FFFFFF",
"@@@@@@@@@@@@@@@",
"@@@@@@@@@@@@@@@",
"@@@@@@@@@@@@@@@",
"@@@@@@@@@@@@@@@",
"@@@@@@ @@@@@@",
"@@@@@ ))) @@@@@",
"@@@@ ))))) @@@@",
"@@@@ ))&)) @@@@",
"@@@@ ))&)) @@@@",
"@@@@@ )&) @@@@@",
"@@@@@@ ) @@@@@@",
"@@@@@@ ) @@@@@@",
"@@@@@@ @@@@@@",
"@@@@@@ * @@@@@@",
"@@@@@@ @@@@@@"};

34
components/industrialstuff/resources/bulbon.xpm Normal file
View File

@@ -0,0 +1,34 @@
/* XPM */
static char * LEDBULBON[] = {
"15 15 16 1",
" c #000000",
". c #800000",
"+ c #008000",
"@ c #808000",
"# c #000080",
"$ c #800080",
"% c #008080",
"& c #808080",
"* c #C0C0C0",
"= c #FF0000",
"- c #00FF00",
"; c #FFFF00",
"> c #0000FF",
", c #FF00FF",
"' c #00FFFF",
") c #FFFFFF",
"@@@@@@@;@@@@@@@",
"@@@@@@@;@@@@@@@",
"@@;@@;;;;;@@;@@",
"@@@;;;;;;;;;@@@",
"@@@;;; ;;;@@@",
"@@;;; );) ;;;@@",
"@@;; ););) ;;@@",
";;;; ;)&); ;;;;",
"@@;; );&;) ;;@@",
"@@;;; )&) ;;;@@",
"@@@;;; ) ;;;@@@",
"@@@;;; ; ;;;@@@",
"@@;@@; ;@@;@@",
"@@@@@@ * @@@@@@",
"@@@@@@ @@@@@@"};

BIN
components/industrialstuff/resources/green.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.7 KiB

6
components/industrialstuff/resources/industrial_icons.txt Normal file
View File

@@ -0,0 +1,6 @@
tadvled.png
tanalogsensor.png
tindgnoumeter.png
tindled.png
tlednumber.png
tstoplightsensor.png

6
components/industrialstuff/resources/ledbuttons.txt Normal file
View File

@@ -0,0 +1,6 @@
black.png
green.png
red.png
yellow.png
bulboff.xpm
bulbon.xpm

BIN
components/industrialstuff/resources/red.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.8 KiB

4
components/industrialstuff/resources/sensors.txt Normal file
View File

@@ -0,0 +1,4 @@
stop_green.png
stop_red.png
stop_unknown.png
stop_yellow.png

BIN
components/industrialstuff/resources/stop_green.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 235 B

BIN
components/industrialstuff/resources/stop_red.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 239 B

BIN
components/industrialstuff/resources/stop_unknown.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 244 B

BIN
components/industrialstuff/resources/stop_yellow.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 235 B

BIN
components/industrialstuff/resources/tadvled.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.7 KiB

BIN
components/industrialstuff/resources/tanalogsensor.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 193 B

BIN
components/industrialstuff/resources/tindadvled.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 787 B

BIN
components/industrialstuff/resources/tindgnoumeter.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 363 B

BIN
components/industrialstuff/resources/tindled.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 313 B

BIN
components/industrialstuff/resources/tlednumber.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 219 B

BIN
components/industrialstuff/resources/tstoplightsensor.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 258 B

BIN
components/industrialstuff/resources/yellow.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.8 KiB

330
components/industrialstuff/source/AdvLed.pas Normal file
View File

@@ -0,0 +1,330 @@
(******************************************************
AdvLed by Jurassic Pork 2013 for Lazarus
created from TComled of ComPort Library ver. 3.00
written by Dejan Crnila, 1998 - 2002
email: dejancrn@yahoo.com
****************************************************************************
This file is part of Lazarus
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
****************************************************************************
Unit: AdvLed.pas
******************************************************)
unit AdvLed;
{$mode objfpc}{$H+}
interface
uses
LCLType, Classes, ExtCtrls, Controls, Graphics;
type
// property types
TLedBitmap = Graphics.TPicture;
// TLedKind = (lkRedLight, lkGreenLight, lkBlueLight, lkYellowLight, lkPurpleLight, lkBulb, lkCustom);
TLedKind = (lkRedLight, lkGreenLight, lkYellowLight, lkBulb, lkCustom);
TLedState = (lsDisabled, lsOff, lsOn);
TAdvLedGlyphs = array[TLedState] of TLedBitmap;
TLedStateEvent = procedure(Sender: TObject; AState: TLedState) of object;
// led control that shows the state of serial signals
TAdvLed = class(TCustomImage)
private
FKind: TLedKind;
FState: TLedState;
FBlink: Boolean;
FOnChange: TLedStateEvent;
FGlyphs: TAdvLedGlyphs;
FBlinkTimer: TTimer;
function GetGlyph(const Index: Integer): TLedBitmap;
function GetBlinkDuration: Integer;
procedure SetKind(const Value: TLedKind);
procedure SetState(const Value: TLedState);
procedure SetGlyph(const Index: Integer; const Value: TLedBitmap);
procedure SetBlinkDuration(const Value: Integer);
procedure SetBlink(const Value: Boolean);
function StoredGlyph(const Index: Integer): Boolean;
procedure SelectLedBitmap(const LedKind: TLedKind);
function BitmapToDraw: TLedBitmap;
procedure BitmapNeeded;
procedure DoTimer(Sender: TObject);
procedure GlyphChanged(Sender: TObject);
protected
FlipFLop : Boolean;
procedure DoChange(AState: TLedState); dynamic;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
// kind property must be published before GlyphOn, GlyphOff,GlyphDisable
property Kind: TLedKind read FKind write SetKind default lkRedLight;
property GlyphDisabled: TLedBitmap index 0 read GetGlyph
write SetGlyph stored StoredGlyph;
property GlyphOff: TLedBitmap index 1 read GetGlyph
write SetGlyph stored StoredGlyph;
property GlyphOn: TLedBitmap index 2 read GetGlyph
write SetGlyph stored StoredGlyph;
property State: TLedState read FState write SetState;
property Blink: Boolean read FBlink write SetBlink;
property BlinkDuration: Integer read GetBlinkDuration write SetBlinkDuration default 1000;
property Align;
property AutoSize default true;
property Center;
property Constraints;
// property Picture;
property Visible;
property OnClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property Stretch;
property Showhint;
property Transparent;
property Proportional;
property OnPictureChanged;
property OnChange: TLedStateEvent read FOnChange write FOnChange;
{ property Align;
property DragCursor;
property DragMode;
property Enabled;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property Anchors;
property Constraints;
property DragKind;
property ParentBiDiMode;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
property OnEndDock;
property OnResize;
property OnStartDock;
property OnContextPopup; }
end;
implementation
{$R ledbuttons.res}
(*****************************************
* auxilary functions *
*****************************************)
function Min(A, B: Integer): Integer;
begin
if A < B then
Result := A
else
Result := B;
end;
function Max(A, B: Integer): Integer;
begin
if A > B then
Result := A
else
Result := B;
end;
(*****************************************
* TAdvLed control *
*****************************************)
// create control
constructor TAdvLed.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle - [csSetCaption];
AutoSize:=True;
FGlyphs[lsOn] := TLedBitmap.Create;
FGlyphs[lsOff] := TLedBitmap.Create;
FGlyphs[lsDisabled] := TLedBitmap.Create;
FGlyphs[lsOn].OnChange:= @GlyphChanged;
FGlyphs[lsOff].OnChange:= @GlyphChanged;
FGlyphs[lsDisabled].OnChange:= @GlyphChanged;
FBlinkTimer := TTimer.Create(nil);
FBlinkTimer.OnTimer := @DoTimer;
FBlinkTimer.Enabled := false;
if (csDesigning in ComponentState) then BitmapNeeded;
end;
// destroy control
destructor TAdvLed.Destroy;
begin
FBlinkTimer.Free;
FGlyphs[lsOn].Free;
FGlyphs[lsOff].Free;
FGlyphs[lsDisabled].Free;
inherited Destroy;
end;
// loaded
procedure TAdvLed.Loaded;
begin
Try
If (csDesigning in ComponentState) Then Exit ;
// Load Bitmap if necessary
BitmapNeeded;
Finally
inherited Loaded;
End;
end;
// timer
procedure TAdvLed.DoTimer(Sender: TObject);
begin
if FlipFlop then
SetState(lsOn )
else
SetState(lsoff);
FlipFlop := Not FlipFlop;
end;
// trigger OnChangeEvent
procedure TAdvLed.DoChange(AState: TLedState);
begin
if Assigned(FOnChange) then
FOnChange(Self, AState);
invalidate;
end;
// if bitmap is empty, load it
procedure TAdvLed.BitmapNeeded;
begin
if (FGlyphs[lsOn].Bitmap.Empty) or (FGlyphs[lsOff].Bitmap.Empty) or
(FGlyphs[lsDisabled].Bitmap.Empty) then
begin
SelectLedBitmap(FKind);
Picture.Assign(BitmapToDraw);
end;
end;
procedure TAdvLed.SelectLedBitmap(const LedKind: TLedKind);
const
{ OnBitmaps: array[TLedKind] of string = ('LEDREDON', 'LEDGREENON', 'LEDBLUEON',
'LEDYELLOWON', 'LEDPURPLEON', 'LEDBULBON', '');
OffBitmaps: array[TLedKind] of string = ('LEDREDOFF', 'LEDGREENOFF',
'LEDBLUEOFF', 'LEDYELLOWOFF', 'LEDPURPLEOFF', 'LEDBULBOFF' ,'');
DisabledBitmaps: array[TLedKind] of string = ('LEDREDOFF', 'LEDGREENOFF',
'LEDBLUEOFF', 'LEDYELLOWOFF', 'LEDPURPLEOFF', 'LEDBULBOFF' ,''); }
OnBitmaps: array[TLedKind] of string = ('RED', 'GREEN', 'YELLOW', 'BULBON', '');
OffBitmaps: array[TLedKind] of string = ('BLACK', 'BLACK', 'BLACK','BULBOFF', '');
DisabledBitmaps: array[TLedKind] of string = ('BLACK', 'BLACK', 'BLACK','BULBOFF' ,'');
begin
if LedKind <> lkCustom then
begin
FGlyphs[lsOn].LoadFromResourceName(HInstance, OnBitmaps[LedKind]);
FGlyphs[lsOff].LoadFromResourceName(HInstance, OffBitmaps[LedKind]);
FGlyphs[lsDisabled].LoadFromResourceName(HInstance, DisabledBitmaps[LedKind]);
end;
end;
// set led kind
procedure TAdvLed.SetKind(const Value: TLedKind);
begin
if FKind <> Value then
begin
FKind := Value;
SelectLedBitmap(FKind);
Picture.Assign(BitmapToDraw);
end;
end;
// set led state
procedure TAdvLed.SetState(const Value: TLedState);
begin
FState := Value;
if not (csLoading in ComponentState) then
DoChange(FState);
Picture.Assign(BitmapToDraw);
end;
function TAdvLed.GetGlyph(const Index: Integer): TLedBitmap;
begin
case Index of
0: Result := FGlyphs[lsDisabled];
1: Result := FGlyphs[lsOff];
2: Result := FGlyphs[lsOn];
else
Result := nil;
end;
end;
procedure TAdvLed.GlyphChanged(Sender: TObject );
begin
// if (csDesigning in ComponentState) then Picture.Assign(Sender as TPicture);
if (csDesigning in ComponentState) then
begin
if Sender = FGlyphs[lsDisabled] then FState := lsDisabled;
if Sender = FGlyphs[lsOff] then FState := lsOff;
if Sender = FGlyphs[lsOn] then FState := lsOn;
Picture.Assign(Sender as TPicture);
end;
end;
// set custom bitmap
procedure TAdvLed.SetGlyph(const Index: Integer; const Value: TLedBitmap);
begin
if FKind = lkCustom then
begin
case Index of
0: FGlyphs[lsDisabled].Assign(Value);
1: FGlyphs[lsOff].Assign(Value);
2: FGlyphs[lsOn].Assign(Value);
end;
end;
Picture.Assign(BitmapToDraw);
end;
function TAdvLed.StoredGlyph(const Index: Integer): Boolean;
begin
Result := FKind = lkCustom;
end;
// get bitmap for drawing
function TAdvLed.BitmapToDraw: TLedBitmap;
var
ToDraw: TLedState;
begin
if not Enabled then
ToDraw := lsOff
else
ToDraw := FState;
Result := FGlyphs[ToDraw];
end;
function TAdvLed.GetBlinkDuration: Integer;
begin
Result := FBlinkTimer.Interval;
end;
procedure TAdvLed.SetBlinkDuration(const Value: Integer);
begin
FBlinkTimer.Interval := Value;
end;
// set led blink
procedure TAdvLed.SetBlink(const Value: Boolean);
begin
FBlink :=Value;
if (csDesigning in ComponentState) then Exit;
FBlinkTimer.Enabled := FBlink;
end;
end.

30
components/industrialstuff/source/AllIndustrialRegister.pas Normal file
View File

@@ -0,0 +1,30 @@
{**********************************************************************
Package industrial Lazarus
This unit is part of Lazarus Project
***********************************************************************}
unit AllIndustrialRegister;
interface
uses
Classes, LResources, AdvLed, IndLed, LedNumber, Sensors, IndGnouMeter;
procedure Register;
implementation
{$R industrial_icons.res}
//==========================================================
procedure Register;
begin
RegisterComponents ('Industrial',[
TAdvLed, TIndLed, TLedNumber, TStopLightSensor, TAnalogSensor, TindGnouMeter]);
end;
end.

228
components/industrialstuff/source/indcyBaseLed.pas Normal file
View File

@@ -0,0 +1,228 @@
{ Component(s):
tcyBaseLed
Description:
A base led component with Group feature
Led states : 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/).
*
* 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 *****}
unit indcyBaseLed;
{$mode objfpc}{$H+}
interface
uses LCLIntf, LCLType, LMessages, Messages, Classes, Types, Controls, Graphics;
type
TLedStatus = (lsOn, lsOff, lsDisabled);
TcyBaseLed = class(TGraphicControl)
private
FGroupIndex: Integer;
FAllowAllOff: Boolean;
FLedValue: Boolean;
FReadOnly: Boolean;
procedure SetAllowAllOff(Value: Boolean);
procedure SetGroupIndex(Value: Integer);
procedure UpdateExclusive;
protected
procedure Click; override;
procedure Loaded; override;
procedure SetEnabled(Value: Boolean); override;
procedure CMButtonPressed(var Message: TLMessage); message CM_BUTTONPRESSED; // Called in UpdateExclusive procedure ...
function TransparentColorAtPos(Point: TPoint): boolean; virtual;
procedure LedStatusChanged; virtual;
procedure SetInternalLedValue(Value: Boolean);
function GetLedStatus: TLedStatus; virtual;
procedure SetLedvalue(Value: Boolean); virtual;
procedure SetReadOnly(AValue: Boolean); virtual;
property AllowAllOff: Boolean read FAllowAllOff write SetAllowAllOff default false;
property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
property LedValue: Boolean read FLedvalue write SetLedvalue;
property ReadOnly: Boolean read FReadOnly write SetReadOnly default false;
public
property Canvas;
constructor Create(AOwner: TComponent); override;
property LedStatus: TLedStatus read GetLedStatus;
procedure Switch;
published
end;
implementation
constructor TcyBaseLed.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAllowAllOff := false;
FGroupIndex := 0;
FLedvalue:= false;
FReadOnly := false;
end;
procedure TcyBaseLed.LedStatusChanged;
begin
Invalidate;
end;
procedure TcyBaseLed.Loaded;
begin
Inherited;
ControlStyle := ControlStyle - [csDoubleClicks];
end;
procedure TcyBaseLed.SetReadOnly(AValue: Boolean);
begin
if AValue <> FReadOnly
then FReadOnly := AValue;
end;
procedure TcyBaseLed.SetEnabled(Value: Boolean);
begin
Inherited;
LedStatusChanged;
end;
function TcyBaseLed.TransparentColorAtPos(Point: TPoint): boolean;
begin
RESULT := false;
end;
procedure TcyBaseLed.Click;
var aPt: TPoint;
begin
if not FReadOnly
then begin
GetCursorPos(aPt);
aPt := Self.ScreenToClient(aPt);
if Not TransparentColorAtPos(aPt)
then LedValue := not FLedValue;
end;
Inherited;
end;
function TcyBaseLed.GetLedStatus: TLedStatus;
begin
if not Enabled
then
RESULT := lsDisabled
else
if FLedValue
then RESULT := lsOn
else RESULT := lsOff;
end;
// Procedure to force changing value :
procedure TcyBaseLed.SetInternalLedValue(Value: Boolean);
begin
if FLedValue <> Value
then begin
FLedValue := Value;
LedStatusChanged;
end;
end;
procedure TcyBaseLed.Switch;
begin
LedValue := not FLedValue;
end;
procedure TcyBaseLed.SetLedvalue(Value: Boolean);
begin
if Value <> FLedvalue
then begin
if (not Value) and (not FAllowAllOff) and (FGroupIndex <> 0)
then Exit; // Can't turn off all leds of the same group ...
FLedvalue := Value;
LedStatusChanged;
if Value
then UpdateExclusive; // Send message to turn off the other one ...
end;
end;
procedure TcyBaseLed.SetAllowAllOff(Value: Boolean);
begin
if FAllowAllOff <> Value
then begin
FAllowAllOff := Value;
UpdateExclusive; // Inform FAllowAllOff value to the others from the same group
end;
end;
procedure TcyBaseLed.SetGroupIndex(Value: Integer);
begin
if FGroupIndex <> Value
then begin
FGroupIndex := Value;
UpdateExclusive;
end;
end;
procedure TcyBaseLed.UpdateExclusive;
var
Msg: TMessage;
begin
if (FGroupIndex <> 0) and (Parent <> nil)
then begin
Msg.Msg := CM_BUTTONPRESSED;
Msg.WParam := FGroupIndex;
Msg.LParam := PtrInt(Self);
Msg.Result := 0;
Parent.Broadcast(Msg);
end;
end;
procedure TcyBaseLed.CMButtonPressed(var Message: TLMessage);
var Sender: TcyBaseLed;
begin
if (csLoading in ComponentState) then exit;
if Message.WParam = FGroupIndex // Same group?
then begin
Sender := TcyBaseLed(Message.LParam);
if Sender <> Self
then begin
if Sender.LedValue and FLedValue // Only one can be turn on on group mode ...
then begin;
FLedValue := false;
LedStatusChanged;
end;
FAllowAllOff := Sender.AllowAllOff;
end;
end;
end;
end.

307
components/industrialstuff/source/indcyClasses.pas Normal file
View File

@@ -0,0 +1,307 @@
{ Unit indcyClasses from cyClasses
Description:
Unit with sub-properties for components.
* ***** 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 *****}
unit indcyClasses;
{$mode objfpc}{$H+}
// {$I cyCompilerDefines.inc}
interface
uses
LCLIntf, Classes, Graphics, Controls, SysUtils,
indcyTypes, indcyGraphics;
type
tcyBevel = class(TCollectionItem)
private
FHighlightColor: TColor;
FShadowColor: TColor;
FWidth: Word;
FStyle: TcyBevelCut;
FDrawRight: Boolean;
FDrawLeft: Boolean;
FDrawTop: Boolean;
FDrawBottom: Boolean;
FNeedOwnerRealign: Boolean;
procedure SetHighlightColor(const Value: TColor);
procedure SetShadowColor(const Value: TColor);
procedure SetWidth(const Value: Word);
procedure SetStyle(const Value: TcyBevelCut);
procedure SetDrawBottom(const Value: Boolean);
procedure SetDrawLeft(const Value: Boolean);
procedure SetDrawRight(const Value: Boolean);
procedure SetDrawTop(const Value: Boolean);
protected
function GetDisplayName: string; override;
public
constructor Create(ACollection: TCollection); override;
procedure Assign(Source: TPersistent); override;
published
property DrawLeft: Boolean read FDrawLeft write SetDrawLeft default True;
property DrawTop: Boolean read FDrawTop write SetDrawTop default True;
property DrawRight: Boolean read FDrawRight write SetDrawRight default True;
property DrawBottom: Boolean read FDrawBottom write SetDrawBottom default True;
property HighlightColor: TColor read FHighlightColor write SetHighlightColor default clBtnHighlight;
property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow;
property Style: TcyBevelCut read FStyle write SetStyle default bcRaised;
property Width: Word read FWidth write SetWidth default 1;
end;
TcyBevelClass = class of tcyBevel;
tcyBevels = Class(TCollection)
private
FControl: TControl;
FOnChange: TNotifyEvent;
FNeedOwnerRealign: Boolean;
function GetBevel(Index: Integer): TcyBevel;
protected
function GetOwner: TPersistent; Override;
procedure Update(Item: TCollectionItem); Override;
public
constructor Create(aControl: TControl; BevelClass: TcyBevelClass);
function Add: TcyBevel;
procedure Delete(Index: Integer);
procedure DrawBevels(aCanvas: TCanvas; var BoundsRect: TRect; RoundRect: Boolean);
function xBevelsWidth: Integer;
function BevelsWidth: Integer;
property Items[Index: Integer]: TcyBevel read GetBevel; default;
property NeedOwnerRealign: Boolean read FNeedOwnerRealign;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
implementation
{ tcyBevel }
procedure tcyBevel.Assign(Source: TPersistent);
begin
if Source is tcyBevel then
begin
FHighlightColor := tcyBevel(Source).FHighlightColor;
FShadowColor := tcyBevel(Source).FShadowColor;
FWidth := tcyBevel(Source).FWidth;
FStyle := tcyBevel(Source).FStyle;
FDrawRight := tcyBevel(Source).FDrawRight;
FDrawLeft := tcyBevel(Source).FDrawLeft;
FDrawTop := tcyBevel(Source).FDrawTop;
FDrawBottom := tcyBevel(Source).FDrawBottom;
end;
// inherited Assign(Source);
end;
constructor tcyBevel.Create(ACollection: TCollection);
begin
inherited Create(ACollection);
FHighlightColor := clBtnHighlight;
FShadowColor := clBtnShadow;
FWidth := 1;
FStyle := bcRaised;
FDrawLeft := true;
FDrawTop := true;
FDrawRight := true;
FDrawBottom := true;
FNeedOwnerRealign := true;
end;
function tcyBevel.GetDisplayName: string;
begin
case FStyle of
bcLowered: Result := 'Lowered';
bcRaised: Result := 'Raised';
bcNone: Result := 'None';
bcTransparent: Result := 'Transparent';
end;
Result := Result + ' Bevel';
Result := Result + ' Width = ' + intToStr(FWidth);
end;
procedure tcyBevel.SetDrawBottom(const Value: Boolean);
begin
FDrawBottom := Value;
Changed(false); // It will call TcyBevels.Update !
end;
procedure tcyBevel.SetDrawLeft(const Value: Boolean);
begin
FDrawLeft := Value;
Changed(false);
end;
procedure tcyBevel.SetDrawRight(const Value: Boolean);
begin
FDrawRight := Value;
Changed(false);
end;
procedure tcyBevel.SetDrawTop(const Value: Boolean);
begin
FDrawTop := Value;
Changed(false);
end;
procedure tcyBevel.SetHighlightColor(const Value: TColor);
begin
FHighlightColor := Value;
Changed(false);
end;
procedure tcyBevel.SetShadowColor(const Value: TColor);
begin
FShadowColor := Value;
Changed(false);
end;
procedure tcyBevel.SetStyle(const Value: TcyBevelCut);
begin
if FStyle = Value then EXIT;
if (FStyle = bcNone) or (Value = bcNone)
then FNeedOwnerRealign := true;
FStyle := Value;
Changed(false);
end;
procedure tcyBevel.SetWidth(const Value: Word);
begin
if FWidth = Value then EXIT;
FWidth := Value;
FNeedOwnerRealign := true;
Changed(false);
end;
{TcyBevels}
constructor TcyBevels.Create(aControl: TControl; BevelClass: TcyBevelClass);
begin
inherited Create(BevelClass);
FControl := aControl;
FNeedOwnerRealign := false;
end;
function TcyBevels.GetBevel(Index: Integer): TcyBevel;
begin
Result := TcyBevel(inherited Items[Index]);
end;
function TcyBevels.GetOwner: TPersistent;
begin
Result := FControl;
end;
// Event Called by setting properties/events of TcyBevel :
procedure TcyBevels.Update(Item: TCollectionItem);
begin
Inherited;
if Assigned(FOnChange)
then begin
if Item <> nil
then
if TcyBevel(Item).FNeedOwnerRealign
then begin
FNeedOwnerRealign := true;
TcyBevel(Item).FNeedOwnerRealign := false;
end;
FOnChange(Self);
FNeedOwnerRealign := false;
end
else
FControl.Invalidate;
end;
function TcyBevels.Add: TcyBevel;
begin
Result := TcyBevel(inherited Add);
Result.Changed(false); // It will call TcyBevels.Update only at run-time!
end;
procedure TcyBevels.Delete(Index: Integer);
begin
Inherited;
FNeedOwnerRealign := true;
Update(Nil);
end;
procedure TcyBevels.DrawBevels(aCanvas: TCanvas; var BoundsRect: TRect; RoundRect: Boolean);
var i: Integer;
begin
for i := 0 to Count-1 do
case Items[i].FStyle of
bcRaised:
begin
cyFrame3D(aCanvas, BoundsRect, Items[i].FHighlightColor, Items[i].FShadowColor, Items[i].FWidth,
Items[i].FDrawLeft, Items[i].FDrawTop, Items[i].FDrawRight, Items[i].FDrawBottom, RoundRect);
RoundRect := false;
end;
bcLowered:
begin
cyFrame3D(aCanvas, BoundsRect, Items[i].FShadowColor, Items[i].FHighlightColor, Items[i].FWidth,
Items[i].FDrawLeft, Items[i].FDrawTop, Items[i].FDrawRight, Items[i].FDrawBottom, RoundRect);
RoundRect := false;
end;
bcTransparent: // Just Inflate Rect
begin
InflateRect(BoundsRect, (-1) * Items[i].FWidth, (-1) * Items[i].FWidth);
RoundRect := false;
end;
bcNone: ;
end;
end;
function TcyBevels.xBevelsWidth: Integer;
begin
RESULT := 0;
end;
// 9999 for All other units like TcySimpleGauge
function TcyBevels.BevelsWidth: Integer;
var i: Integer;
begin
RESULT := 0;
for i := 0 to Count-1 do
if Items[i].FStyle <> bcNone
then Inc(RESULT, Items[i].FWidth);
end;
end.

198
components/industrialstuff/source/indcyGraphics.pas Normal file
View File

@@ -0,0 +1,198 @@
{ Unit indcyGraphics from cyGraphics
Description:
Unit with graphic functions
* ***** 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 *****}
unit indcyGraphics;
{$mode objfpc}{$H+}
// {$I cyCompilerDefines.inc}
interface
// We need to put jpeg to the uses for avoid run-time not handled jpeg image ...
uses
LCLIntf, LCLType, Types, Classes, Forms, Graphics, Math, Buttons, Controls,
ExtCtrls, SysUtils, indcyTypes;
// Objects painting functions :
procedure cyFrame3D(Canvas: TCanvas; var Rect: TRect; TopLeftColor, BottomRightColor: TColor; Width: Integer;
const DrawLeft: Boolean = true; const DrawTop: Boolean = true; const DrawRight: Boolean = true; const DrawBottom: Boolean = true;
const RoundRect: boolean = false);
// TPicture and TGraphic functions:
function PictureIsTransparentAtPos(aPicture: TPicture; aPoint: TPoint): boolean;
function IconIsTransparentAtPos(aIcon: TIcon; aPoint: TPoint): boolean;
function ValidGraphic(aGraphic: TGraphic): Boolean;
// Other functions:
function PointInEllipse(const aPt: TPoint; const aRect: TRect): boolean;
implementation
{ Procedures and functions}
procedure cyFrame3D(Canvas: TCanvas; var Rect: TRect; TopLeftColor, BottomRightColor: TColor; Width: Integer;
const DrawLeft: Boolean = true; const DrawTop: Boolean = true; const DrawRight: Boolean = true; const DrawBottom: Boolean = true;
const RoundRect: boolean = false);
var incValue: Integer;
procedure DrawLines;
begin
with Canvas, Rect do
begin
// Draw Left and Top line :
Pen.Color := TopLeftColor;
if DrawLeft
then begin
MoveTo(Left, Top + incValue);
LineTo(Left, Bottom);
end;
if DrawTop
then begin
MoveTo(Left + incValue, Top);
LineTo(Right, Top);
end;
// Draw right and bottom line :
Pen.Color := BottomRightColor;
if DrawRight
then begin
MoveTo(Right, Top + incValue);
LineTo(Right, Bottom);
end;
if DrawBottom
then begin
MoveTo(Right - incValue, Bottom);
LineTo(Left-1 + incValue, Bottom);
end;
end;
end;
begin
if RoundRect
then incValue := 1
else incValue := 0;
Canvas.Pen.Width := 1;
Dec(Rect.Bottom);
Dec(Rect.Right);
while Width > 0 do
begin
Dec(Width);
DrawLines;
incValue := 0;
InflateRect(Rect, -1, -1);
end;
Inc(Rect.Bottom);
Inc(Rect.Right);
end;
function PointInEllipse(const aPt: TPoint; const aRect: TRect): boolean;
var
CenterEllipseCoord: TPoint;
EllipseWidth, EllipseHeight: Integer;
begin
CenterEllipseCoord := Point((aRect.Right + aRect.Left) div 2, (aRect.Bottom + aRect.Top) div 2);
EllipseWidth := (aRect.Right - aRect.Left) div 2;
EllipseHeight := (aRect.Bottom - aRect.Top) div 2;
RESULT := Sqr((aPt.x - CenterEllipseCoord.x)/EllipseWidth) + Sqr((aPt.y - CenterEllipseCoord.y)/EllipseHeight)
<= 1;
// = 0 On the center of ellipse
// < 1 Inside the ellipse
// = on the border of ellipse
// > 1 Outside the ellipse
end;
function PictureIsTransparentAtPos(aPicture: TPicture; aPoint: TPoint): boolean;
begin
RESULT := false; // TJPEGImage and others formats not handled ...
if aPicture.Graphic = nil then Exit;
if aPicture.Graphic.Empty then Exit;
if aPicture.Graphic is TBitmap
then begin
RESULT := aPicture.Bitmap.Canvas.Pixels[aPoint.X, aPoint.Y]
= aPicture.Bitmap.Canvas.Pixels[0, aPicture.Bitmap.Height-1];
end
else
if aPicture.Graphic is TIcon
then
RESULT := IconIsTransparentAtPos(aPicture.Icon, aPoint)
end;
// 9999 New function for CodeTyphon
function IconIsTransparentAtPos(aIcon: TIcon; aPoint: TPoint): boolean;
var aPic: TPicture;
begin
RESULT := false;
aPic := TPicture.Create;
try
aPic.Bitmap.Width := aIcon.Width;
aPic.Bitmap.Height := aIcon.Height;
aPic.Bitmap.PixelFormat := pf1bit; // Black = not transparent
aPic.Bitmap.Canvas.Brush.Color := clWhite;
aPic.Bitmap.Canvas.FillRect(Rect(0, 0, aIcon.Width, aIcon.Height));
aPic.Assign(aIcon);
aPic.Bitmap.PixelFormat := pf1bit; // Black = not transparent
RESULT := aPic.Bitmap.Canvas.Pixels[aPoint.X, aPoint.Y] <> clBlack;
finally
aPic.Free;
end;
end;
function ValidGraphic(aGraphic: TGraphic): Boolean;
begin
RESULT := false;
if aGraphic <> Nil
then
if not aGraphic.Empty
then RESULT := true;
end;
end.

86
components/industrialstuff/source/indcyTypes.pas Normal file
View File

@@ -0,0 +1,86 @@
{ Unit indcyTypes from cyTypes
Description:
Unit with Types declarations.
* ***** 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 *****}
unit indcyTypes;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, Graphics, Classes, types;
type
// Graphic:
TCaptionRender = (crNormal, crPathEllipsis, crEndEllipsis, crWordEllipsis);
TCaptionOrientation = (coHorizontal, coHorizontalReversed, coVertical, coVerticalReversed);
TBgPosition = (bgCentered, bgTopLeft, bgTopCenter, bgTopRight, bgCenterRight, bgBottomRight, bgBottomCenter, bgBottomLeft, bgCenterLeft);
TBgStyle = (bgNone, bgNormal, bgMosaic, bgStretch, bgStretchProportional);
TcyBevelCut = (bcLowered, bcRaised, bcNone, bcTransparent);
TDgradOrientation = (dgdVertical, dgdHorizontal, dgdAngle, dgdRadial, dgdRectangle);
TDgradOrientationShape = (osRadial, osRectangle);
TDgradBalanceMode = (bmNormal, bmMirror, bmReverse, bmReverseFromColor, bmInvertReverse, bmInvertReverseFromColor);
// Cindy components:
TRunTimeDesignJob = (rjNothing, rjMove, rjResizeTop, rjResizeBottom, rjResizeLeft, rjResizeTopLeft,
rjResizeBottomLeft, rjResizeRight, rjResizeTopRight, rjResizeBottomRight);
TLineCoord = record
BottomCoord, TopCoord: TPoint;
end;
//var
// CaptionOrientationWarning: Boolean = true;
const
DT_PATH_ELLIPSIS = $8000;
DT_WORD_ELLIPSIS = $8000;
cCaptionOrientationWarning = 'Note that text orientation doesn''t work with all fonts!';
Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
WordWraps: array[Boolean] of Word = (DT_SINGLELINE, DT_WORDBREAK);
TextLayouts: array[TTextLayout] of Longint = (DT_TOP, DT_VCENTER, DT_BOTTOM);
CaptionOrientations: array[TCaptionOrientation] of word = (0, 1800, 900, 2700);
CaptionRenders: array[TCaptionRender] of Integer = (0, DT_PATH_ELLIPSIS, DT_END_ELLIPSIS, DT_WORD_ELLIPSIS);
implementation
end.

457
components/industrialstuff/source/indgnoumeter.pas Normal file
View File

@@ -0,0 +1,457 @@
{**********************************************************************
GnouMeter is a meter which can display an integer or a float value (Single).
Just like a progress bar or a gauge, all you have do do is to define
the Minimum and maximum values as well as the actual value.
Above the meter, one can display the name of the data being measured (optional)
and its actual value with its corresponding unit.
The minimum and maximum values are respectively shown at the bottom and the
top of the meter with their corresponding units.
The meter is filled with the color ColorFore and its background color
is defined by the ColorBack Property.
THIS COMPONENT IS ENTIRELY FREEWARE
Author: Jérôme Hersant
jhersant@post4.tele.dk
***********************************************************************}
unit indGnouMeter;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls, Graphics, SysUtils, Messages, LMessages, Types, LCLType, LCLIntf;
type
TindGnouMeter = class(TGraphicControl)
private
fValue: Double;
fColorFore: TColor;
fColorBack: TColor;
fSignalUnit: ShortString;
fValueMax: Double;
fValueMin: Double;
fDigits: Byte;
fIncrement: Double;
fShowIncrements: Boolean;
fGapTop: Word;
fGapBottom: Word;
fBarThickness: Word;
fMarkerColor: TColor;
fShowMarker: Boolean;
//Variables used internally
TopTextHeight: Word;
LeftMeter: Word;
DisplayValue: String;
DrawStyle: integer;
TheRect: TRect;
//End of variables used internally
procedure SetValue(val: Double);
procedure SetColorBack(val: TColor);
procedure SetColorFore(val: TColor);
procedure SetSignalUnit(val: ShortString);
procedure SetValueMin(val: Double);
procedure SetValueMax(val: Double);
procedure SetDigits(val: Byte);
procedure SetTransparent(val: Boolean);
function GetTransparent: Boolean;
procedure SetIncrement(val: Double);
procedure SetShowIncrements(val: Boolean);
procedure SetGapTop(val: Word);
procedure SetGapBottom(val: Word);
procedure SetBarThickness(val: Word);
procedure SetMarkerColor(val: TColor);
procedure SetShowMarker(val: Boolean);
procedure DrawTopText;
procedure DrawMeterBar;
procedure DrawIncrements;
function ValueToPixels(val: Double): integer;
procedure DrawValueMax;
procedure DrawValueMin;
procedure DrawMarker;
protected
procedure Paint; override;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Align;
property Caption;
property Visible;
property ShowHint;
property Value: Double read fValue write SetValue;
property Color;
property Font;
property ParentColor;
property ColorFore: Tcolor read fColorFore write SetColorFore;
property ColorBack: Tcolor read fColorBack write SetColorBack;
property SignalUnit: ShortString read fSignalUnit write SetSignalUnit;
property ValueMin: Double read fValueMin write SetValueMin;
property ValueMax: Double read fValueMax write SetValueMax;
property Digits: Byte read fDigits write SetDigits;
property Increment: Double read fIncrement write SetIncrement;
property ShowIncrements: Boolean read fShowIncrements write SetShowIncrements;
property Transparent: Boolean read GetTransparent write SetTransparent;
property GapTop: Word read fGapTop write SetGapTop;
property GapBottom: Word read fGapBottom write SetGapBottom;
property BarThickness: Word read fBarThickness write SetBarThickness;
property MarkerColor: TColor read fMarkerColor write SetMarkerColor;
property ShowMarker: Boolean read fShowMarker write SetShowMarker;
end;
implementation
constructor TindGnouMeter.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable, csSetCaption];
Width := 100;
Height := 200;
fColorFore := clRed;
fColorBack := clBtnFace;
fMarkerColor := clBlue;
fValueMin := 0;
fValueMax := 100;
fIncrement := 10;
fShowIncrements := True;
fShowMarker := True;
fValue := 0;
fGapTop := 20;
fGapBottom := 10;
fBarThickness := 5;
fSignalUnit := 'Units';
end;
destructor TindGnouMeter.Destroy;
begin
inherited Destroy;
end;
procedure TindGnouMeter.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TindGnouMeter.SetValue(val: Double);
begin
if (val <> fValue) and (val >= fValueMin) and (val <= fValueMax) then
begin
fValue := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetColorFore(val: TColor);
begin
if val <> fColorFore then
begin
fColorFore := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetColorBack(val: TColor);
begin
if val <> fColorBack then
begin
fColorBack := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetSignalUnit(val: ShortString);
begin
if val <> fSignalUnit then
begin
fSignalUnit := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetValueMin(val: Double);
begin
if (val <> fValueMin) and (val <= fValue) then
begin
fValueMin := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetValueMax(val: Double);
begin
if (val <> fValueMax) and (val >= fValue) then
begin
fValueMax := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetDigits(val: Byte);
begin
if (val <> fDigits) then
begin
fDigits := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetIncrement(val: Double);
begin
if (val <> fIncrement) and (val > 0) then
begin
fIncrement := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetShowIncrements(val: Boolean);
begin
if (val <> fShowIncrements) then
begin
fShowIncrements := val;
Invalidate;
end;
end;
function TindGnouMeter.GetTransparent: Boolean;
begin
Result := not (csOpaque in ControlStyle);
end;
procedure TindGnouMeter.SetTransparent(Val: Boolean);
begin
if Val <> Transparent then
begin
if Val then
ControlStyle := ControlStyle - [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque];
Invalidate;
end;
end;
procedure TindGnouMeter.SetGapTop(val: Word);
begin
if (val <> fGapTop) then
begin
fGapTop := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetGapBottom(val: Word);
begin
if (val <> fGapBottom) then
begin
fGapBottom := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetBarThickness(val: Word);
begin
if (val <> fBarThickness) and (val > 0) then
begin
fBarThickness := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetMarkerColor(val: TColor);
begin
if (val <> fMarkerColor) then
begin
fMarkerColor := val;
Invalidate;
end;
end;
procedure TindGnouMeter.SetShowMarker(val: Boolean);
begin
if (val <> fShowMarker) then
begin
fShowMarker := val;
Invalidate;
end;
end;
procedure TindGnouMeter.DrawIncrements;
var
i: Double;
PosPixels: Word;
begin
if fShowIncrements then
begin
with Canvas do
begin
i := fValueMin;
while i <= fValueMax do
begin
PosPixels := ValueToPixels(i);
pen.color := clGray;
MoveTo(LeftMeter + BarThickness + 3, PosPixels - 1);
LineTo(LeftMeter + BarThickness + 7, PosPixels - 1);
pen.color := clWhite;
MoveTo(LeftMeter + BarThickness + 3, PosPixels);
LineTo(LeftMeter + BarThickness + 7, PosPixels);
i := i + fIncrement;
end;
end;
end;
end;
procedure TindGnouMeter.DrawMarker;
begin
if fShowMarker then
begin
with Canvas do
begin
pen.color := clWhite;
Brush.Style := bsClear;
MoveTo(LeftMeter - 2, ValueToPixels(fValue));
LineTo(LeftMeter - 6, ValueToPixels(fValue) - 4);
LineTo(LeftMeter - 6, ValueToPixels(fValue) + 4);
pen.color := clGray;
LineTo(LeftMeter - 2, ValueToPixels(fValue));
pen.color := fMarkerColor;
Brush.color := fMarkerColor;
Brush.Style := bsSolid;
Polygon([Point(LeftMeter - 3, ValueToPixels(fValue)),
Point(LeftMeter - 5, ValueToPixels(fValue) - 2),
Point(LeftMeter - 5, ValueToPixels(fValue) + 2),
Point(LeftMeter - 3, ValueToPixels(fValue))]);
end;
end;
end;
procedure TindGnouMeter.DrawTopText;
begin
with Canvas do
begin
DisplayValue := Caption;
Brush.Style := bsClear;
TheRect := ClientRect;
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_CENTER + DT_TOP;
Font.Style := [fsBold];
TopTextHeight := DrawText(Handle, PChar(DisplayValue),
Length(DisplayValue), TheRect, DrawStyle);
Font.Style := [];
TheRect.Top := TopTextHeight;
DisplayValue := FloatToStrF(Value, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
TopTextHeight := TopTextHeight + DrawText(Handle, PChar(DisplayValue),
Length(DisplayValue), TheRect, DrawStyle);
TopTextHeight := TopTextHeight + fGapTop;
end;
end;
procedure TindGnouMeter.DrawValueMin;
begin
with Canvas do
begin
TheRect := ClientRect;
TheRect.Left := LeftMeter + BarThickness + 10;
TheRect.Top := TopTextHeight;
TheRect.Bottom := Height - fGapBottom + 6;
Brush.Style := bsClear;
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_BOTTOM;
DisplayValue := FloatToStrF(ValueMin, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
DrawText(Handle, PChar(DisplayValue), Length(DisplayValue),
TheRect, DrawStyle);
end;
end;
procedure TindGnouMeter.DrawValueMax;
begin
with Canvas do
begin
TheRect := ClientRect;
TheRect.Left := LeftMeter + BarThickness + 10;
TheRect.Top := TopTextHeight - 6;
Brush.Style := bsClear;
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_TOP;
DisplayValue := FloatToStrF(ValueMax, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
DrawText(Handle, PChar(DisplayValue), Length(DisplayValue),
TheRect, DrawStyle);
end;
end;
procedure TindGnouMeter.DrawMeterBar;
begin
with Canvas do
begin
pen.Color := fColorBack;
Brush.Color := fColorBack;
Brush.Style := bsSolid;
Rectangle(LeftMeter, ValueToPixels(fValueMax), LeftMeter +
fBarThickness, ValueToPixels(fValueMin));
pen.Color := fColorFore;
Brush.Color := fColorFore;
Brush.Style := bsSolid;
Rectangle(LeftMeter + 1, ValueToPixels(fValue), LeftMeter +
fBarThickness, ValueToPixels(fValueMin));
pen.color := clWhite;
Brush.Style := bsClear;
MoveTo(LeftMeter + fBarThickness - 1, ValueToPixels(fValueMax));
LineTo(LeftMeter, ValueToPixels(fValueMax));
LineTo(LeftMeter, ValueToPixels(fValueMin) - 1);
pen.color := clGray;
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValueMin) - 1);
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValueMax));
if (fValue > fValueMin) and (fValue < fValueMax) then
begin
pen.color := clWhite;
MoveTo(LeftMeter + 1, ValueToPixels(fValue));
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValue));
pen.color := clGray;
MoveTo(LeftMeter + 1, ValueToPixels(fValue) - 1);
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValue) - 1);
end;
end;
end;
function TindGnouMeter.ValueToPixels(val: Double): integer;
var
factor: Double;
begin
Result := 0;
if fValueMax > fValueMin then
begin
Factor := (Height - fGapBottom - TopTextHeight) / (fValueMin - fValueMax);
Result := Round(Factor * val - Factor * fValueMax + TopTextHeight);
end;
end;
procedure TindGnouMeter.Paint;
begin
LeftMeter := (Width div 2) - 10 - fBarThickness;
with Canvas do
begin
if not Transparent then
begin
Brush.Color := Self.Color;
Brush.Style := bsSolid;
FillRect(ClientRect);
end;
Brush.Style := bsClear;
DrawTopText;
DrawValueMin;
DrawValueMax;
DrawMeterBar;
DrawMarker;
DrawIncrements;
end;
end;
end.

371
components/industrialstuff/source/indled.pas Normal file
View 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.

BIN
components/industrialstuff/source/industrial_icons.res Normal file
View File

Binary file not shown.

BIN
components/industrialstuff/source/ledbuttons.res Normal file
View File

Binary file not shown.

585
components/industrialstuff/source/lednumber.pas Normal file
View File

@@ -0,0 +1,585 @@
{*********************************************************}
{* VPLEDLABEL.PAS 1.03 -> LEDNumber.PAS *}
{*********************************************************}
{* ***** 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 Original Code is TurboPower Visual PlanIt *}
{* *}
{* The Initial Developer of the Original Code is TurboPower Software *}
{* *}
{* Portions created by TurboPower Software Inc. are Copyright (C) 2002 *}
{* TurboPower Software Inc. All Rights Reserved. *}
{* *}
{* Contributor(s): *}
{* Modified by Jurassic Pork for include in industrial Stuff Lazarus package *}
{* 05/2013 *}
{* ***** END LICENSE BLOCK ***** *}
unit LedNumber;
{$mode objfpc}{$H+}
interface
uses
LMessages, Classes, Controls, Graphics;
type
TSegmentSize = 2..10;
TLedNumberBorderStyle = (lnbNone, lnbSingle, lnbSunken, lnbRaised);
{ TCustomLEDNumber }
TCustomLEDNumber = class(TGraphicControl)
private
FBorderStyle: TLedNumberBorderStyle;
FTransparent: boolean;
procedure SetBorderStyle(AValue: TLedNumberBorderStyle);
procedure SetTransparent(AValue: boolean);
protected{private}
FBgColor : TColor;
FOffColor : TColor;
FOnColor : TColor;
FColumns : Integer;
FRows : Integer;
FSize : TSegmentSize;
lbDrawBmp : TBitmap;
procedure CMTextChanged(var Message: TLMessage); message CM_TEXTCHANGED;
procedure Initialize(var Points: array of TPoint);
function NewOffset(xOry: char; OldOffset: Integer): Integer;
procedure ProcessCaption(Points: array of TPoint);
procedure PaintSegment(Segment: Integer; TheColor: TColor;
Points: array of TPoint; OffsetX, OffsetY: Integer);
procedure ResizeControl(Row, Col, Size: Integer);
function GetAbout: string;
procedure SetAbout(const Value: string);
procedure SetSize(Value: TSegmentSize);
procedure SetOnColor(Value: TColor);
procedure SetOffColor(Value: TColor);
procedure SetRows(Value: Integer);
procedure SetColumns(Value: Integer);
procedure SetbgColor(Value: TColor);
procedure SelectSegments(Segment: Word; Points: array of TPoint;
OffsetX, OffsetY: Integer);
protected
procedure Paint; override;
public
constructor Create(AOwner:TComponent);override;
destructor Destroy; override;
{properties}
property Version: string read GetAbout write SetAbout stored False;
property BorderStyle: TLedNumberBorderStyle read FBorderStyle write SetBorderStyle default lnbNone; {Draws border around segments.}
property Columns: Integer read FColumns write SetColumns default 10;
property Rows: Integer read FRows write SetRows default 1;
property BgColor: TColor read FbgColor write SetbgColor default clBlack;
property OffColor: TColor read FOffColor write SetOffColor default $000E3432;
property OnColor: TColor read FOnColor write SetOnColor default clLime;
property Size: TSegmentSize read FSize write SetSize default 2;
property Transparent: boolean read FTransparent write SetTransparent default false; {Draws segments with transparent background.BgColor is used as mask color.}
{Inherited properties}
property Caption;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
end;
TLEDNumber = class(TCustomLEDNumber)
published
property Version;
property BorderStyle;
property Caption;
property Columns;
property Rows;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property BgColor;
property OffColor;
property OnColor;
property ParentShowHint;
property PopupMenu;
property Size;
property ShowHint;
property Transparent;
property Visible;
end;
implementation
// uses
// VpConst;
{ LED Segment Map }
{ }
{ ------------------------ }
{ | 1 | }
{ ------------------------ }
{ | | \ | | / | | }
{ | | \ | | / | | }
{ | | \ | | / | | }
{ |2 |\3 \ |4 | /5 /|6 | }
{ | | \ \| |/ / | | }
{ | | \ | | / | | }
{ ----------- ----------- }
{ | 7 \/ 8 | }
{ -----------/\----------- }
{ | | / | | \ | | }
{ | | / /| |\ \ | | }
{ |9 |/10 / |11| \12 \|13| }
{ | | / | | \ | | }
{ | | / | | \ | | }
{ | | / | | \ | | }
{ ------------------------ |-----| }
{ | 14 | | * | }
{ ------------------------ |-----| }
{ }
{ * Period and comma are drawn here }
{ Colon is drawn in the center of }
{ segments 4 and 11 }
{ Each segment is made up of 6 points. The segments that don't need 6 points, }
{ such as the period and colon dots, return to the coordinates of the initial }
{ point for the remaining unused points. }
const
{LED SEGMENT ARRAYS}
MAX_POINTS = 107;
DigitPoints: array[0..MAX_POINTS] of TPoint =
{Segment 1}
((X:2;Y:2),(X:3;Y:1),(X:11;Y:1),(X:12;Y:2),(X:11;Y:3),(X:3;Y:3),
{Segment 2}
(X:2;Y:3),(X:3;Y:4),(X:3;Y:12),(X:2;Y:13),(X:1;Y:12),(X:1;Y:4),
{Segment 3}
(X:3;Y:3),(X:6;Y:9),(X:6;Y:13),(X:3;Y:7),(X:3;Y:3),(X:3;Y:3),
{Segment 4}
(X:7;Y:3),(X:8;Y:4),(X:8;Y:12),(X:7;Y:13),(X:6;Y:12),(X:6;Y:4),
{Segment 5}
(X:11;Y:3),(X:11;Y:7),(X:8;Y:13),(X:8;Y:9),(X:11;Y:3),(X:11;Y:3),
{Segment 6}
(X:12;Y:3),(X:13;Y:4),(X:13;Y:12),(X:12;Y:13),(X:11;Y:12),(X:11;Y:4),
{Segment 7}
(X:2;Y:14),(X:3;Y:13),(X:6;Y:13),(X:7;Y:14),(X:6;Y:15),(X:3;Y:15),
{Segment 8}
(X:7;Y:14),(X:8;Y:13),(X:11;Y:13),(X:12;Y:14),(X:11;Y:15),(X:8;Y:15),
{Segment 9}
(X:2;Y:15),(X:3;Y:16),(X:3;Y:24),(X:2;Y:25),(X:1;Y:24),(X:1;Y:16),
{Segment 10}
(X:6;Y:15),(X:6;Y:19),(X:3;Y:25),(X:3;Y:21),(X:6;Y:15),(X:6;Y:15),
{Segment 11}
(X:7;Y:15),(X:8;Y:16),(X:8;Y:24),(X:7;Y:25),(X:6;Y:24),(X:6;Y:16),
{Segment 12}
(X:8;Y:15),(X:11;Y:21),(X:11;Y:25),(X:8;Y:19),(X:8;Y:15),(X:8;Y:15),
{Segment 13}
(X:12;Y:15),(X:13;Y:16),(X:13;Y:24),(X:12;Y:25),(X:11;Y:24),(X:11;Y:16),
{Segment 14}
(X:2;Y:26),(X:3;Y:25),(X:11;Y:25),(X:12;Y:26),(X:11;Y:27),(X:3;Y:27),
{Period }
(X:14;Y:25),(X:16;Y:25),(X:16;Y:27),(X:14;Y:27),(X:14;Y:25),(X:14;Y:25),
{Comma }
(X:14;Y:25),(X:16;Y:25),(X:16;Y:27),(X:13;Y:30),(X:14;Y:27),(X:14;Y:25),
{Colon Top }
(X:5;Y:7),(X:9;Y:7),(X:9;Y:10),(X:5;Y:10),(X:5;Y:7),(X:5;Y:7),
{Colon Btm }
(X:5;Y:20),(X:9;Y:20),(X:9;Y:23),(X:5;Y:23),(X:5;Y:20),(X:5;Y:20));
Characters: Array[0..72] of Word =
($0000,$3B70,$1320,$0001,$0300,$0002,$0840,$CCCC,$1020,$8784,
{ ' ' * + , - . / 0 1 2 }
$870C,$4708,$C30C,$C38C,$8408,$C78C,$C70C,$0810,$2040,$C788,
{ 3 4 5 6 7 8 9 < > A }
$952C,$C084,$942C,$C384,$C380,$C18C,$4788,$9024,$048C,$4A90,
{ B C D E F G H I J K }
$4084,$6C88,$6498,$C48C,$C780,$C49E,$C790,$C214,$9020,$448C,
{ L M N O P Q R S T U }
$48C0,$44D8,$2850,$2820,$8844,$2010,$C788,$952C,$C084,$942C,
{ V W X Y Z / a b c d }
$C384,$C380,$C18C,$4788,$9024,$048C,$4A90,$4084,$6C88,$6498,
{ e f g h i j k l m n }
$C48C,$C780,$C49E,$C790,$C214,$9020,$448C,$48C0,$44D8,$2850,
{ o p q r s t u v w x }
$2820,$8844,$FFFF);
{ y z : }
CharacterNDX: Array[1..122] of integer =
(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
10, 11, 12, 13, 14, 15, 16, 72, 0, 17, 0, 18, 0, 0, 19, 20, 21, 22, 23, 24,
25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43,
44, 0, 45, 0, 0, 0, 0, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44);
{===== TCustomLEDNumber ============================================}
constructor TCustomLEDNumber.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FTransparent := False;
FBorderStyle := lnbNone;
ControlStyle := [csCaptureMouse,
csOpaque,
csSetCaption,
csClickEvents,
csDoubleClicks];
Width := 170;
Height := 30;
FOnColor := clLime;
FOffColor := $000E3432;
FBgColor := clBlack;
FSize := 2;
FRows := 1;
FColumns := 10;
Caption := 'LED-LABEL';
lbDrawBmp := TBitmap.Create;
end;
{=====}
destructor TCustomLEDNumber.Destroy;
begin
lbDrawBmp.Free;
lbDrawBmp := nil;
inherited Destroy;
end;
{=====}
function TCustomLEDNumber.GetAbout : string;
begin
Result := ''; //VpVersionStr;
end;
{=====}
procedure TCustomLEDNumber.SetAbout(const Value : string);
begin
{Leave empty}
end;
{=====}
procedure TCustomLEDNumber.SetTransparent(AValue: boolean);
begin
if FTransparent=AValue then Exit;
FTransparent:=AValue;
lbDrawBmp.Transparent := FTransparent;
lbDrawBmp.TransparentColor := FBgColor;
Invalidate;
end;
procedure TCustomLEDNumber.SetBorderStyle(AValue: TLedNumberBorderStyle);
begin
if FBorderStyle=AValue then Exit;
FBorderStyle:=AValue;
Invalidate;
end;
procedure TCustomLEDNumber.CMTextChanged(var Message: TLMessage);
begin
inherited;
Invalidate;
end;
{=====}
procedure TCustomLEDNumber.Initialize(var Points: array of TPoint);
var
I : Integer;
begin
for I := 0 to MAX_POINTS do begin
Points[i].X := DigitPoints[i].X * (FSize - 1);
Points[i].Y := DigitPoints[i].Y * (FSize - 1);
end;
end;
{=====}
function TCustomLEDNumber.NewOffset(xOry: char; OldOffset: Integer): Integer;
begin
if (xOry = 'x')then
newOffset := oldOffset + 17 * (FSize - 1)
else
newOffset := oldOffset + 30 * (FSize -1)
end;
{=====}
procedure TCustomLEDNumber.Paint;
var
Points: array[0..MAX_POINTS] of TPoint;
ARect: TRect;
begin
lbDrawBMP.Width := Width;
lbDrawBMP.Height := Height;
Initialize(Points);
lbDrawBMP.Canvas.Brush.Color := FBgColor;
lbDrawBMP.Canvas.FillRect(ClientRect);
ProcessCaption(Points);
Canvas.CopyMode := cmSrcCopy;
if BorderStyle <> lnbNone then
begin
ARect := ClientRect;
case BorderStyle of
lnbSingle:
begin
Canvas.Pen.Color := cl3DDkShadow;
Canvas.Frame(ARect);
end;
lnbSunken: Canvas.Frame3D(ARect, cl3DDkShadow, clBtnHiLight, 1);
lnbRaised: Canvas.Frame3D(ARect, clBtnHiLight, cl3DDkShadow, 1);
end;
inc(ARect.Left, 1);
inc(ARect.Top, 1);
inc(ARect.Right, 1);
inc(ARect.Bottom, 1);
Canvas.StretchDraw(ARect, lbDrawBMP);
end else
Canvas.Draw(0, 0, lbDrawBMP);
end;
{=====}
procedure TCustomLEDNumber.PaintSegment(Segment: Integer; TheColor: TColor;
Points: array of TPoint; OffsetX, OffsetY: Integer);
var
I: Integer;
DrawPts: array[0..5] of TPoint;
begin
Dec(Segment);
lbDrawBMP.Canvas.Pen.Style := psClear;
lbDrawBMP.Canvas.Brush.Color := TheColor;
for i := 0 to 5 do begin
DrawPts[i].X := offsetX + Points[Segment * 6 + i].X;
DrawPts[i].Y := offsetY + Points[Segment * 6 + i].Y;
end;
lbDrawBMP.Canvas.Polygon(DrawPts);
end;
{=====}
procedure TCustomLEDNumber.SelectSegments(Segment: Word;
Points: array of TPoint; OffsetX, OffsetY: Integer);
var
I : integer;
Bit : word;
MyColor : TColor;
Skip : Boolean;
begin
if (Segment and $FFFF) = $FFFF then begin
MyColor := FOnColor;
PaintSegment(17, MyColor, Points, OffsetX, OffsetY);
PaintSegment(18, MyColor, Points, OffsetX, OffsetY);
end
else begin
Bit := $8000;
for I := 1 to 16 do begin
Skip := False;
if (Segment and Bit) = Bit then
MyColor := FOnColor
else begin
if (i = 15) or (i = 16) then
Skip := True;
MyColor := FOffColor;
end;
if (not Skip) and (MyColor <> FBgColor) then
PaintSegment(I, MyColor, Points, OffsetX, OffsetY);
Bit := Bit div 2;
end;
end;
end;
{=====}
procedure TCustomLEDNumber.ProcessCaption(Points: array of TPoint);
var
Next : Char;
Last : Char;
I, X : Integer;
Row, ColsPerRow: Integer;
Tmp : Integer;
OffsetX : Integer;
OffsetY : Integer;
DisplayStr : string;
begin
Last := #0;
OffsetX := FSize;
OffsetY := 0;
DisplayStr := Caption;
if Length(DisplayStr) > 0 then
if (DisplayStr[1] = ',') or (DisplayStr[1] = '.') then
DisplayStr := ' ' + DisplayStr;
Row := 1;
ColsPerRow := 0;
for I := 1 to Length(Caption) do begin
Next := Caption[I];
case Ord(Next) of
42..58,60,62,65..90,92,97..122: begin
if ColsPerRow = FColumns then begin
Row := Row + 1;
if Row > FRows then
exit;
offsetY := newOffset('y',offsetY);
offsetX := FSize;
ColsPerRow := 0
end;
if (Next = '.') or (Next = ',') then
if (Last = '.') or (Last = ',') then begin
SelectSegments(Characters[CharacterNDX[Ord(Next)]], Points,
OffsetX, OffsetY);
OffsetX := NewOffset('x', OffsetX);
end
else begin
OffsetX := OffsetX - (17 * (FSize - 1));
Tmp := (Characters[CharacterNDX[Ord(Next)]]
or Characters[CharacterNDX[Ord(Last)]]);
SelectSegments(Tmp, Points, OffsetX, OffsetY);
OffsetX := NewOffset('x', OffsetX);
end
else begin
SelectSegments(Characters[CharacterNDX[Ord(Next)]], Points, OffsetX,
OffsetY);
offsetX := NewOffset('x', OffsetX);
ColsPerRow := ColsPerRow + 1;
end;
end;
10: begin {eat linefeed}
end;
13: begin
if ColsPerRow < FColumns then
for x := 1 to (FColumns - ColsPerRow) do begin
SelectSegments(Characters[CharacterNDX[1]], Points, OffsetX, OffsetY);
OffsetX := NewOffset('x', OffsetX);
end;
Row := Row + 1;
if Row > FRows then
exit;
OffsetY := NewOffset('y', OffsetY);
OffsetX := FSize;
ColsPerRow := 0;
end;
else begin
if ColsPerRow = FColumns then begin
Row := Row + 1;
if Row > FRows then
Exit;
OffsetY := NewOffset('y', OffsetY);
OffsetX := FSize;
ColsPerRow := 0;
end;
SelectSegments(Characters[CharacterNDX[1]], Points, OffsetX, OffsetY);
OffsetX := newOffset('x', OffsetX);
ColsPerRow := ColsPerRow + 1;
end;
end;
Last := Next;
end;
for x := 1 to (FColumns - ColsPerRow) do begin
SelectSegments(Characters[CharacterNDX[1]], Points, OffsetX, OffsetY);
OffsetX := NewOffset('x', OffsetX);
end;
if (FColumns * FRows) > Length(caption) then begin
for X := Row + 1 to FRows do begin
OffsetX := FSize;
OffsetY := NewOffset('y', OffsetY);
for I := 1 to FColumns do begin
SelectSegments(Characters[CharacterNDX[1]], Points, OffsetX, OffsetY);
OffsetX := NewOffset('x', OffsetX);
end;
end;
end;
end;
{=====}
procedure TCustomLEDNumber.ResizeControl(Row, Col, Size: Integer);
begin
FRows := Row;
FColumns := Col;
FSize := Size;
SetBounds(Left, Top, FColumns * 17 * (FSize - 1), FRows * 30 * (FSize - 1));
Invalidate;
end;
{=====}
procedure TCustomLEDNumber.SetbgColor(Value: TColor);
begin
if FBgColor <> Value then begin
FBgColor := Value;
Invalidate;
end;
end;
{=====}
procedure TCustomLEDNumber.SetOnColor(Value:TColor);
begin
if FOnColor <> Value then begin
FOnColor := Value;
Invalidate;
end;
end;
{=====}
procedure TCustomLEDNumber.SetOffColor(Value:TColor);
begin
if FOffColor <> Value then begin
FOffColor := Value;
Invalidate;
end;
end;
{=====}
procedure TCustomLEDNumber.SetRows(Value : Integer);
begin
if FRows <> Value then begin
if Value < 1 then
Value := 1;
ResizeControl(Value, FColumns, FSize);
end;
end;
{=====}
procedure TCustomLEDNumber.SetColumns(Value : Integer);
begin
if FColumns <> Value then begin
if Value < 1 then
Value := 1;
ResizeControl(FRows, Value, FSize);
end;
end;
{=====}
procedure TCustomLEDNumber.SetSize(Value : TSegmentSize);
begin
if FSize <> Value then begin
//if Value < 2 then <- unreachable
// Value := 2;
//if Value > 10 then
// Value := 10;
ResizeControl(FRows, FColumns, Value);
end;
end;
{=====}
end.

485
components/industrialstuff/source/sensors.pas Normal file
View File

@@ -0,0 +1,485 @@
{ Copyright (C) 1998-2000, written by Shkolnik Mike
FIDOnet: 2:463/106.14
E-Mail: mshkolnik@scalabium.com
mshkolnik@yahoo.com
WEB: http://www.scalabium.com
http://www.geocities.com/mshkolnik
tel: 380-/44/-552-10-29
TStopLightSensor and TAnalogSensor sensor components
Modified by Jurassic Pork for Lazarus "Industrial" package
}
unit Sensors;
{$mode objfpc}{$H+}
interface
uses LCLIntf, LCLType, LResources, Classes, Controls, Graphics, Stdctrls, Extctrls;
type
TStopLights = (slUNKNOWN, slRED, slYELLOW, slGREEN);
type
TSensorPanel = class(TPanel)
private
FlblShowText: TLabel; {sensor value}
FShowText: Boolean;
FShowLevel: Boolean; {show the RED and YELLOW levels or not}
FValue: Double;
FValueMin: Double;
FValueMax: Double;
FValueRed: Double;
FValueYellow: Double;
FColorBack: TColor;
FColorFore: TColor;
FColorRed: TColor;
FColorYellow: TColor;
function GetCaption: TCaption;
procedure SetCaption(AValue: TCaption);
procedure SetShowText(AValue: Boolean);
procedure SetShowLevel(AValue: Boolean);
procedure SetColorInd(Index: Integer; AValue: TColor);
procedure SetValue(AValue: Double); virtual;
procedure SetValueMin(AValue: Double);
procedure SetValueMax(AValue: Double);
procedure SetValueRed(AValue: Double);
procedure SetValueYellow(AValue: Double);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetStatus: TStopLights;
procedure SetColorState(slStopLight: TStopLights); virtual;
published
property Caption read GetCaption write SetCaption;
property ShowText: Boolean read FShowText write SetShowText;
property ShowLevel: Boolean read FShowLevel write SetShowLevel;
property ColorFore: TColor index 0 read FColorFore write SetColorInd default clLime;
property ColorBack: TColor index 1 read FColorBack write SetColorInd default clBlack;
property ColorRed: TColor index 2 read FColorRed write SetColorInd default clRed;
property ColorYellow: TColor index 3 read FColorYellow write SetColorInd default clYellow;
property Value: Double read FValue write SetValue;
property ValueMin: Double read FValueMin write SetValueMin;
property ValueMax: Double read FValueMax write SetValueMax;
property ValueRed: Double read FValueRed write SetValueRed;
property ValueYellow: Double read FValueYellow write SetValueYellow;
end;
TAnalogKind = (akAnalog, akHorizontal, akVertical);
TAnalogSensor = class(TSensorPanel)
private
FAnalogKind: TAnalogKind;
procedure PaintAsNeedle;
procedure PaintAsHorizontal;
procedure PaintAsVertical;
procedure SetAnalogKind(AValue: TAnalogKind);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property Font;
property AnalogKind: TAnalogKind read FAnalogKind write SetAnalogKind;
end;
TStopLightSensor = class(TImage)
private
FState: TStopLights;
procedure SetState(AValue: TStopLights);
protected
public
constructor Create(AOwner: TComponent); override;
published
property Center default True;
property State: TStopLights read FState write SetState;
end;
implementation
{$R sensors.res}
uses SysUtils;
{ TSensorPanel }
constructor TSensorPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Height := 75;
Width := 170;
Parent := AOwner as TWinControl;
FValue := 0;
FValueMin := 0;
FValueMax := 100;
FValueRed := 30;
FValueYellow := 60;
FColorFore := {clGreen} clLime;
FColorBack := clBlack {clWhite};
FColorRed := clRed;
FColorYellow := clYellow;
FlblShowText := TLabel.Create(Self);
with FlblShowText do
begin
Alignment := taCenter;
AutoSize := False;
Font := Self.Font;
Height := 17;
Left := 5;
Top := 57;
Width := 160;
Parent := Self;
Align := alBottom;
end;
FShowLevel := True;
Caption := '';
ShowText := True;
end;
destructor TSensorPanel.Destroy;
begin
// FlblShowText.Free;
inherited Destroy;
end;
function TSensorPanel.GetStatus: TStopLights;
begin
Result := slUNKNOWN;
if (Value > ValueMin) and (Value < ValueMin) then Result := slGREEN;
if (Value < ValueYellow) then Result := slYellow;
if (Value < ValueRed) then Result := slRED;
end;
procedure TSensorPanel.SetColorState(slStopLight: TStopLights);
begin
FlblShowText.Font := Font;
case slStopLight of
slRED: FlblShowText.Font.Color := FColorRed;
slYELLOW: FlblShowText.Font.Color := FColorYellow;
else // slUNKNOWN, slGREEN
// FlblShowText.Font := Font;
end;
end;
procedure TSensorPanel.SetValue(AValue: Double);
begin
if (AValue < FValueMin) then
AValue := FValueMin
else
if (AValue > FValueMax) then
AValue := FValueMax;
if (FValue <> AValue) then
begin
FValue := AValue;
FlblShowText.Caption := FlblShowText.Hint + FloatToStr(FValue);
Invalidate;
end;
end;
function TSensorPanel.GetCaption: TCaption;
begin
// Modif J.P 05/2013 Caption replace Hint
Result := FlblShowText.Hint;
end;
procedure TSensorPanel.SetCaption(AValue: TCaption);
begin
// Modif J.P 05/2013 Caption replace Hint
FlblShowText.Hint := AValue;
inherited Caption := '';
FlblShowText.Caption := FlblShowText.Hint + FloatToStr(FValue);
Invalidate;
end;
procedure TSensorPanel.SetShowText(AValue: Boolean);
begin
if (AValue <> FShowText) then
begin
FShowText := AValue;
FlblShowText.Visible := FShowText;
end;
end;
procedure TSensorPanel.SetShowLevel(AValue: Boolean);
begin
if (AValue <> FShowLevel) then
begin
FShowlevel := AValue;
Invalidate;
end;
end;
procedure TSensorPanel.SetColorInd(Index: Integer; AValue: TColor);
begin
if (AValue <> FColorFore) then
begin
case Index of
0: FColorFore := AValue;
1: FColorBack := AValue;
2: FColorRed := AValue;
3: FColorYellow := AValue;
end;
Invalidate;
end;
end;
procedure TSensorPanel.SetValueMin(AValue: Double);
begin
if (AValue <> FValueMin) then
begin
if (AValue > FValueMin) then
if not (csLoading in ComponentState) then
raise EInvalidOperation.CreateFmt('OutOfRange', [-MaxInt, Round(FValueMax - 1)]);
FValueMin := AValue;
if (FValue < AValue) then FValue := AValue;
Invalidate;
end;
end;
procedure TSensorPanel.SetValueMax(AValue: Double);
begin
if (AValue <> FValueMax) then
begin
if (AValue < FValueMin) then
if not (csLoading in ComponentState) then
raise EInvalidOperation.CreateFmt('SOutOfRange', [Round(FValueMin + 1), MaxInt]);
FValueMax := AValue;
if (FValue > AValue) then FValue := AValue;
Invalidate;
end;
end;
procedure TSensorPanel.SetValueRed(AValue: Double);
begin
if (AValue <> FValueRed) then
begin
if (AValue < FValueMin) or (AValue > FValueMax) then
if not (csLoading in ComponentState) then
raise EInvalidOperation.CreateFmt('SOutOfRange', [Round(FValueMin), Round(FValueMax)]);
FValueRed := AValue;
Invalidate;
end;
end;
procedure TSensorPanel.SetValueYellow(AValue: Double);
begin
if (AValue <> FValueYellow) then
begin
if (AValue < FValueRed) or (AValue > FValueMax) then
if not (csLoading in ComponentState) then
raise EInvalidOperation.CreateFmt('SOutOfRange', [Round(FValueRed), Round(FValueMax)]);
FValueYellow := AValue;
Invalidate;
end;
end;
{ TAnalogSensor }
constructor TAnalogSensor.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Value := 20;
AnalogKind := akAnalog;
end;
procedure TAnalogSensor.Paint;
begin
inherited Paint;
case FAnalogKind of
akAnalog: PaintAsNeedle;
akHorizontal: PaintAsHorizontal;
akVertical: PaintAsVertical;
end;
end;
function SolveForY(X, Z: Double): Double;
begin
if Z = 0 then
Result := 0
else
Result := X/Z;
end;
procedure TAnalogSensor.PaintAsNeedle;
var MiddleX: Integer;
Angle: Double;
X, Y, W, H: Integer;
begin
X := 20;
Y := 23;
W := ClientWidth - 2*20; //130;
H := ClientHeight - 2*23; //33;
if (W < 1) or (H < 1) then Exit;
with Canvas do
begin
Brush.Color := ColorBack;
Pen.Color := clBlack;
Pen.Width := 1;
{ draw a pie }
Pie(X, Y, X + W, Y + 2*H, X + W, Y + H - 1, X, Y + H - 1);
// Chord(X, Y, X+W, (Y+H)*2, X+W, Y+H-1, X, Y+H-1);
MiddleX := W div 2;
{ draw pie for current value }
Brush.Color := ColorFore;
Pen.Color := clBlack;
MoveTo(X + MiddleX, Y + H - 1);
Angle := Pi * SolveForY(FValue - FValueMin, FValueMax - FValueMin);
Pie(X, Y, X + W, Y + 2*H, Round(X + MiddleX*(1 - Cos(Angle))), Round(Y - 1 + H*(1 - Sin(Angle))), X, Y+H);
if FShowLevel then
begin
// Pen.Width := 1;
{ draw a RED level line }
Pen.Color := ColorRed;
MoveTo(X + MiddleX, Y + H - 1);
Angle := Pi * SolveForY(FValueRed - FValueMin, FValueMax - FValueMin);
LineTo(Round(X + MiddleX*(1 - Cos(Angle))), Round(Y - 1 + H*(1 - Sin(Angle))));
{ draw a YELLOW level line }
Pen.Color := ColorYellow;
MoveTo(X + MiddleX, Y + H - 1);
Angle := Pi * SolveForY(FValueYellow - FValueMin, FValueMax - FValueMin);
LineTo(Round(X + MiddleX*(1 - Cos(Angle))), Round(Y - 1 + H*(1 - Sin(Angle))));
end;
end;
end;
procedure TAnalogSensor.PaintAsHorizontal;
var MiddleX: Integer;
X, Y, W, H: Integer;
begin
X := 20;
Y := 23;
W := ClientWidth - 2*20; //130;
H := ClientHeight - 2*23; //33;
if (W < 1) or (H < 1) then Exit;
with Canvas do
begin
Brush.Color := ColorBack;
Pen.Color := clBlack;
Pen.Width := 1;
Rectangle(X, Y, X + W, Y + H);
{ draw pie for current value }
Brush.Color := ColorFore;
Pen.Color := clBlack;
MiddleX := Round(W*SolveForY(FValue - FValueMin, FValueMax - FValueMin));
Rectangle(X, Y, X + MiddleX, Y + H);
if FShowLevel then
begin
{ draw a RED level line }
Pen.Color := ColorRed;
MiddleX := Round(W*SolveForY(FValueRed - FValueMin, FValueMax - FValueMin));
MoveTo(X + MiddleX, Y + 1);
LineTo(X + MiddleX, Y + H - 1);
{ draw a YELLOW level line }
Pen.Color := ColorYellow;
MiddleX := Round(W*SolveForY(FValueYellow - FValueMin, FValueMax - FValueMin));
MoveTo(X + MiddleX, Y + 1);
LineTo(X + MiddleX, Y + H - 1);
end;
end;
end;
procedure TAnalogSensor.PaintAsVertical;
var MiddleY: Integer;
X, Y, W, H: Integer;
begin
X := 20;
Y := 23;
W := ClientWidth - 2*20; //130;
H := ClientHeight - 2*23; //33;
if (W < 1) or (H < 1) then Exit;
with Canvas do
begin
Brush.Color := ColorBack;
Pen.Color := clBlack;
Pen.Width := 1;
Rectangle(X + W - 1, Y + H - 1, X, Y);
{ draw pie for current value }
Brush.Color := ColorFore;
Pen.Color := clBlack;
MiddleY := Round(H*SolveForY(FValue - FValueMin, FValueMax - FValueMin));
Rectangle(X, Y + H - 1 - MiddleY, X + W - 1, Y + H - 1);
if FShowLevel then
begin
{ draw a RED level line }
Pen.Color := ColorRed;
MiddleY := Round(H*SolveForY(FValueRed - FValueMin, FValueMax - FValueMin));
MoveTo(X + 1, Y + H - 1 - MiddleY);
LineTo(X + W - 1, Y + H - 1 - MiddleY);
{ draw a YELLOW level line }
Pen.Color := ColorYellow;
MiddleY := Round(H*SolveForY(FValueYellow - FValueMin, FValueMax - FValueMin));
MoveTo(X + 1, Y + H - 1 - MiddleY);
LineTo(X + W - 1, Y + H - 1 - MiddleY);
end;
end;
end;
procedure TAnalogSensor.SetAnalogKind(AValue: TAnalogKind);
begin
if (AValue <> FAnalogKind) then
begin
FAnalogKind := AValue;
Invalidate;
end;
end;
{ TStopLightSensor }
constructor TStopLightSensor.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 23;
Height := 43;
Center := True;
FState := slRED;
State := slUNKNOWN;
end;
procedure TStopLightSensor.SetState(AValue: TStopLights);
begin
if (AValue <> FState) then
begin
FState := AValue;
case AValue of
slUNKNOWN: Picture.LoadFromResourceName(HInstance, 'STOP_UNKNOWN', TPortableNetworkGraphic);
slRED: Picture.LoadFromResourceName(HInstance, 'STOP_RED', TPortableNetworkGraphic);
slYELLOW: Picture.LoadFromResourceName(HInstance, 'STOP_YELLOW', TPortableNetworkGraphic);
slGREEN: Picture.LoadFromResourceName(HInstance, 'STOP_GREEN', TPortableNetworkGraphic);
end;
end;
end;
end.

BIN
components/industrialstuff/source/sensors.res Normal file
View File

Binary file not shown.