abbar.pas

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

unit AbBar;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                              Component TAbBar                                }
{                                                                              }
{******************************************************************************}
{        e-Mail: [e-mail] , Web: http://www.abaecker.com            }
{------------------------------------------------------------------------------}
{          (c) Copyright 1998..2000 A.Baecker, All rights Reserved             }
{******************************************************************************}

interface

{$I abks.inc}

uses
  Windows,
  Classes,
  Graphics,
  Controls,
  extctrls,
  {****** Abakus VCL - Units ******}
  _AbInfo,
  _GClass;

type

  TAbBar = class(TAbAnalogGControl)
  private
    FBarSettings: TBarSettings;
    FBevelOuter: TAbSBevel;
  protected
    procedure Paint; override;
    procedure ValueChange; override;
    procedure ParamChange(Sender: TObject); override;
    procedure DrawHSector(can: TCanvas; rSector: TRect);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    property Align;
    property LogScale;
    property BarSettings: TBarSettings read FBarSettings write FBarSettings;
    property BevelOuter: TAbSBevel read FBevelOuter write FBevelOuter;
  end;

implementation

destructor TAbBar.Destroy;
begin
  FBevelOuter.Free;
  FBarSettings.Free;
  inherited Destroy;
end;

constructor TAbBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  BeginUpdate;
  Height := 28;
  Width := 164;

  FBevelOuter := TAbSBevel.Create;
  FBevelOuter.Spacing := 5;
  FBevelOuter.Width := 2;

  FBarSettings := TBarSettings.Create;
  FBarSettings.minWidth := 25;
  FBarSettings.minHeight := 12;
  FBarSettings.Options := [opValue, opUnit];

  if (csDesigning in Componentstate) then Loaded;

end;

procedure TAbBar.Loaded;
begin
  inherited Loaded;
  FBevelOuter.OnChange := ParamChange;
  FBarSettings.OnChange := ParamChange;
  EndUpdate;
end;


procedure TAbBar.DrawHSector(can: TCanvas; rSector: TRect);
var
  w, x1, x2         : Smallint;
  PPP               : Single;           {PixPerPPT}
begin
  w := rSector.Right - rSector.Left;
  PPP := w / 1000;

  can.Brush.Style := bsSolid;
  can.Brush.Color := SectorSettings.Sector1Color;
  can.Pen.Color := SectorSettings.Sector1Color;

  x1 := Round(PPP * SectorSettings.Sector1From);
  x2 := Round(PPP * SectorSettings.Sector1To);
  can.Rectangle(rSector.Left + x1, rSector.Top, rSector.Left + x2,
    rSector.Bottom);
  can.Brush.Color := SectorSettings.Sector2Color;
  can.Pen.Color := SectorSettings.Sector2Color;
  x1 := Round(PPP * SectorSettings.Sector2From);
  x2 := Round(PPP * SectorSettings.Sector2To);
  can.Rectangle(rSector.Left + x1, rSector.Top, rSector.Left + x2,
    rSector.Bottom);
  can.Brush.Color := SectorSettings.Sector3Color;
  can.Pen.Color := SectorSettings.Sector3Color;
  x1 := Round(PPP * SectorSettings.Sector3From);
  x2 := Round(PPP * SectorSettings.Sector3To);
  can.Rectangle(rSector.Left + x1, rSector.Top, rSector.Left + x2,
    rSector.Bottom);

end;

procedure TAbBar.Paint;
var
  r                 : TRect;
  w                 : Smallint;
  min_h, min_w      : Smallint;

  procedure GetMin(var Min: Smallint; Value: Smallint);
  begin
    if Min < Value then Min := Value;
  end;

begin
  if (UpdateCount <> 0) then Exit;
  BarSettings.ValueUnit := SignalSettings.ValueUnit;

  min_h := BarSettings.Bevel.TotalWidth * 2
    + BevelOuter.TotalWidth * 2
    + BarSettings.minHeight;
  w := BevelOuter.TotalWidth * 2 + BarSettings.minWidth;
  min_w := w;

  if ((Width < min_w) or (Height < min_h)) then
  begin
    if Width < min_w then
    begin
      Width := min_w;
    end;
    if Height < min_h then
    begin
      Height := min_h;
    end;
  end;

  r := ClientRect;

  FBevelOuter.PaintFilledBevel(Canvas, r);

  FBarSettings.Bevel.PaintFilledBevel(Canvas, r);

  FBarSettings.BarRect := r;

  ValueChange;
end;

procedure TAbBar.ValueChange;
begin
  inherited ValueChange;

  if not Visible then Exit;
  BarSettings.Value := ValueStr;

  if (opUseSectorCol in FBarSettings.Options)
    and (InSector1 or InSector2 or InSector3) then
    FBarSettings.SectorCol := ActSectorCol
  else
    FBarSettings.SectorCol := FBarSettings.Color;
  FBarSettings.PaintBar(Canvas, PPT);

end;

procedure TAbBar.ParamChange(Sender: TObject);
begin
  inherited ParamChange(Sender);
  if Assigned(BarSettings) then BarSettings.ppt0 := SignalSettings.GetPPT(0);
  Invalidate;
end;

end.