[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    {
      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.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]