{
Programm : SWITCH.PAS
Sprache : Delphi
Zweck : Schalter-Komponente
Datum : 15, 16. Feb. 1996
Autor : U.Jnr-
This component simulates a luffing switch as used in many electic devices.
No Bitmaps are used, so it's fully scaleable.
Sorry for comments are in german.
Contact: Udo Juerss, 57078 Siegen, Germany, CompuServe [101364,526]
Greetings from germany - enjoy...
}
unit
Switch;
interface
uses
WinTypes, WinProcs, Messages, Classes, Controls, Graphics;
{------------------------------------------------------------------------------}
type
RectArray = array[0..3] of TPoint; {Vektorarraytyp fnr Rechteck}
TriArray = array[0..2] of TPoint; {Vektorarraytyp fnr Dreieck}
TSwitch = class(TCustomControl)
private
TopShape: TriArray; {Dreieck Vektoren von Schalteroberseite}
OnShape: RectArray; {Rechteck Vektoren von Schalterfront "ON"}
OffShape: RectArray; {Rechteck Vektoren von Schalterfront "OFF"}
SideShape: RectArray; {Rechteck Vektoren von Schalterseite}
FOnChanged: TNotifyEvent; {Verbindung zur Aussenwelt}
FOnChecked: TNotifyEvent; {Verbindung zur Aussenwelt}
FOnUnChecked: TNotifyEvent; {Verbindung zur Aussenwelt}
FCaptionOn: TCaption; {Beschriftung Schalterstellung "ON"}
FCaptionOff: TCaption; {Beschriftung Schalterstellung "OFF"}
FChecked: Boolean; {Flag von Schalterstellung}
FCheckedLeft: Boolean; {Flag ob "ON" links oder rechts dargestellt wird}
FSlope: Byte; {Neigung (3D Effekt) des Schalters}
FSideLength: Byte; {Seitenabstand fnr hervorstehendes Schalterteil}
FOnColor: TColor; {Farbe fnr Frontfl_che "ON"}
FOffColor: TColor; {Farbe fnr Frontfl_che "OFF"}
FTopColor: TColor; {Farbe fnr Schalteroberseite}
FSideColor: TColor; {Farbe fnr Seitenfl_che}
ALeft: Integer; {Linke Anfangsposition des Schalters}
ATop: Integer; {Obere Anfangsposition des Schalters}
AHeight: Integer; {Hwhe des Schalters}
AWidth: Integer; {Breite des Schalters}
LabelLen: Integer; {Halbbreite des Schalters}
LabelOfs: Integer; {Halbbreite fnr Spiegeldarstellung}
Side: Integer; {Tempor_r in Setup verwendet}
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
procedure CallNotifyEvent;
procedure Setup;
procedure Draw;
procedure SetCaptionOn(Value: TCaption);
procedure SetCaptionOff(Value: TCaption);
procedure SetChecked(Value: Boolean);
procedure SetCheckedLeft(Value: Boolean);
procedure SetSlope(Value: Byte);
procedure SetSideLength(Value: Byte);
procedure SetOnColor(Value: TColor);
procedure SetOffColor(Value: TColor);
procedure SetTopColor(Value: TColor);
procedure SetSideColor(Value: TColor);
public
constructor Create(AOwner: TComponent); override;
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
published
property CaptionOn: TCaption read FCaptionOn write SetCaptionOn;
property CaptionOff: TCaption read FCaptionOff write SetCaptionOff;
property Checked: Boolean read FChecked write SetChecked default False;
property CheckedLeft: Boolean read FCheckedLeft write SetCheckedLeft default True;
property Slope: Byte read FSlope write SetSlope default 6;
property SideLength: Byte read FSideLength write SetSideLength default 6;
property OnColor: TColor read FOnColor write SetOnColor default clRed;
property OffColor: TColor read FOffColor write SetOffColor default clMaroon;
property TopColor: TColor read FTopColor write SetTopColor default clSilver;
property SideColor: TColor read FSideColor write SetSideColor default clSilver;
property Font;
property TabStop;
property TabOrder;
property ShowHint;
property OnClick;
property OnMouseDown;
property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
property OnChecked: TNotifyEvent read FOnChecked write FOnChecked;
property OnUnChecked: TNotifyEvent read FOnUnChecked write FOnUnChecked;
end;
{------------------------------------------------------------------------------}
procedure Register;
implementation
{------------------------------------------------------------------------------}
constructor TSwitch.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Caption:='';
FCaptionOn:='EIN';
FCaptionOff:='AUS';
FSlope:=6;
FSideLength:=6;
FChecked:=False;
FCheckedLeft:=True;
FOnColor:=clRed;
FOffColor:=clMaroon;
FTopColor:=clSilver;
FSideColor:=clSilver;
FOnChecked:=nil;
FOnUnChecked:=nil;
SetBounds(Left,Top,83,18 + FSlope);
Font.Name:='small fonts';
Font.Size:=7;
Font.Color:=clWhite;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.Paint;
begin
Draw; {Keine geerbte Methode aufrufen und sofort Schalter zeichnen}
end;
{------------------------------------------------------------------------------}
procedure TSwitch.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited MouseDown(Button,Shift,X,Y);
if (Button = mbLeft) then
begin
SetFocus;
if ((LabelLen > 0) and (X > LabelLen)) or
((LabelLen < 0) and (X < Abs(LabelLen))) then
begin {Nur wenn Mausklick innerhalb des hervorgehobenen Schalterteil ist}
FChecked:=not FChecked;
CallNotifyEvent;
Invalidate;
end;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.WMSetFocus(var Message: TWMSetFocus);
begin
Invalidate;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.WMKillFocus(var Message: TWMKillFocus);
begin
Invalidate;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.KeyDown(var Key: Word; Shift: TShiftState);
begin
if Focused and ((Key = VK_Space) or (Key = VK_Return)) then
begin
FChecked:=not FChecked;
CallNotifyEvent;
Invalidate;
Click;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.CallNotifyEvent; {Au-enwelt informieren}
begin
if Assigned(FOnChanged) then FOnChanged(Self);
if FChecked and Assigned(FOnChecked) then FOnChecked(Self) else
if not FChecked and Assigned(FOnUnChecked) then FOnUnChecked(Self);
end;
{------------------------------------------------------------------------------}
procedure TSwitch.Draw; {Schalter zeichnen}
var
TW: Integer;
TH: Integer;
begin
Setup; {Vektoren fnr Schalterteile berechnen}
if Focused then Canvas.Rectangle(0,0,Width,AHeight + 1 + 2 * ATop);
Canvas.Pen.Color:=clWhite; {Umrandung von Schalter zeichnen}
Canvas.MoveTo(ALeft - 1,ATop + AHeight + 1);
Canvas.LineTo(ALeft + AWidth,ATop + AHeight + 1); {Untere Linie in weiss}
Canvas.LineTo(ALeft + AWidth,ATop - 2); {Rechte Linie in weiss}
Canvas.Pen.Color:=clGray;
Canvas.MoveTo(ALeft + AWidth,ATop - 1);
Canvas.LineTo(ALeft - 1,ATop - 1); {Obere Linie in dunkelgrau}
Canvas.LineTo(ALeft - 1,ATop + AHeight + 1); {Linke Linie in dunkelgrau}
Canvas.Pen.Color:=clBlack; {Polygonumrandung ist schwarz}
Canvas.Brush.Style:=bsSolid; {Fnllfl_che ist geschlossen}
Setup;
Canvas.Brush.Color:=FTopColor;
Canvas.Polygon(TopShape); {Top des Schalters zeichnen}
Canvas.Brush.Color:=FSideColor;
Canvas.Polygon(SideShape); {Seite des Schalters zeichnen}
if FChecked then Canvas.Brush.Color:=FOnColor
else Canvas.Brush.Color:=FOffColor;
Canvas.Polygon(OnShape); {On Seite des Schalters zeichnen}
Canvas.Brush.Color:=FOffColor;
Canvas.Polygon(OffShape); {Off Seite des Schalters zeichnen}
Canvas.Font:=Font; {Gew_hlten Font nbergeben}
Canvas.Brush.Style:=bsClear; {Transparente Textausgabe}
if FChecked then Caption:=FCaptionOn else Caption:=FCaptionOff;
if LabelLen > 0 then TW:=ALeft + ((Abs(LabelLen) - Canvas.TextWidth(Caption)) div 2)
else TW:=LabelOfs + ((Abs(LabelLen) - Canvas.TextWidth(Caption)) div 2);
TH:=ATop + ((AHeight - Canvas.TextHeight(Caption)) div 2);
Canvas.TextOut(TW,TH,Caption);
end;
{------------------------------------------------------------------------------}
procedure TSwitch.Setup; {Vektoren fnr Schalterteile berechnen}
begin
ALeft:=2; {2 Pixel linker Abstand fnr Rahmen und Focusrechteck}
ATop:=2; {2 Pixel oberer Abstand fnr Rahmen und Focusrechteck}
AHeight:=Height - FSlope - 2 * ATop; {Schalterhwhe = Height - Ofs - Neigung}
AWidth:=Width - 2 * ALeft; {Schalterbreite = Width - 2 * Ofs}
LabelLen:=AWidth div 2;
LabelOfs:=LabelLen + ALeft;
Side:=FSideLength;
if (not FChecked and FCheckedLeft) or (not FCheckedLeft and FChecked) then
begin
LabelLen:=-LabelLen;
Side:=-FSideLength;
end;
TopShape[0].X:=LabelOfs; {Vektoren von obere Dreieckfl_che berechnen}
TopShape[0].Y:=ATop;
TopShape[1].X:=LabelOfs + LabelLen - Side;
TopShape[1].Y:=ATop + FSlope;
TopShape[2].X:=LabelOfs + LabelLen;
TopShape[2].Y:=ATop;
OnShape[0].X:=LabelOfs - LabelLen; {Vektoren der "EIN" Frontseite berechnen}
OnShape[0].Y:=ATop;
OnShape[1]:=TopShape[0];
OnShape[2]:=OffShape[3];
OnShape[3].X:=OnShape[0].X;
OnShape[3].Y:=ATop + AHeight;
OffShape[0]:=TopShape[0]; {Vektoren der "AUS" Frontseite berechnen}
OffShape[1]:=TopShape[1];
OffShape[2].X:=OffShape[1].X;
OffShape[2].Y:=OffShape[1].Y + AHeight;
OffShape[3].X:=OffShape[0].X;
OffShape[3].Y:=ATop + AHeight;
SideShape[0]:=OffShape[1]; {Vektoren der Seitenfl_che berechnen}
SideShape[1]:=TopShape[2];
SideShape[2].X:=SideShape[1].X;
SideShape[2].Y:=ATop + AHeight;
SideShape[3]:=OffShape[2];
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetCaptionOn(Value: TCaption); {Beschriftung "ON" nbergeben}
begin
if FCaptionOn <> Value then
begin
FCaptionOn:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetCaptionOff(Value: TCaption); {Beschriftung "OFF" nbergeben}
begin
if FCaptionOff <> Value then
begin
FCaptionOff:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetChecked(Value: Boolean);
begin
if FChecked <> Value then
begin
FChecked:=Value;
CallNotifyEvent;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetCheckedLeft(Value: Boolean);
begin
if FCheckedLeft <> Value then
begin
FCheckedLeft:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetSlope(Value: Byte);
begin
if FSlope <> Value then
begin
FSlope:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetSideLength(Value: Byte);
begin
if (FSideLength <> Value) and (Value < Width - 4) then
begin
FSideLength:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetOnColor(Value: TColor);
begin
if FOnColor <> Value then
begin
FOnColor:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetOffColor(Value: TColor);
begin
if FOffColor <> Value then
begin
FOffColor:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetTopColor(Value: TColor);
begin
if FTopColor <> Value then
begin
FTopColor:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure TSwitch.SetSideColor(Value: TColor);
begin
if FSideColor <> Value then
begin
FSideColor:=Value;
Invalidate;
end;
end;
{------------------------------------------------------------------------------}
procedure Register;
begin
RegisterComponents('Udo|s',[TSwitch]);
end;
{------------------------------------------------------------------------------}
initialization
end.