abhmeter.pas

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

unit AbHMeter;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                            Component TAbHMeter                               }
{                                                                              }
{******************************************************************************}
{        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,
  Messages,
  SysUtils,
  {****** Abakus VCL - Units ******}
  AbFlashT,
  _GClass,
  _AbInfo,
  _AbProc;

type
  THMeterOption = (opBevelInner, opBevelOuter, opUnit, opName1, opName2,
    opOverflow, opLimit, opSector);
  THMeterOptions = set of THMeterOption;

  TAbHMeter = class(TAbAnalogGControl)
  private
    FAutoSize: Boolean;
    FBevelInner: TAbSBevel;
    FBevelOuter: TAbSBevel;
    FFontUnit: TFont;
    FScaleSettings: TScaleSettings;
    FOptions: THMeterOptions;
    isToSmall : Boolean;
    BmpBuffer: TBitmap;
    sName1: TSize;
    sName2: TSize;
    sValue: TSize;
    sUnit: TSize;
    rPointer: TRect;
    rScale: TRect;
    rBuffer: TRect;                     // rect of the inner meter
    zeiger: array[0..2] of TPoint;
    Zeiger2: array[0..2] of TPoint;
    minPointer: array[0..2] of TPoint;  // pointer for min values
    maxPointer: array[0..2] of TPoint;  // pointer for max values
    AltPosPointer: Smallint;
    min_h: Smallint;
    min_w: Smallint;
    Flashing: Boolean;
    FlashColor: TColor;

  protected
    procedure PointerFlash;
    procedure Paint; override;
    procedure ValueChange; override;
    procedure LogScaleChanged; override;
    procedure ParamChange(Sender: TObject); override;
    procedure OverflowChange(PPT: Integer); override;
    procedure LimitChange; override;
    procedure SetAbAutoSize(Value: Boolean);
    procedure SetOptions(Value: THMeterOptions);
    procedure SetFontUnit(Value: TFont);
    procedure DrawHSector(can: TCanvas; rSector: TRect);
    procedure DrawPointer(can: TCanvas);
    procedure CalcSize;
    procedure WMFlash(var Message: TMessage); message WM_FLASH;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    property Font;
    property Visible;
    property LogScale;
    property AutoSize: Boolean read FAutoSize write SetAbAutoSize;
    property FontUnit: TFont read FFontUnit write SetFontUnit;
    property BevelInner: TAbSBevel read FBevelInner write FBevelInner;
    property BevelOuter: TAbSBevel read FBevelOuter write FBevelOuter;
    property Options: THMeterOptions read FOptions write SetOptions;
    property ScaleSettings: TScaleSettings read FScaleSettings write
    FScaleSettings;
  end;

implementation


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

  Height := 118;
  Width := 263;
  isToSmall := false;

  FAutoSize := true;

  FFontUnit := TFont.Create;
  FFontUnit.Color := clBlack;
  FFontUnit.Name := 'System';
  FFontUnit.Size := 10;

  FBevelInner := TAbSBevel.Create;
  FBevelInner.Style := bsLowered;
  FBevelInner.Spacing := 5;
  FBevelInner.Width := 2;
  FBevelInner.BevelLine := blInner;

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

  FOptions := [opBevelInner, opBevelOuter, opUnit, opOverflow, opLimit, opName1,
    opName2, opSector];

  FScaleSettings := TScaleSettings.Create;

  BmpBuffer := TBitmap.Create;
  BmpBuffer.Height := 1;
  BmpBuffer.Width := 1;

  Flashing := false;
  FlashColor := clRed;

  if (csDesigning in Componentstate) then Loaded;
end;

procedure TAbHMeter.Loaded;
begin
  inherited Loaded;
  FFontUnit.OnChange := ParamChange;

  FBevelInner.OnChange := ParamChange;

  FBevelOuter.OnChange := ParamChange;

  FScaleSettings.OnChange := ParamChange;
  EndUpdate;
end;

destructor TAbHMeter.Destroy;
begin
  FFontUnit.Free;
  FBevelInner.Free;
  FBevelOuter.Free;
  FScaleSettings.Free;
  DelControl(self);
  BmpBuffer.Free;
  inherited Destroy;
end;

procedure TAbHMeter.LogScaleChanged;
begin
  // notify TScaleSettings...
  FScaleSettings.LogScale := LogScale;
  if UpdateCount = 0 then Invalidate;
end;

procedure TAbHMeter.SetAbAutoSize(Value: Boolean);
begin
  FAutoSize := Value;
  if UpdateCount = 0 then Invalidate;
end;

procedure TAbHMeter.SetFontUnit(Value: TFont);
begin
  FFontUnit.Assign(Value);
  if UpdateCount = 0 then Invalidate;
end;

procedure TAbHMeter.DrawPointer(can: TCanvas);
var
  TempBmp           : TBitmap;
  Pos, posMin, posMax : Smallint;
  // posUL, posLL: Smallint;
  cl                : TColor;
  PixPerPPT         : Single;
  x1, x2            : Integer;
  ah                : Integer;          // arrow half
begin

  if isToSmall then Exit;

  if Assigned(BmpBuffer) then
  begin
    if (BmpBuffer.Width < 2) then begin
      exit;
    end;

    ah := FScaleSettings.sl1 div 2;

    x1 := ScaleSettings.pos0 - rBuffer.Left;
    x2 := (ScaleSettings.pos100 - rBuffer.Left);

    TempBmp := TBitmap.Create;
    TempBmp.Assign(BmpBuffer);
    {
    if BmpBuffer = nil then begin
      TempBmp.Free;
      exit;
    end;      }

    PixPerPPT := (((x2 - x1)) / 1000);

    Pos := x1 + Round(PixPerPPT * PPT);
    posMax := x1 + Round(PixPerPPT * MaxPPT);
    posMin := x1 + Round(PixPerPPT * MinPPT);

    {  calculation of lower/upper limitation
    posUL := x1 + Round(PixPerPPT * ULimitPPT);
    posLL := x1 + Round(PixPerPPT * LLimitPPT);
    }

    AltPosPointer := Pos;
    if FScaleSettings.PosLeftTop then
    begin
      zeiger[0].x := Pos - ah;
      zeiger[0].y := rPointer.Bottom - rBuffer.Top - 2;
      zeiger[1].x := Pos + ah;
      zeiger[1].y := zeiger[0].y;
      zeiger[2].x := Pos;
      zeiger[2].y := zeiger[0].y - FScaleSettings.sl1;

      minPointer[0].x := posMin;
      minPointer[0].y := rPointer.Top - rBuffer.Top - ah - 3;
      minPointer[1].x := posMin - ah;
      minPointer[1].y := minPointer[0].y;
      minPointer[2].x := minPointer[0].x;
      minPointer[2].y := minPointer[0].y + FScaleSettings.sl1;

      maxPointer[0].x := posMax;
      maxPointer[0].y := minPointer[0].y;
      maxPointer[1].x := posMax + ah;
      maxPointer[1].y := minPointer[1].y;
      maxPointer[2].x := maxPointer[0].x;
      maxPointer[2].y := minPointer[2].y;
    end
    else
    begin
      zeiger[0].x := Pos - ah;
      zeiger[0].y := rPointer.Top - rBuffer.Top;
      zeiger[1].x := Pos + ah;
      zeiger[1].y := zeiger[0].y;
      zeiger[2].x := Pos;
      zeiger[2].y := zeiger[0].y + FScaleSettings.sl1;


      minPointer[0].x := posMin;
      minPointer[0].y := (rPointer.Bottom - rBuffer.Top) + ah + 3;

      minPointer[1].x := posMin - ah;
      minPointer[1].y := minPointer[0].y;

      minPointer[2].x := minPointer[0].x;
      minPointer[2].y := minPointer[0].y - FScaleSettings.sl1;


      maxPointer[0].x := posMax;
      maxPointer[0].y := minPointer[0].y;
      ;

      maxPointer[1].x := posMax + ah;
      maxPointer[1].y := minPointer[1].y;

      maxPointer[2].x := maxPointer[0].x;
      maxPointer[2].y := minPointer[2].y;
    end;

    Zeiger2[0].x := rBuffer.Left + zeiger[0].x;
    Zeiger2[0].y := rBuffer.Top + zeiger[0].y;
    Zeiger2[1].x := rBuffer.Left + zeiger[1].x;
    Zeiger2[1].y := rBuffer.Top + zeiger[1].y;
    Zeiger2[2].x := rBuffer.Left + zeiger[2].x;
    Zeiger2[2].y := rBuffer.Top + zeiger[2].y;

    TempBmp.Canvas.Pen.Color := clBlack;

    if MinMax.FMinVisible then
    begin
      if MinMax.UseSectorCol and SectorSettings.CheckSectorColor(MinPPT, cl)
        then
        TempBmp.Canvas.Brush.Color := cl
      else
        TempBmp.Canvas.Brush.Color := MinMax.FMinColor;
      TempBmp.Canvas.Polygon(minPointer);
    end;

    if MinMax.FMaxVisible then
    begin
      if MinMax.UseSectorCol and SectorSettings.CheckSectorColor(MaxPPT, cl)
        then
        TempBmp.Canvas.Brush.Color := cl
      else
        TempBmp.Canvas.Brush.Color := MinMax.FMaxColor;
      TempBmp.Canvas.Polygon(maxPointer);
    end;

    if Flashing then
      TempBmp.Canvas.Brush.Color := FlashColor
    else
      TempBmp.Canvas.Brush.Color := FScaleSettings.PointerColor;
    TempBmp.Canvas.Polygon(zeiger);

    can.Draw(rBuffer.Left, rBuffer.Top, TempBmp);

    TempBmp.Free;

  end;
end;

procedure TAbHMeter.SetOptions(Value: THMeterOptions);
begin
  FOptions := Value;
  if UpdateCount = 0 then Invalidate;