abswitch.pas

著名的虚拟仪表控件,包含全部源码, 可以在,delphi2007 下安装运行

  inherited Destroy;
end;

procedure TAbSwitch.SetOrientation(Value: TBtnOrientation);
var
  Max, Min          : Integer;
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    Max := AbMaxInt(Width, Height);
    Min := AbMinInt(Width, Height);
    if FOrientation = boVertical then
    begin
      SetBounds(Left, Top, Min, Max);
      vertical := true;
    end
    else
    begin
      SetBounds(Left, Top, Max, Min);
      vertical := false;
    end;
    ParamChange(self);
  end;
end;

{XXXXXXX TAbRockerSwitch XXXXXXXXXXXX}


procedure TAbRockerSwitch.Paint;
begin
  inherited Paint;
end;

constructor TAbRockerSwitch.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(Left, Top, 33, 81);
  FLEDColorOn := clLime;
  FLEDColorOff := clGreen;
  FBtnBevel2Width := 3;
  FBtnColorFaceHi := RGB(221, 221, 221);
  FBtnColorFaceSh := clBtnFace + (clBtnShadow - clBtnFace) div 4;
  FLEDHeight := 8;
end;

destructor TAbRockerSwitch.Destroy;
begin
  inherited Destroy;
end;

procedure TAbRockerSwitch.SetBtnBevel2Width(Value: Integer);
begin
  if (FBtnBevel2Width <> Value) and (Value >= 0) then
  begin
    FBtnBevel2Width := Value;
    StatusChanged;
  end;
end;

procedure TAbRockerSwitch.SetLedHeight(Value: Integer);
begin
  if (FLEDHeight <> Value) and (Value >= 0) then
  begin
    FLEDHeight := Value;
    StatusChanged;
  end;
end;


procedure TAbRockerSwitch.SetBtnColorFaceHi(Value: TColor);
begin
  if FBtnColorFaceHi <> Value then
  begin
    FBtnColorFaceHi := Value;
    StatusChanged;
  end;
end;

procedure TAbRockerSwitch.SetBtnColorFaceSh(Value: TColor);
begin
  if FBtnColorFaceSh <> Value then
  begin
    FBtnColorFaceSh := Value;
    StatusChanged;
  end;
end;

procedure TAbRockerSwitch.SetLEDColorOn(Value: TColor);
begin
  if FLEDColorOn <> Value then
  begin
    FLEDColorOn := Value;
    StatusChanged;
  end;
end;

procedure TAbRockerSwitch.SetLEDColorOff(Value: TColor);
begin
  if FLEDColorOff <> Value then
  begin
    FLEDColorOff := Value;
    StatusChanged;
  end;
end;


procedure TAbRockerSwitch.DrawSwitch(can: TCanvas; r: TRect; TopLeft, vertical:
  Boolean);
var
  ba1               : array[0..3] of TPoint;
  ba2               : array[0..3] of TPoint;
  ba3               : array[0..6] of TPoint;
  ba4               : array[0..6] of TPoint;

  Col1, Col2, col3, col4, col5: TColor;

  Center            : Integer;

  bw1, bw2          : Integer;          { bevelWidth }
  rLED              : TRect;
begin

  Col1 := FBtnColorHighlight;
  col3 := FBtnColorFace;
  col5 := FBtnColorShadow;
  Col2 := FBtnColorFaceHi;
  col4 := FBtnColorFaceSh;

  Dec(r.Right);
  Dec(r.Bottom);

  if vertical then
    Center := r.Top + (r.Bottom - r.Top) div 2
  else
    Center := r.Left + (r.Right - r.Left) div 2;

  bw1 := FBtnBevelWidth;
  bw2 := FBtnBevel2Width;

  ba3[0] := r.TopLeft;
  ba3[1].x := r.Right;
  ba3[1].y := ba3[0].y;
  ba3[6].x := ba3[0].x;
  ba3[6].y := r.Bottom;

  ba4[1] := ba3[1];
  ba4[2] := r.BottomRight;
  ba4[3] := ba3[6];

  if vertical then
  begin
    ba3[4].x := r.Left + bw1;
    ba3[4].y := Center;

    ba4[6].x := r.Right - bw1;
    ba4[6].y := Center;

    if TopLeft then
    begin
      ba3[2].x := r.Right - bw1;
      ba3[2].y := r.Top + bw1;
      ba3[3].x := r.Left + bw1;
      ba3[3].y := ba3[2].y;
      ba3[5].x := r.Left + bw1 + bw2;
      ba3[5].y := r.Bottom - bw1 - bw2;

      ba4[0] := ba3[2];
      ba4[4] := ba3[5];
      ba4[5].x := r.Right - bw1 - bw2;
      ba4[5].y := ba4[4].y;
    end
    else
    begin
      ba3[2].x := r.Right - bw1 - bw2;
      ba3[2].y := r.Top + bw1 + bw2;
      ba3[3].x := r.Left + bw1 + bw2;
      ba3[3].y := ba3[2].y;
      ba3[5].x := r.Left + bw1;
      ba3[5].y := r.Bottom - bw1;

      ba4[0] := ba3[2];
      ba4[4] := ba3[5];
      ba4[5].x := r.Right - bw1;
      ba4[5].y := ba4[4].y;
    end;
    ba1[0] := ba3[3];
    ba1[1] := ba3[2];
    ba1[2] := ba4[6];
    ba1[3] := ba3[4];

    ba2[0] := ba1[3];
    ba2[1] := ba1[2];
    ba2[2] := ba4[5];
    ba2[3] := ba4[4];

  end
  else
  begin
    ba3[3].x := Center;
    ba3[3].y := ba3[0].y + bw1;

    ba4[5].x := Center;
    ba4[5].y := r.Bottom - bw1;

    if TopLeft then
    begin
      ba3[2].x := r.Right - bw1 - bw2;
      ba3[2].y := r.Top + bw1 + bw2;
      ba3[4].x := r.Left + bw1;
      ba3[4].y := ba3[3].y;
      ba3[5].x := ba3[4].x;
      ba3[5].y := r.Bottom - bw1;

      ba4[0] := ba3[2];
      ba4[4] := ba3[5];
      ba4[6].x := r.Right - bw1 - bw2;
      ba4[6].y := r.Bottom - bw1 - bw2;
    end
    else
    begin
      ba3[2].x := r.Right - bw1;
      ba3[2].y := r.Top + bw1;
      ba3[4].x := r.Left + bw1 + bw2;
      ba3[4].y := ba3[3].y + bw2;
      ba3[5].x := ba3[4].x;
      ba3[5].y := r.Bottom - bw1 - bw2;

      ba4[0] := ba3[2];
      ba4[4] := ba3[5];
      ba4[6].x := r.Right - bw1;
      ba4[6].y := r.Bottom - bw1;
    end;

    ba1[0] := ba3[4];
    ba1[1] := ba3[3];
    ba1[2] := ba4[5];
    ba1[3] := ba3[5];

    ba2[0] := ba3[3];
    ba2[1] := ba3[2];
    ba2[2] := ba4[6];
    ba2[3] := ba4[5];
  end;

  can.Brush.Color := Col1;
  can.Pen.Color := Col1;
  can.Polygon(ba3);
  can.Brush.Color := col5;
  can.Pen.Color := col5;
  can.Polygon(ba4);

  if TopLeft then
  begin

    can.Brush.Color := Col2;
    can.Pen.Color := Col2;
    can.Polygon(ba2);
    can.Brush.Color := col3;
    can.Pen.Color := col3;
    can.Polygon(ba1);

  end
  else
  begin
    can.Brush.Color := col3;
    can.Pen.Color := col3;
    can.Polygon(ba2);
    can.Brush.Color := col4;
    can.Pen.Color := col4;
    can.Polygon(ba1);
  end;

  if FLEDHeight = 0 then Exit;
  if vertical then
  begin
    if SwapGraphic then
    begin
      rLED := Rect(ba2[3].x + bw1,
        ba2[3].y - bw1 - FLEDHeight,
        ba2[2].x - bw1 + 1,
        ba2[3].y - bw1 + 1);
    end
    else
    begin
      rLED := Rect(ba1[0].x + bw1,
        ba1[0].y + bw1,
        ba1[1].x - bw1,
        ba1[0].y + FLEDHeight + bw1);
    end;

  end
  else
  begin
    if SwapGraphic then
    begin
      rLED := Rect(ba2[1].x - bw1 - FLEDHeight,
        ba2[1].y + bw1,
        ba2[2].x - bw1 + 1,
        ba2[2].y - bw1 + 1);
    end
    else
    begin
      rLED := Rect(ba1[0].x + bw1,
        ba1[0].y + bw1,
        ba1[3].x + bw1 + FLEDHeight,
        ba1[3].y - bw1);
    end;

  end;
  if Checked then
    can.Brush.Color := FLEDColorOn
  else
    can.Brush.Color := FLEDColorOff;

  can.Rectangle(rLED.Left, rLED.Top, rLED.Right, rLED.Bottom);
  Frame3D(can, rLED, FBtnColorShadow, FBtnColorHighlight, 1);

end;


{XXXXXXX TAbToggleSwitch XXXXXXXXXXXX}

constructor TAbToggleSwitch.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(Left, Top, 25, 57);
  ColorOff := clRed;
  FTextOff := '0';
  FTextOn := '1';
  FColorOn := clLime;
  FColorOff := clRed;
end;

destructor TAbToggleSwitch.Destroy;
begin
  inherited Destroy;
end;

procedure TAbToggleSwitch.Paint;
begin
  inherited Paint;
end;

procedure TAbToggleSwitch.SetTextOff(Value: string);
begin
  if FTextOff <> Value then
  begin
    FTextOff := Value;
    ParamChange(self);
  end;
end;

procedure TAbToggleSwitch.SetTextOn(Value: string);
begin
  if FTextOn <> Value then
  begin
    FTextOn := Value;
    ParamChange(self);
  end;
end;

procedure TAbToggleSwitch.SetColorOn(Value: TColor);
begin
  if FColorOn <> Value then
  begin
    FColorOn := Value;
    ParamChange(self);
  end;
end;

procedure TAbToggleSwitch.SetColorOff(Value: TColor);
begin
  if FColorOff <> Value then
  begin
    FColorOff := Value;
    ParamChange(self);
  end;
end;

procedure TAbToggleSwitch.DrawSwitch(can: TCanvas; r: TRect; TopLeft, vertical:
  Boolean);
var
  br                : TRect;
  Col1, Col2, col3, col4: TColor;
  bw1               : Integer;          { bevelWidth }
  n                 : Integer;
  State             : Boolean;
  txt               : string;
begin
  Col2 := FBtnColorFace;                { button color }
  col3 := FBtnColorHighlight;           { button bevel + structure color 1 }
  col4 := FBtnColorShadow;              { button bevel + structure color 2  }
  if Checked then
  begin
    Col1 := FColorOn;
    txt := FTextOn;
  end
  else
  begin
    Col1 := FColorOff;
    txt := FTextOff;
  end;

  if FSwapGraphic then
    State := not Checked
  else
    State := Checked;

  TopLeft := State;

  bw1 := FBtnBevelWidth;

  br := r;
  if vertical then
  begin
    if TopLeft then
      br.Bottom := r.Top + (r.Bottom - r.Top) div 2
    else
      br.Top := r.Top + (r.Bottom - r.Top) div 2;
  end
  else
  begin
    if TopLeft then
      br.Right := r.Left + (r.Right - r.Left) div 2
    else
      br.Left := r.Left + (r.Right - r.Left) div 2;
  end;

  can.Brush.Color := Col1;
  can.Pen.Color := Col1;
  can.Rectangle(r.Left, r.Top, r.Right, r.Bottom);

  can.Brush.Color := Col2;
  can.Pen.Color := clBlack;
  can.Rectangle(br.Left, br.Top, br.Right, br.Bottom);
  AbBorder(br, 1);
  Frame3D(can, br, col3, col4, bw1);

  if vertical then
  begin
    n := br.Top + 2;
    while n < br.Bottom - 2 do
    begin
      can.Pen.Color := col3;
      can.moveTo(br.Left + 1, n);
      can.LineTo(br.Right - 2, n);
      can.Pen.Color := col4;
      can.moveTo(br.Left + 1, n + 1);
      can.LineTo(br.Right - 2, n + 1);
      n := n + 4;
    end;
  end
  else
  begin
    n := br.Left + 2;
    while n < br.Right - 2 do
    begin
      can.Pen.Color := col4;
      can.moveTo(n, br.Top + 2);
      can.LineTo(n, br.Bottom - 2);
      can.Pen.Color := col3;
      can.moveTo(n + 1, br.Top + 2);
      can.LineTo(n + 1, br.Bottom - 2);
      n := n + 4;
    end;
  end;

  can.Brush.Style := bsClear;
  can.Font := Font;

  if vertical then
  begin
    if TopLeft then
    begin
      AbTextOut(can,
        r.Left + (r.Right - r.Left) div 2,
        r.Bottom - (r.Bottom - r.Top) div 4,
        txt,
        toMidCenter);
    end
    else
    begin
      AbTextOut(can,
        r.Left + (r.Right - r.Left) div 2,
        r.Top + (r.Bottom - r.Top) div 4,
        txt,
        toMidCenter);
    end;
  end
  else
  begin
    if TopLeft then
    begin
      AbTextOut(can,
        r.Right - (r.Right - r.Left) div 4,
        r.Top + (r.Bottom - r.Top) div 2,
        txt,
        toMidCenter);
    end
    else
    begin
      AbTextOut(can,
        r.Left + (r.Right - r.Left) div 4,
        r.Top + (r.Bottom - r.Top) div 2,
        txt,
        toMidCenter);
    end;
  end;

end;


end.