abtank.pas

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

unit AbTank;

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

{$I abks.inc}

interface

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

type

  TTankOption = (opUseSectorColors, opValue, opUnit);
  TTankOptions = set of TTankOption;

  TTankStyle = (tsHorizontal, tsVertical, tsEllipse, tsRoundRect, tsCrater,
    tsRectangle);

  TTankSettings = class(TPersistent)
  private
    FStyle: TTankStyle;
    FCraterWidth: Smallint;
    FBkColor: TColor;
    FColor: TColor;
    FOnChange: TNotifyEvent;            // with "Full" redraw
    FOnChange2: TNotifyEvent;           // without "Full" redraw
    FPenWidth: Smallint;
    FPenColor: TColor;
  protected
    procedure SetStyle(Value: TTankStyle);
    procedure SetCraterWidth(Value: Smallint);
    procedure SetBkColor(Value: TColor);
    procedure SetColor(Value: TColor);
    procedure SetPenWidth(Value: Smallint);
    procedure SetPenColor(Value: TColor);
    procedure Change(Sender: TObject);
    procedure Change2(Sender: TObject);
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Style: TTankStyle read FStyle write SetStyle;
    property CraterWidth: Smallint read FCraterWidth write SetCraterWidth;
    property BkColor: TColor read FBkColor write SetBkColor;
    property Color: TColor read FColor write SetColor;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChange2: TNotifyEvent read FOnChange2 write FOnChange2;
    property PenWidth: Smallint read FPenWidth write SetPenWidth;
    property PenColor: TColor read FPenColor write SetPenColor;
  end;



  TAbTank = class(TAbAnalogGControl)
  private
    FTankSettings: TTankSettings;
    FBevelValue: TAbSBevel;
    FFontUnitCol: TColor;
    FOptions: TTankOptions;
    FPPH : Single;                      {percentage of "Value", shown in PPHColor}
    FPPHColor : TColor;
    ClipRgn: HRgn;                      {Tank Clipbereich}
    r1: Smallint;
    r2: Smallint;                       {Tank Radius}
    PixPerPPT: Single;                  {h鰄e / 1000}
    crater: array[1..6] of TPoint;
    FirstDraw: Boolean;
    FVIndOffsX: Integer;
    FVIndOffsY: Integer;
    rValue: TRect;
    sValue: TSize;                      // Size of Value string
    sUnit: TSize;                       // Size of  Unit string

    pPos: TPoint;                       // to detect scrolling
  protected
    procedure Paint; override;
    procedure ValueChange; override;
    procedure ParamChange(Sender: TObject); override;
    procedure Change2(Sender: TObject);
    procedure SetOptions(Value: TTankOptions);
    procedure SetFontUnitCol(Value: TColor);
    procedure SetVIndOffsX(Value: Integer);
    procedure SetVIndOffsY(Value: Integer);
    procedure SetPPH(Value : Single);
    procedure SetPPHColor(Value : TColor);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    property LogScale;
    property Visible;
    property PPH : Single read FPPH write SetPPH;
    property PPHColor : TColor read FPPHColor write SetPPHColor;
    property BevelValue: TAbSBevel read FBevelValue write FBevelValue;
    property TankSettings: TTankSettings read FTankSettings write FTankSettings;
    property Options: TTankOptions read FOptions write SetOptions;
    property FontUnitCol: TColor read FFontUnitCol write SetFontUnitCol;
    property VIndOffsX: Integer read FVIndOffsX write SetVIndOffsX;
    property VIndOffsY: Integer read FVIndOffsY write SetVIndOffsY;
    property Font;
  end;

implementation



{ TTankSettings }
{==============================================================================}

constructor TTankSettings.Create;
begin
  inherited Create;
  FBkColor := clBtnShadow;
  FColor := clLime;
  FCraterWidth := 20;
  FPenWidth := 2;

end;

destructor TTankSettings.Destroy;
begin
  inherited Destroy;
end;

procedure TTankSettings.SetStyle(Value: TTankStyle);
begin
  FStyle := Value;
  Change(self);
end;

procedure TTankSettings.SetCraterWidth(Value: Smallint);
begin
  if (Value > 0) and (Value < 51) then FCraterWidth := Value;
  Change(self);
end;

procedure TTankSettings.SetBkColor(Value: TColor);
begin
  FBkColor := Value;
  Change2(self);
end;

procedure TTankSettings.SetColor(Value: TColor);
begin
  FColor := Value;
  Change2(self);
end;

procedure TTankSettings.SetPenWidth(Value: Smallint);
begin
  if (Value >= 0) and (Value < 11) then FPenWidth := Value;
  Change2(self);
end;

procedure TTankSettings.SetPenColor(Value: TColor);
begin
  FPenColor := Value;
  Change2(self);
end;

procedure TTankSettings.Change(Sender: TObject);
begin
  if Assigned(FOnChange) then FOnChange(self);
end;

procedure TTankSettings.Change2(Sender: TObject);
begin
  if Assigned(FOnChange2) then FOnChange2(self);
end;

{ TAbTank }
{==============================================================================}

constructor TAbTank.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  BeginUpdate;
  FirstDraw := true;

  FTankSettings := TTankSettings.Create;

  FBevelValue := TAbSBevel.Create;
  FBevelValue.Style := bsLowered;
  FBevelValue.Width := 2;
  FBevelValue.Spacing := 0;
  FBevelValue.Color := clBtnShadow;
  FBevelValue.ColorShadowFrom := clBlack;
  FBevelValue.ColorShadowTo := clBlack;
  FBevelValue.ColorHighLightFrom := clBtnFace;
  FBevelValue.ColorHighLightTo := clBtnFace;

  FOptions := [opValue, opUnit];

  Font.Color := clBtnHighlight;
  Font.Name := 'System';
  Font.Size := 10;

  FFontUnitCol := clWhite;

  FPPHColor := clAqua;
  FPPH := 0;

  SetBounds(Left, Top, 164, 81);
  pPos := Point(Left, Top);
  if (csDesigning in Componentstate) then Loaded;

end;

procedure TAbTank.Loaded;
begin
  inherited Loaded;
  Font.OnChange := Change2;
  FTankSettings.OnChange := ParamChange;
  FTankSettings.OnChange2 := Change2;

  FBevelValue.OnChange := Change2;
  EndUpdate;

end;

procedure TAbTank.SetPPH(Value : Single);
begin
  if FPPH <> Value then begin
     if (Value >= 0) and (Value <= 100) then begin
        FPPH := Value;
        ValueChange;
     end;
  end;
end;

procedure TAbTank.SetPPHColor(Value : TColor);
begin
  if FPPHColor <> Value then begin
    FPPHColor := Value;
    ValueChange;
  end;
end;


procedure TAbTank.SetVIndOffsX(Value: Integer);
begin
  if FVIndOffsX <> Value then
  begin
    FVIndOffsX := Value;
    ValueChange;
  end;
end;

procedure TAbTank.SetVIndOffsY(Value: Integer);
begin
  if FVIndOffsY <> Value then
  begin
    FVIndOffsY := Value;