DBR Delphi-Ecke

// Getestet mit D4 unter XP (W7)

// Achtung!
// Wenn Sie die Komponente in Programmen einsetzen, die unter W7 oder
// höher laufen sollen, muss man bei älteren Delphi-Versionen "Scaleby"
// nutzen, um die Anzeige korrekt darzustellen, falls die Bildschirm-
// auflösung geändert wird.
// Empfohlen:

procedure TForm1.FormCreate(Sender: TObject);
begin
 scaleby(199, 200);
end;

// 1. Einfache Variante

// Komponente für einen Wippschalter (scherzhaft Schaukler, Rocker).
// Um die Komponente darzustellen, müssen Sie wipp.zip downloaden, entpacken
// und in das Verzeichnis der Komponente (Lib) kopieren. Um auf das Schalten
// zu reagieren, benutzen Sie MouseDown:

procedure TForm1.Rocker1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if TRocker(Sender).Switch = rckOn then label1.caption := 'EIN' else 
    label1.caption := 'AUS'; 
end;

// Erläuterung der wichtigen Eigenschaften:

// AlwaysRespond (Boolean [True, False])
// Steht diese Eigenschaft auf TRUE, wird der Schalter umgeschaltet,
// egal wohin man klickt. Hat die Eigenschaft den Wert FALSE, kann man
// nur auf den (scheinbar) erhabenen Teil der Wippe klicken

// Color (TRckColor [rckBoth, rckGreen, rckRed])
// Bei rckGreen hat die Wippe bei jedem Schaltzustand die Farbe Grün,
// bei rckRed hat die Wippe bei jedem Schaltzustand die Farbe Rot.
// Bei rckBoth ist die Wippe in eingeschaltetem Zustand grün und im
// ausgeschalteten Zustand rot.

// CursorNormal und CursorSwitch (TCursor)
// Wenn AlwaysRespond (siehe oben) auf FALSE steht, wird bei dem
// (scheinbar) erhabenen Teil der Wippe ein anderer Cursor angezeigt als
// bei dem unteren Teil. Bei AlwaysRespond=TRUE wird CursorNormal dem
// CursorSwitch angepasst.

// Kind (TRckKind [rckHorizontal, rckVertical])
// Bestimmt die Ausrichtung der Komponente.

// Size (TRckSize [rckLarge, rckNormal, rckSmall])
// Stellt die Komponente in 3 Größen dar.

// Switch (TRckSwitch [rckOff, rckOn])
// Bestimmt, ob der Schalter ein- oder ausgeschaltet ist.

// Checked (Boolean [True, False]) Nur zur Laufzeit!
// Ist das Selbe wie Switch und bestimmt auch EIN/AUS.
// Checked entspricht Switch=rckOn; not Checked entspricht Switch=rckOff.

// Enabled (Boolean [True, False])
// Die Schaltwippe wird bei not Enabled grau dargestellt.

//------------------------------------------------------------------------

unit Rocker; 
 
interface 
 
uses 
  Windows, Classes, Graphics, Controls; 
 
type 
  TRckSize = (rckLarge, rckNormal, rckSmall); 
  TRckColor = (rckBoth, rckGreen, rckRed); 
  TRckKind = (rckHorizontal, rckVertical); 
  TRckSwitch = (rckOff, rckOn); 
 
  TRocker = class(TGraphicControl) 
  private 
    FBmp: array[0..1] of TBitmap; 
    FCursorD, FCursorN, FCursorM: TCursor; 
    FDiffw, FDiffh: integer; 
    FSwitch: TRckSwitch; 
    FColor: TRckColor; 
    FAlways: Boolean; 
    FSize: TRckSize; 
    FKind: TRckKind; 
    FHlp: TBitmap; 
  protected 
    procedure Paint; override; 
    procedure Resize; override; 
    function onthat(x, y: integer): boolean; 
    procedure changecursor(x, y: integer); 
    procedure writechecked(b: boolean); 
    procedure setswitch(s: TRckSwitch); 
    procedure setFColor(f: TRckColor); 
    procedure VertFlip(bmp: TBitmap); 
    procedure HorzFlip(bmp: TBitmap); 
    procedure setcursord(c: TCursor); 
    procedure setcursorn(c: TCursor); 
    procedure setAlways(b: boolean); 
    procedure setkind(k: TRckKind); 
    procedure setsize(s: TRckSize); 
    function readchecked: boolean; 
    procedure Rotate(bm: TBitmap); 
    procedure buildonoff; 
    procedure Dimension; 
    procedure arrange; 
  public 
    procedure MouseDown(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseMove(Shift: TShiftState; X, 
      Y: Integer); override; 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
    procedure SetEnabled(Value: Boolean); override; 
    procedure Loaded; override; 
    property Checked: boolean read readchecked write writechecked; 
  published 
    property CursorNormal: TCursor read FCursorN write setcursorn; 
    property CursorSwitch: TCursor read FCursorD write setcursord; 
    property AlwaysRespond: boolean read FAlways write setAlways; 
    property Switch: TRckSwitch read FSwitch write setswitch; 
    property Color: TRckColor read FColor write setFColor; 
    property Size: TRckSize read FSize write setsize; 
    property Kind: TRckKind read FKind write setkind; 
    property ParentShowHint; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnMouseUp; 
    property ShowHint; 
    property Visible; 
    property Enabled; 
  end; 
 
procedure Register; 
 
implementation 
 
{$R wipp.res} 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TRocker]); 
end; 
 
constructor TRocker.Create(Owner: TComponent); 
var 
  x: integer; 
begin 
  inherited Create(Owner); 
  for x := 0 to 1 do begin 
    FBmp[x] := TBitmap.create; 
    FBmp[x].pixelformat := pf24bit; 
  end; 
  FCursorD := crHandpoint; 
  FHlp := TBitmap.create; 
  FKind := rckVertical; 
  FCursorN := crArrow; 
  FCursorM := crArrow; 
  setsize(rckNormal); 
  FSwitch := rckOff; 
  FColor := rckBoth; 
  FAlways := false; 
  arrange; 
end; 
 
destructor TRocker.Destroy; 
var 
  x: integer; 
begin 
  for x := 0 to 1 do FBmp[x].free; 
  FHlp.free; 
  inherited Destroy; 
end; 
 
procedure TRocker.HorzFlip(bmp: TBitmap); 
begin 
  stretchblt(bmp.canvas.handle, 0, 0, bmp.width, bmp.height, 
    bmp.canvas.handle, bmp.width - 1, 0, -bmp.width, bmp.height, SRCCOPY); 
end; 
 
procedure TRocker.VertFlip(bmp: TBitmap); 
begin 
  stretchblt(bmp.canvas.handle, 0, 0, bmp.width, bmp.height, 
    bmp.canvas.handle, 0, bmp.height - 1, bmp.width, -bmp.height, SRCCOPY); 
end; 
 
procedure TRocker.Rotate(bm: TBitmap); 
type 
  TripleArray = array[0..50] of TRGBTriple; 
  PTriple = ^TripleArray; 
var 
  p: PTriple; 
  x, y: integer; 
  bitmap: TBitmap; 
begin 
  bm.pixelformat := pf24bit; 
  bitmap := TBitmap.create; 
  bitmap.width := bm.height; 
  bitmap.height := bm.width; 
  bitmap.pixelformat := pf24bit; 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    for x := bm.width - 1 downto 0 do 
      PTriple(bitmap.scanline[pred(bm.width - x)])[y] := p[x]; 
  end; 
  bm.width := bitmap.width; 
  bm.height := bitmap.height; 
  bm.canvas.draw(0, 0, bitmap); 
  bitmap.free; 
  vertflip(bm); 
end; 
 
procedure TRocker.Dimension; 
var 
  x: integer; 
  procedure zw(b: TBitmap); 
  begin 
    b.width := width; 
    b.height := height; 
  end; 
begin 
  if FKind = rckVertical then begin 
    width := 33 - FDiffw; 
    height := 51 - FDiffh; 
  end else begin 
    width := 51 - FDiffh; 
    height := 33 - FDiffw; 
  end; 
  for x := 0 to 1 do 
    zw(FBmp[x]); 
end; 
 
procedure TRocker.Resize; 
begin 
  inherited; 
  Dimension; 
end; 
 
procedure TRocker.Paint; 
begin 
  canvas.draw(0, 0, FBmp[ord(FSwitch)]); 
end; 
 
procedure TRocker.setswitch(s: TRckSwitch); 
begin 
  if s <> FSwitch then begin 
    FSwitch := s; 
    repaint; 
  end; 
end; 
 
procedure TRocker.buildonoff; 
var 
  x, w, h: integer; 
  procedure makelines(i: integer); 
  begin 
    with FBmp[x].canvas do begin 
      moveto(3, i); 
      lineto(w, i); 
      moveto(i, 3); 
      lineto(i, h); 
    end; 
  end; 
  procedure sdraw(cnv: TCanvas); 
  begin 
    with cnv do begin 
      SetStretchBltMode(handle, STRETCH_HALFTONE); 
      stretchdraw(rect(3, 3, w, h), FHlp); 
    end; 
  end; 
begin 
  if width = 0 then exit; 
  w := width - 3; 
  h := height - 3; 
  for x := 0 to 1 do 
    with FBmp[x], canvas do begin 
      FHlp.handle := LoadBitmap(HInstance, 'lio'); 
      draw(0, 0, FHlp); 
      horzflip(FHlp); 
      draw(w, 0, FHlp); 
      horzflip(FHlp); 
      vertflip(FHlp); 
      draw(0, h, FHlp); 
      FHlp.handle := LoadBitmap(HInstance, 'reu'); 
      draw(w, h, FHlp); 
      brush.color := clBlack; 
      fillrect(rect(w, 3, width, h)); 
      fillrect(rect(3, h, w, height)); 
      pen.color := clBlack; 
      makelines(2); 
      pen.color := $4C4C4C; 
      makelines(0); 
      pen.color := $ACACAC; 
      makelines(1); 
      transparent := true; 
    end; 
  if not enabled then FHlp.handle := LoadBitmap(HInstance, 'wgr') else 
    if (FColor = rckRed) or (FColor = rckBoth) then 
      FHlp.handle := LoadBitmap(HInstance, 'wrt') else 
      FHlp.handle := LoadBitmap(HInstance, 'wgn'); 
  if FKind = rckHorizontal then rotate(FHlp); 
  sdraw(FBmp[0].canvas); 
  if not enabled then FHlp.handle := LoadBitmap(HInstance, 'wgr') else 
    if FColor = rckRed then 
      FHlp.handle := LoadBitmap(HInstance, 'wrt') else 
      FHlp.handle := LoadBitmap(HInstance, 'wgn'); 
  if FKind = rckHorizontal then begin 
    rotate(FHlp); 
    horzflip(FHlp); 
  end else 
    vertflip(FHlp); 
  sdraw(FBmp[1].canvas); 
end; 
 
function TRocker.onthat(x, y: integer): boolean; 
var 
  l, r, i: integer; 
  b, bf: boolean; 
  function prf(w: integer): boolean; 
  begin 
    result := not bf and (w < l) or bf and (w > r); 
  end; 
begin 
  b := FKind = rckVertical; 
  bf := FSwitch = rckOff; 
  if b then i := height div 2 
  else i := width div 2; 
  l := pred(i); 
  r := l + 2; 
  result := b and prf(y) or not b and prf(x); 
end; 
 
procedure TRocker.MouseDown(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if FAlways or onthat(x, y) then begin 
    if FSwitch = rckOff then FSwitch := rckOn else FSwitch := rckOff; 
    repaint; 
    changecursor(x, y); 
    inherited; 
  end;   
end; 
 
procedure TRocker.SetEnabled(Value: Boolean); 
begin 
  inherited; 
  buildonoff; 
end; 
 
procedure TRocker.loaded; 
begin 
  arrange; 
  inherited; 
end; 
 
procedure TRocker.setFColor(f: TRckColor); 
begin 
  if f = FColor then exit; 
  FColor := f; 
  buildonoff; 
  repaint; 
end; 
 
procedure TRocker.setkind(k: TRckKind); 
begin 
  if k = FKind then exit; 
  FKind := k; 
  arrange; 
  repaint; 
end; 
 
procedure TRocker.changecursor(x, y: integer); 
begin 
  releasecapture; 
  if onthat(x, y) then cursor := FCursorD else cursor := FCursorN; 
end; 
 
procedure TRocker.MouseMove(Shift: TShiftState; X, 
  Y: Integer); 
begin 
  changecursor(x, y); 
  inherited; 
end; 
 
procedure TRocker.setcursord(c: TCursor); 
begin 
  FCursorD := c; 
end; 
 
procedure TRocker.setcursorn(c: TCursor); 
begin 
  FCursorN := c; 
end; 
 
procedure TRocker.setsize(s: TRckSize); 
begin 
  if s = FSize then exit; 
  FSize := s; 
  case s of 
    rckLarge: begin 
        FDiffw := 0; 
        FDiffh := 0; 
      end; 
    rckSmall: begin 
        FDiffw := 13; 
        FDiffh := 22; 
      end; 
  else begin 
      FDiffw := 7; 
      FDiffh := 12; 
    end; 
  end; 
  arrange; 
  repaint; 
end; 
 
procedure TRocker.arrange; 
begin 
  Dimension; 
  buildonoff; 
end; 
 
procedure TRocker.setAlways(b: boolean); 
begin 
  if b = FAlways then exit; 
  FAlways := b; 
  if b then begin 
    FCursorM := FCursorN; 
    FCursorN := FCursorD; 
  end else FCursorN := FCursorM; 
end; 
 
function TRocker.readchecked: boolean; 
begin 
  result := FSwitch = rckOn; 
end; 
 
procedure TRocker.writechecked(b: boolean); 
begin 
  if b then begin 
    if FSwitch = rckOn then exit; 
    setswitch(rckOn); 
  end else begin 
    if FSwitch = rckOff then exit; 
    setswitch(rckOff); 
  end; 
end; 
 
end.

// -----------------------------------------------------------------------

// 2. Mehrfarb-Variante

// Die Eigenschaften sind fast identisch mit der einfachen Variante, jedoch
// Color entfällt. Dafür gibt es die Eigenschaften ColorOn und ColorOff,
// welche jeweils eine von zehn (plus Grau für disabled) Farben annehmen
// können. Dazu müssen Sie hier wippx.zip downloaden und in das Verzeichnis
// der Komponente (Lib) entpacken. Logischerweise nimmt die Komponente durch
// die größere Ressource mehr Speicher in Anspruch. Zusätzlich ist das
// Ereignis OnChange dazugekommen, welches beim Ändern des Schaltzustandes
// ausgelöst wird. Außerdem kann man dieses Ereignis auch beim Laden der
// Komponente (Programmstart) auslösen lassen, wenn man die Eigenschaft
// EventOnLoad auf True setzt. Das könnte man beispielsweise benötigen,
// wenn der Schaltzustand bereits beim Start angezeigt werden soll, Z.B.:

procedure TForm1.Rockerx1Change(Sender: TObject; State: Boolean);
begin
if state then label1.caption := 'EIN' else
label1.caption := 'AUS';
end;

// Ist EventOnLoad=False, wird das Ereignis OnChange beim ersten
// Anklicken oder beim ersten Setzen von Switch ausgelöst.

unit Rockerx; 
 
interface 
 
uses 
  Windows, 
  Classes, 
  Controls, 
  Graphics; 
 
type 
  TRckEvent = procedure(Sender: TObject; State: Boolean) of object; 
  TRckColor = (rckAqua, rckBlack, rckBlue, rckBrown, rckGreen, 
    rckOrange, rckPink, rckRed, rckWhite, rckYellow); 
  TRckSize = (rckLarge, rckNormal, rckSmall); 
  TRckKind = (rckHorizontal, rckVertical); 
  TRckSwitch = (rckOff, rckOn); 
 
  TRockerx = class(TGraphicControl) 
  private 
    FCursorD, FCursorN, FCursorM: TCursor; 
    FColorOn, FColorOff: TRckColor; 
    FBmp: array[0..1] of TBitmap; 
    FAlways, FOnStart: Boolean; 
    FDiffw, FDiffh: integer; 
    FSwitch: TRckSwitch; 
    FOff, FOn: string; 
    FEvent: TRckEvent; 
    FSize: TRckSize; 
    FKind: TRckKind; 
    FHlp: TBitmap; 
    FRect: TRect; 
  protected 
    procedure Paint; override; 
    procedure Loaded; override; 
    procedure Resize; override; 
    function onthat(x, y: integer): boolean; 
    procedure changecursor(x, y: integer); 
    function parse(f: TRckColor): string; 
    procedure setFColorOff(f: TRckColor); 
    procedure setFColorOn(f: TRckColor); 
    procedure writechecked(b: boolean); 
    procedure setswitch(s: TRckSwitch); 
    procedure VertFlip(bmp: TBitmap); 
    procedure HorzFlip(bmp: TBitmap); 
    procedure setcursord(c: TCursor); 
    procedure setcursorn(c: TCursor); 
    procedure setAlways(b: boolean); 
    procedure setkind(k: TRckKind); 
    procedure setsize(s: TRckSize); 
    function readchecked: boolean; 
    procedure Rotate(bm: TBitmap); 
    procedure buildonoff; 
    procedure switching; 
    procedure Dimension; 
    procedure arrange; 
  public 
    procedure MouseDown(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseMove(Shift: TShiftState; X, 
      Y: Integer); override; 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
    procedure SetEnabled(Value: Boolean); override; 
    property Checked: boolean read readchecked write writechecked; 
  published 
    property ColorOff: TRckColor read FColorOff write setFColorOff; 
    property CursorNormal: TCursor read FCursorN write setcursorn; 
    property CursorSwitch: TCursor read FCursorD write setcursord; 
    property AlwaysRespond: boolean read FAlways write setAlways; 
    property ColorOn: TRckColor read FColorOn write setFColorOn; 
    property EventOnLoad: boolean read FOnstart write FOnstart; 
    property Switch: TRckSwitch read FSwitch write setswitch; 
    property OnChange: TRckEvent read FEvent write FEvent; 
    property Size: TRckSize read FSize write setsize; 
    property Kind: TRckKind read FKind write setkind; 
    property ParentShowHint; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnMouseUp; 
    property ShowHint; 
    property Visible; 
    property Enabled; 
  end; 
 
procedure Register; 
 
implementation 
 
{$R wippx.res} 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TRockerx]); 
end; 
 
constructor TRockerx.Create(Owner: TComponent); 
var 
  x: integer; 
begin 
  inherited Create(Owner); 
  for x := 0 to 1 do begin 
    FBmp[x] := TBitmap.create; 
    FBmp[x].pixelformat := pf24bit; 
  end; 
  FCursorD := crHandpoint; 
  FHlp := TBitmap.create; 
  FKind := rckVertical; 
  FCursorN := crArrow; 
  FCursorM := crArrow; 
  setsize(rckNormal); 
  FSwitch := rckOff; 
  FAlways := false; 
  FColorOn := rckGreen; 
  FColorOff := rckRed; 
  FOn := parse(FColorOn); 
  FOff := parse(FColorOff); 
  arrange; 
end; 
 
destructor TRockerx.Destroy; 
var 
  x: integer; 
begin 
  for x := 0 to 1 do FBmp[x].free; 
  FHlp.free; 
  inherited Destroy; 
end; 
 
procedure TRockerx.HorzFlip(bmp: TBitmap); 
begin 
  stretchblt(bmp.canvas.handle, 0, 0, bmp.width, bmp.height, 
    bmp.canvas.handle, bmp.width - 1, 0, -bmp.width, bmp.height, SRCCOPY); 
end; 
 
procedure TRockerx.VertFlip(bmp: TBitmap); 
begin 
  stretchblt(bmp.canvas.handle, 0, 0, bmp.width, bmp.height, 
    bmp.canvas.handle, 0, bmp.height - 1, bmp.width, -bmp.height, SRCCOPY); 
end; 
 
procedure TRockerx.Rotate(bm: TBitmap); 
type 
  TripleArray = array[0..50] of TRGBTriple; 
  PTriple = ^TripleArray; 
var 
  p: PTriple; 
  x, y: integer; 
  bitmap: TBitmap; 
begin 
  bm.pixelformat := pf24bit; 
  bitmap := TBitmap.create; 
  bitmap.width := bm.height; 
  bitmap.height := bm.width; 
  bitmap.pixelformat := pf24bit; 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    for x := bm.width - 1 downto 0 do 
      PTriple(bitmap.scanline[pred(bm.width - x)])[y] := p[x]; 
  end; 
  bm.width := bitmap.width; 
  bm.height := bitmap.height; 
  bm.canvas.draw(0, 0, bitmap); 
  bitmap.free; 
  vertflip(bm); 
end; 
 
procedure TRockerx.Dimension; 
var 
  x: integer; 
  procedure zw(b: TBitmap); 
  begin 
    b.width := width; 
    b.height := height; 
  end; 
begin 
  if FKind = rckVertical then begin 
    width := 33 - FDiffw; 
    height := 51 - FDiffh; 
  end else begin 
    width := 51 - FDiffh; 
    height := 33 - FDiffw; 
  end; 
  for x := 0 to 1 do 
    zw(FBmp[x]); 
end; 
 
procedure TRockerx.Resize; 
begin 
  inherited; 
  Dimension; 
  Frect := rect(0, 0, width, height); 
end; 
 
procedure TRockerx.Paint; 
begin 
  with canvas do 
    draw(0, 0, FBmp[ord(FSwitch)]); 
end; 
 
procedure TRockerx.switching; 
begin 
  repaint; 
  if assigned(FEvent) then 
    FEvent(self, readchecked); 
end; 
 
procedure TRockerx.setswitch(s: TRckSwitch); 
begin 
  if s <> FSwitch then begin 
    FSwitch := s; 
    switching; 
  end; 
end; 
 
procedure TRockerx.buildonoff; 
var 
  x, w, h: integer; 
  procedure makelines(i: integer); 
  begin 
    with FBmp[x].canvas do begin 
      moveto(3, i); 
      lineto(w, i); 
      moveto(i, 3); 
      lineto(i, h); 
    end; 
  end; 
  procedure sdraw(cnv: TCanvas); 
  begin 
    with cnv do begin 
      SetStretchBltMode(handle, STRETCH_HALFTONE); 
      stretchdraw(rect(3, 3, w, h), FHlp); 
    end; 
  end; 
begin 
  if width = 0 then exit; 
  w := width - 3; 
  h := height - 3; 
  for x := 0 to 1 do 
    with FBmp[x], canvas do begin 
      FHlp.handle := LoadBitmap(HInstance, 'liox'); 
      draw(0, 0, FHlp); 
      horzflip(FHlp); 
      draw(w, 0, FHlp); 
      horzflip(FHlp); 
      vertflip(FHlp); 
      draw(0, h, FHlp); 
      FHlp.handle := LoadBitmap(HInstance, 'reux'); 
      draw(w, h, FHlp); 
      brush.color := clBlack; 
      fillrect(rect(w, 3, width, h)); 
      fillrect(rect(3, h, w, height)); 
      pen.color := clBlack; 
      makelines(2); 
      pen.color := $4C4C4C; 
      makelines(0); 
      pen.color := $ACACAC; 
      makelines(1); 
      transparent := true; 
    end; 
  if not enabled then FHlp.handle := LoadBitmap(HInstance, 'wgrx') else 
    FHlp.handle := LoadBitmap(HInstance, PChar(FOff)); 
  if FKind = rckHorizontal then rotate(FHlp); 
  sdraw(FBmp[0].canvas); 
  if not enabled then FHlp.handle := LoadBitmap(HInstance, 'wgrx') else 
    FHlp.handle := LoadBitmap(HInstance, PChar(FOn)); 
  if FKind = rckHorizontal then begin 
    rotate(FHlp); 
    horzflip(FHlp); 
  end else 
    vertflip(FHlp); 
  sdraw(FBmp[1].canvas); 
end; 
 
function TRockerx.onthat(x, y: integer): boolean; 
var 
  l, r, i: integer; 
  b, bf: boolean; 
  function prf(w: integer): boolean; 
  begin 
    result := not bf and (w < l) or bf and (w > r); 
  end; 
begin 
  b := FKind = rckVertical; 
  bf := FSwitch = rckOff; 
  if b then i := height div 2 
  else i := width div 2; 
  l := pred(i); 
  r := l + 2; 
  result := b and prf(y) or not b and prf(x); 
end; 
 
procedure TRockerx.MouseDown(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if FAlways or onthat(x, y) then begin 
    if FSwitch = rckOff then setswitch(rckOn) else setswitch(rckOff); 
    changecursor(x, y); 
  end; 
  inherited; 
end; 
 
procedure TRockerx.SetEnabled(Value: Boolean); 
begin 
  inherited; 
  buildonoff; 
end; 
 
procedure TRockerx.setFColorOn(f: TRckColor); 
begin 
  if f = FColorOn then exit; 
  FColorOn := f; 
  FOn := parse(f); 
  buildonoff; 
  repaint; 
end; 
 
procedure TRockerx.setFColorOff(f: TRckColor); 
begin 
  if f = FColorOff then exit; 
  FColorOff := f; 
  FOff := parse(f); 
  buildonoff; 
  repaint; 
end; 
 
procedure TRockerx.setkind(k: TRckKind); 
begin 
  if k = FKind then exit; 
  FKind := k; 
  arrange; 
  repaint; 
end; 
 
procedure TRockerx.changecursor(x, y: integer); 
begin 
  releasecapture; 
  if onthat(x, y) then cursor := FCursorD else cursor := FCursorN; 
end; 
 
procedure TRockerx.MouseMove(Shift: TShiftState; X, 
  Y: Integer); 
begin 
  changecursor(x, y); 
  inherited; 
end; 
 
procedure TRockerx.setcursord(c: TCursor); 
begin 
  FCursorD := c; 
end; 
 
procedure TRockerx.setcursorn(c: TCursor); 
begin 
  FCursorN := c; 
end; 
 
procedure TRockerx.setsize(s: TRckSize); 
begin 
  if s = FSize then exit; 
  FSize := s; 
  case s of 
    rckLarge: begin 
        FDiffw := 0; 
        FDiffh := 0; 
      end; 
    rckSmall: begin 
        FDiffw := 13; 
        FDiffh := 22; 
      end; 
  else begin 
      FDiffw := 7; 
      FDiffh := 12; 
    end; 
  end; 
  arrange; 
  repaint; 
end; 
 
procedure TRockerx.arrange; 
begin 
  Dimension; 
  buildonoff; 
end; 
 
procedure TRockerx.setAlways(b: boolean); 
begin 
  if b = FAlways then exit; 
  FAlways := b; 
  if b then begin 
    FCursorM := FCursorN; 
    FCursorN := FCursorD; 
  end else FCursorN := FCursorM; 
end; 
 
function TRockerx.readchecked: boolean; 
begin 
  result := FSwitch = rckOn; 
end; 
 
procedure TRockerx.writechecked(b: boolean); 
begin 
  if b then begin 
    if FSwitch = rckOn then exit; 
    setswitch(rckOn); 
  end else begin 
    if FSwitch = rckOff then exit; 
    setswitch(rckOff); 
  end; 
end; 
 
procedure TRockerx.loaded; 
begin 
  inherited; 
  if FOnStart then switching; 
end; 
 
function TRockerx.parse(f: TRckColor): string; 
begin 
  case f of 
    rckRed: result := 'wrtx'; 
    rckAqua: result := 'waqx'; 
    rckBlue: result := 'wblx'; 
    rckPink: result := 'wpkx'; 
    rckBrown: result := 'wbrx'; 
    rckGreen: result := 'wgnx'; 
    rckWhite: result := 'wwsx'; 
    rckBlack: result := 'wbkx'; 
    rckOrange: result := 'worx'; 
    rckYellow: result := 'wgbx'; 
  end; 
end; 
 
end.

// -----------------------------------------------------------------------

// 3. LED-Variante

// Diese Variante ist die Erweiterung von Variante 2. Zum Einen ist
// die Farbe rckMetal hinzugekommen, zum Anderen kann man bei Bedarf
// eine LED für den Schaltzustand ein- bzw. ausblenden. Das kann hilfreich
// sein, falls man für EIN und AUS die selbe Farbe für die Wippe einstellt.
// Die Eigenschaft LEDLeftTop legt fest, ob die LED oben oder unten, bzw.
// rechts oder links dargestellt wird. Für diese Variante müssen Sie
// hier wippl.zip downloaden und in das Verzeichnis der Komponente (Lib)
// entpacken.

unit RockerL; 
 
interface 
 
uses 
  Windows, 
  Classes, 
  Controls, 
  Graphics; 
 
type 
  TRckEvent = procedure(Sender: TObject; State: Boolean) of object; 
  TRckColor = (rckAqua, rckBlack, rckBlue, rckBrown, rckGreen, 
    rckMetal, rckOrange, rckPink, rckRed, rckWhite, rckYellow); 
  TRckSize = (rckLarge, rckNormal, rckSmall); 
  TRckKind = (rckHorizontal, rckVertical); 
  TRckSwitch = (rckOff, rckOn); 
 
  TRockerL = class(TGraphicControl) 
  private 
    FThreshold, FZL, FDiffw, FDiffh: integer; 
    Fleft, FLed, FAlways, FOnStart: Boolean; 
    FCursorD, FCursorN, FCursorM: TCursor; 
    FBmp, FLeds: array[0..1] of TBitmap; 
    FColorOn, FColorOff: TRckColor; 
    FSwitch: TRckSwitch; 
    FOff, FOn: string; 
    FEvent: TRckEvent; 
    FSize: TRckSize; 
    FKind: TRckKind; 
    FHlp: TBitmap; 
    FRect: TRect; 
  protected 
    procedure Paint; override; 
    procedure Loaded; override; 
    procedure Resize; override; 
    function onthat(x, y: integer): boolean; 
    procedure changecursor(x, y: integer); 
    function parse(f: TRckColor): string; 
    procedure setFColorOff(f: TRckColor); 
    procedure setFColorOn(f: TRckColor); 
    procedure writechecked(b: boolean); 
    procedure setswitch(s: TRckSwitch); 
    procedure VertFlip(bmp: TBitmap); 
    procedure HorzFlip(bmp: TBitmap); 
    procedure setcursord(c: TCursor); 
    procedure setcursorn(c: TCursor); 
    procedure setAlways(b: boolean); 
    procedure setkind(k: TRckKind); 
    procedure setsize(s: TRckSize); 
    function readchecked: boolean; 
    procedure Rotate(bm: TBitmap); 
    procedure makeled(b: boolean); 
    procedure setleft(b: boolean); 
    procedure buildonoff; 
    procedure switching; 
    procedure Dimension; 
    procedure arrange; 
  public 
    procedure MouseDown(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseMove(Shift: TShiftState; X, 
      Y: Integer); override; 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
    procedure SetEnabled(Value: Boolean); override; 
    property Checked: boolean read readchecked write writechecked; 
  published 
    property ColorOff: TRckColor read FColorOff write setFColorOff; 
    property CursorNormal: TCursor read FCursorN write setcursorn; 
    property CursorSwitch: TCursor read FCursorD write setcursord; 
    property AlwaysRespond: boolean read FAlways write setAlways; 
    property ColorOn: TRckColor read FColorOn write setFColorOn; 
    property EventOnLoad: boolean read FOnstart write FOnstart; 
    property Switch: TRckSwitch read FSwitch write setswitch; 
    property OnChange: TRckEvent read FEvent write FEvent; 
    property LEDLeftTop: boolean read Fleft write setleft; 
    property Size: TRckSize read FSize write setsize; 
    property Kind: TRckKind read FKind write setkind; 
    property LED: boolean read Fled write makeled; 
    property ParentShowHint; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnMouseUp; 
    property ShowHint; 
    property Visible; 
    property Enabled; 
  end; 
 
procedure Register; 
 
implementation 
 
{$R wippl.res} 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TRockerL]); 
end; 
 
constructor TRockerL.Create(Owner: TComponent); 
var 
  x: integer; 
begin 
  inherited Create(Owner); 
  for x := 0 to 1 do begin 
    FBmp[x] := TBitmap.create; 
    FBmp[x].pixelformat := pf24bit; 
    FLeds[x] := TBitmap.create; 
  end; 
  FLeft := true; 
  FCursorD := crHandpoint; 
  FHlp := TBitmap.create; 
  FKind := rckVertical; 
  FColorOff := rckMetal; 
  FColorOn := rckMetal; 
  FLed := true; 
  FOff := parse(FColorOff); 
  FOn := parse(FColorOn); 
  FCursorN := crArrow; 
  FCursorM := crArrow; 
  setsize(rckNormal); 
  FSwitch := rckOff; 
  FAlways := false; 
  arrange; 
end; 
 
destructor TRockerL.Destroy; 
var 
  x: integer; 
begin 
  for x := 0 to 1 do begin 
    FBmp[x].free; 
    FLeds[x].free; 
  end; 
  FHlp.free; 
  inherited Destroy; 
end; 
 
procedure TRockerL.HorzFlip(bmp: TBitmap); 
begin 
  stretchblt(bmp.canvas.handle, 0, 0, bmp.width, bmp.height, 
    bmp.canvas.handle, bmp.width - 1, 0, -bmp.width, bmp.height, SRCCOPY); 
end; 
 
procedure TRockerL.VertFlip(bmp: TBitmap); 
begin 
  stretchblt(bmp.canvas.handle, 0, 0, bmp.width, bmp.height, 
    bmp.canvas.handle, 0, bmp.height - 1, bmp.width, -bmp.height, SRCCOPY); 
end; 
 
procedure TRockerL.Rotate(bm: TBitmap); 
type 
  TripleArray = array[0..50] of TRGBTriple; 
  PTriple = ^TripleArray; 
var 
  p: PTriple; 
  x, y: integer; 
  bitmap: TBitmap; 
begin 
  bm.pixelformat := pf24bit; 
  bitmap := TBitmap.create; 
  bitmap.width := bm.height; 
  bitmap.height := bm.width; 
  bitmap.pixelformat := pf24bit; 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    for x := bm.width - 1 downto 0 do 
      PTriple(bitmap.scanline[pred(bm.width - x)])[y] := p[x]; 
  end; 
  bm.width := bitmap.width; 
  bm.height := bitmap.height; 
  bm.canvas.draw(0, 0, bitmap); 
  bitmap.free; 
  vertflip(bm); 
end; 
 
procedure TRockerL.Dimension; 
var 
  x: integer; 
  procedure zw(b: TBitmap); 
  begin 
    b.width := width; 
    b.height := height; 
  end; 
begin 
  if Fled then begin 
    case FSize of 
      rckLarge: Fzl := 25; 
      rckNormal: Fzl := 19; 
    else Fzl := 15; 
    end; 
  end else Fzl := 0; 
  if FKind = rckVertical then begin 
    width := 33 - FDiffw; 
    height := 51 - FDiffh + Fzl; 
  end else begin 
    width := 51 - FDiffh + Fzl; 
    height := 33 - FDiffw; 
  end; 
  for x := 0 to 1 do 
    zw(FBmp[x]); 
end; 
 
procedure TRockerL.Resize; 
begin 
  inherited; 
  Dimension; 
  Frect := rect(0, 0, width, height); 
end; 
 
procedure TRockerL.Paint; 
begin 
  with canvas do 
    draw(0, 0, FBmp[ord(FSwitch)]); 
end; 
 
procedure TRockerL.switching; 
begin 
  repaint; 
  if assigned(FEvent) then 
    FEvent(self, readchecked); 
end; 
 
procedure TRockerL.setswitch(s: TRckSwitch); 
begin 
  if s <> FSwitch then begin 
    FSwitch := s; 
    buildonoff; 
    switching; 
  end; 
end; 
 
procedure TRockerL.buildonoff; 
var 
  x, w, h: integer; 
  rt, gn: string; 
  procedure makelines(i: integer); 
  begin 
    with FBmp[x].canvas do begin 
      moveto(3, i); 
      lineto(w, i); 
      moveto(i, 3); 
      lineto(i, h); 
    end; 
  end; 
  procedure sdraw(cnv: TCanvas); 
  var 
    zwl, zwr, zso, zsu, li, ob, zw, dr, ll, lt: integer; 
  begin 
    if FKind = rckHorizontal then begin 
      if FLeft then begin 
        zwr := 0; 
        zwl := Fzl; 
        li := zwl + 2; 
        case FSize of 
          rckLarge: ll := 6; 
        else ll := 5; 
        end; 
      end else begin 
        zwr := Fzl; 
        zwl := 0; 
        li := w - zwr; 
        case FSize of 
          rckLarge: ll := 52; 
          rckNormal: ll := 39; 
        else ll := 29; 
        end; 
      end; 
      case FSize of 
        rckLarge: lt := 8; 
        rckNormal: lt := 6; 
      else lt := 5; 
      end; 
      zso := 0; 
      zsu := 0; 
      ob := 3; 
      zw := li; 
      dr := h; 
    end else begin 
      if Fleft then begin 
        zsu := 0; 
        zso := Fzl; 
        ob := zso + 2; 
        case FSize of 
          rckLarge: lt := 6; 
        else lt := 5; 
        end; 
      end else begin 
        zsu := Fzl; 
        zso := 0; 
        ob := h - zsu; 
        case FSize of 
          rckLarge: lt := 52; 
          rckNormal: lt := 39; 
        else lt := 29; 
        end; 
      end; 
      zw := w; 
      li := 3; 
      zwl := 0; 
      zwr := 0; 
      dr := ob; 
      case FSize of 
        rckLarge: ll := 8; 
        rckNormal: ll := 6; 
      else ll := 5; 
      end; 
    end; 
    with cnv do begin 
      SetStretchBltMode(handle, STRETCH_HALFTONE); 
      stretchdraw(rect(3 + zwl, 3 + zso, w - zwr, h - zsu), FHlp); 
      pen.color := clBlack; 
      moveto(li, ob); 
      lineto(zw, dr); 
      if not FLed then exit; 
      if FSwitch = rckOff then 
        draw(ll, lt, Fleds[0]) 
      else draw(ll, lt, Fleds[1]); 
    end; 
  end; 
begin 
  if width = 0 then exit; 
  w := width - 3; 
  h := height - 3; 
  if enabled then begin 
    rt := 'r'; 
    gn := 'g'; 
  end else begin 
    rt := 'e'; 
    gn := 'e'; 
  end; 
  case FSize of 
    rckLarge: begin 
        Fleds[0].handle := LoadBitmap(HInstance, PChar('l' + rt + 'gl')); 
        Fleds[1].handle := LoadBitmap(HInstance, PChar('l' + gn + 'gl')); 
      end; 
    rckNormal: begin 
        Fleds[0].handle := LoadBitmap(HInstance, PChar('l' + rt + 'nl')); 
        Fleds[1].handle := LoadBitmap(HInstance, PChar('l' + gn + 'nl')); 
      end; 
  else begin 
      Fleds[0].handle := LoadBitmap(HInstance, PChar('l' + rt + 'kl')); 
      Fleds[1].handle := LoadBitmap(HInstance, PChar('l' + gn + 'kl')); 
    end; 
  end; 
  for x := 0 to 1 do 
    with FBmp[x], canvas do begin 
      if FLed then begin 
        brush.color := $525252; 
        fillrect(cliprect); 
      end; 
      FHlp.handle := LoadBitmap(HInstance, 'liol'); 
      draw(0, 0, FHlp); 
      horzflip(FHlp); 
      draw(w, 0, FHlp); 
      horzflip(FHlp); 
      vertflip(FHlp); 
      draw(0, h, FHlp); 
      FHlp.handle := LoadBitmap(HInstance, 'reul'); 
      draw(w, h, FHlp); 
      brush.color := clBlack; 
      fillrect(rect(width - 3, 3, width, h)); 
      fillrect(rect(3, h, w, height)); 
      pen.color := clBlack; 
      makelines(2); 
      pen.color := $4C4C4C; 
      makelines(0); 
      pen.color := $ACACAC; 
      makelines(1); 
      transparent := true; 
    end; 
  if not enabled then FHlp.handle := LoadBitmap(HInstance, 'wgrl') else 
    FHlp.handle := LoadBitmap(HInstance, PChar(FOff)); 
  if FKind = rckHorizontal then rotate(FHlp); 
  sdraw(FBmp[0].canvas); 
  if not enabled then FHlp.handle := LoadBitmap(HInstance, 'wgrl') else 
    FHlp.handle := LoadBitmap(HInstance, PChar(FOn)); 
  if FKind = rckHorizontal then begin 
    rotate(FHlp); 
    horzflip(FHlp); 
    FThreshold := (width - Fzl) div 2; 
  end else begin 
    vertflip(FHlp); 
    FThreshold := (height - fzl) div 2; 
  end; 
  sdraw(FBmp[1].canvas); 
end; 
 
function TRockerL.onthat(x, y: integer): boolean; 
var 
  l, i, j: integer; 
  b, bf: boolean; 
  function prf(w, v: integer): boolean; 
  begin 
    result := (not bf and (w < l) and (w >= i + 5)) 
      or (bf and (w > l) and (w <= v - j)); 
  end; 
begin 
  b := FKind = rckVertical; 
  bf := FSwitch = rckOff; 
  i := Fzl * ord(FLeft); 
  j := Fzl * ord(not FLeft) + 5; 
  l := FThreshold + i; 
  result := b and prf(y, height) or not b and prf(x, width); 
end; 
 
procedure TRockerL.MouseDown(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if FAlways or onthat(x, y) then begin 
    if FSwitch = rckOff then setswitch(rckOn) else setswitch(rckOff); 
    changecursor(x, y); 
  end; 
  inherited; 
end; 
 
procedure TRockerL.SetEnabled(Value: Boolean); 
begin 
  inherited; 
  buildonoff; 
end; 
 
procedure TRockerL.setFColorOn(f: TRckColor); 
begin 
  if f = FColorOn then exit; 
  FColorOn := f; 
  FOn := parse(f); 
  buildonoff; 
  repaint; 
end; 
 
procedure TRockerL.setFColorOff(f: TRckColor); 
begin 
  if f = FColorOff then exit; 
  FColorOff := f; 
  FOff := parse(f); 
  buildonoff; 
  repaint; 
end; 
 
procedure TRockerL.setkind(k: TRckKind); 
begin 
  if k = FKind then exit; 
  FKind := k; 
  arrange; 
  repaint; 
end; 
 
procedure TRockerL.changecursor(x, y: integer); 
begin 
  releasecapture; 
  if onthat(x, y) then cursor := FCursorD else cursor := FCursorN; 
end; 
 
procedure TRockerL.MouseMove(Shift: TShiftState; X, 
  Y: Integer); 
begin 
  changecursor(x, y); 
  inherited; 
end; 
 
procedure TRockerL.setcursord(c: TCursor); 
begin 
  FCursorD := c; 
end; 
 
procedure TRockerL.setcursorn(c: TCursor); 
begin 
  FCursorN := c; 
end; 
 
procedure TRockerL.setsize(s: TRckSize); 
begin 
  if s = FSize then exit; 
  FSize := s; 
  case s of 
    rckLarge: begin 
        FDiffw := 0; 
        FDiffh := 0; 
      end; 
    rckSmall: begin 
        FDiffw := 13; 
        FDiffh := 22; 
      end; 
  else begin 
      FDiffw := 7; 
      FDiffh := 12; 
    end; 
  end; 
  arrange; 
  repaint; 
end; 
 
procedure TRockerL.arrange; 
begin 
  Dimension; 
  buildonoff; 
end; 
 
procedure TRockerL.setAlways(b: boolean); 
begin 
  if b = FAlways then exit; 
  FAlways := b; 
  if b then begin 
    FCursorM := FCursorN; 
    FCursorN := FCursorD; 
  end else FCursorN := FCursorM; 
end; 
 
function TRockerL.readchecked: boolean; 
begin 
  result := FSwitch = rckOn; 
end; 
 
procedure TRockerL.writechecked(b: boolean); 
begin 
  if b then begin 
    if FSwitch = rckOn then exit; 
    setswitch(rckOn); 
  end else begin 
    if FSwitch = rckOff then exit; 
    setswitch(rckOff); 
  end; 
end; 
 
procedure TRockerL.loaded; 
begin 
  inherited; 
  if FOnStart then switching; 
end; 
 
function TRockerL.parse(f: TRckColor): string; 
begin 
  case f of 
    rckRed: result := 'wrtl'; 
    rckAqua: result := 'waql'; 
    rckBlue: result := 'wbll'; 
    rckPink: result := 'wpkl'; 
    rckBrown: result := 'wbrl'; 
    rckGreen: result := 'wgnl'; 
    rckWhite: result := 'wwsl'; 
    rckBlack: result := 'wbkl'; 
    rckMetal: result := 'wmtl'; 
    rckOrange: result := 'worl'; 
    rckYellow: result := 'wgbl'; 
  end; 
end; 
 
procedure TRockerL.makeled(b: boolean); 
begin 
  if FLed = b then exit; 
  FLed := b; 
  arrange; 
  repaint; 
end; 
 
procedure TRockerL.setleft(b: boolean); 
begin 
  if FLeft = b then exit; 
  FLeft := b; 
  arrange; 
  repaint; 
end; 
 
end.

// -----------------------------------------------------------------------

// Wie man mit einem String (im Beispiel "ButtonState" genannt), der nur
// Nullen und Einsen enthält, eine Schalterreihe ansteuert, zeigt das
// Beispiel, bei welchem für 1 Byte die Dual- <---> Dezimaldarstellung
// angezeigt wird.

Beispiel-Download