abrmeter.pas

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

unit AbRMeter;

{******************************************************************************}
{ Abakus VCL                                                                   }
{               Components TAb120Meter, TAb180Meter, TAb270Meter               }
{                                                                              }
{******************************************************************************}
{        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,
  {****** Abakus VCL - Units ******}
  _AbProc,
  _GClass,
  _AbInfo,
  _Arrow,
  AbFlashT;

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

  TMeterType = (Ab360Meter, Ab270Meter, Ab180Meter, Ab120Meter);

  TAbRMeter = class(TAbAnalogGControl)
  private
    FAutoSize: Boolean;
    FArrowSettings: TArrowSettings;
    FBevelInner: TAbSBevel;
    FBevelOuter: TAbSBevel;
    FFontUnit: TFont;
    FOptions: TRMeterOptions;
    FScaleSettings: TScaleSettings;
    isToSmall : Boolean;
    BmpPointerArea: TBitmap;
    Flashing: Boolean;
    FlashColor: TColor;
    vChange : Boolean;
  protected
    procedure PointerFlash;
    procedure Paint; override;
    procedure LimitChange; override;
    procedure ValueChange; override;
    procedure LogScaleChanged; override;
    procedure ParamChange(Sender: TObject); override;
    procedure OverflowChange(PPT: Integer); override;
    procedure SetAbAutoSize(Value: Boolean);
    procedure SetOptions(Value: TRMeterOptions);
    procedure SetFontUnit(Value: TFont);
    procedure CalcSize;
    procedure DrawRSector(can: TCanvas; rSector: TRect);
    procedure DrawPointer(can: TCanvas; Col: TColor);
    procedure WMFlash(var Message: TMessage); message WM_FLASH;
  public
    ArrowStartPos: array[0..8] of TPoint;
    ArrowActPos: array[0..8] of TPoint;
    minPointerStart: array[0..2] of TPoint;  //pointer for min values Startposition
    maxPointerStart: array[0..2] of TPoint;  //pointer for max values Startposition
    minPointer: array[0..2] of TPoint;  // pointer for min values
    maxPointer: array[0..2] of TPoint;  // pointer for max values

    sName1: TSize;
    sName2: TSize;
    sUnit: TSize;
    PPTOld: Smallint;
    min_h: Smallint;
    min_w: Smallint;
    rPointer: TRect;

    HeightFactor: Single;
    StartAngle: Smallint;
    RotAngle: Smallint;
    MeterType: TMeterType;

    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 ArrowSettings: TArrowSettings read FArrowSettings write
    FArrowSettings;
    property FontUnit: TFont read FFontUnit write SetFontUnit;
    property BevelInner: TAbSBevel read FBevelInner write FBevelInner;
    property BevelOuter: TAbSBevel read FBevelOuter write FBevelOuter;
    property Options: TRMeterOptions read FOptions write SetOptions;
    property ScaleSettings: TScaleSettings read FScaleSettings write
    FScaleSettings;

  end;

  TAb360Meter = class(TAbRMeter)
  private
  protected
    procedure SetStartPos(Value : SmallInt);
  public
    constructor Create(AOwner: TComponent); override;
  published
    property StartPos : SmallInt read StartAngle write SetStartPos;
  end;

  TAb270Meter = class(TAbRMeter)
  private
  protected
  public
    constructor Create(AOwner: TComponent); override;
  published
  end;

  TAb180Meter = class(TAbRMeter)
  private
  protected
  public
    constructor Create(AOwner: TComponent); override;
  published
  end;

  TAb120Meter = class(TAbRMeter)
  private
  protected
  public
    constructor Create(AOwner: TComponent); override;
  published
  end;

implementation

{======================================================================}

constructor TAb120Meter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  StartAngle := 300;
  RotAngle := 120;
  HeightFactor := 2.5;
  SetBounds(left,top, 252, 155);
  FScaleSettings.Steps := 5;
  MeterType := Ab120Meter;
  if (csDesigning in Componentstate) then Loaded;
end;

{ TAb180Meter }
{==============================================================================}

constructor TAb180Meter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  StartAngle := 270;
  RotAngle := 180;
  HeightFactor := 2;
  SetBounds(left,top, 252, 174);
  FScaleSettings.Steps := 5;
  MeterType := Ab180Meter;
  if (csDesigning in Componentstate) then Loaded;
end;

{ TAb270Meter }
{==============================================================================}

constructor TAb270Meter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  StartAngle := 225;
  RotAngle := 270;
  HeightFactor := 1.18;
  SetBounds(left,top, 252, 252);
  FScaleSettings.Steps := 10;
  MeterType := Ab270Meter;
  if (csDesigning in Componentstate) then Loaded;
end;

{ TAb360Meter }
{==============================================================================}

constructor TAb360Meter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  StartAngle := 0;
  RotAngle := 360;
  HeightFactor := 1;
  SetBounds(left,top, 252, 252);
  FScaleSettings.Steps := 10;
  MeterType := Ab360Meter;
  if (csDesigning in Componentstate) then Loaded;
end;

procedure TAb360Meter.SetStartPos(Value : SmallInt);
begin
  if Value <> StartAngle then begin
    if (Value >= 0) and (Value <= 360) then begin
       StartAngle := Value;
       ParamChange(self);
    end;
  end;
end;

{ TAbRMeter }
{==============================================================================}

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

  FAutoSize := true;
  isToSmall := false;

  FArrowSettings := TArrowSettings.Create;

  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, opName1, opName2, opOverflow,
    opLimit, opSector, opUnit];


  FScaleSettings := TScaleSettings.Create;

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

  PPTOld := -1;

  Flashing := false;

  FlashColor := clRed;

  if (csDesigning in componentstate) then Loaded;
end;

procedure TAbRMeter.Loaded;
begin
  FArrowSettings.OnChange := ParamChange;
  FFontUnit.OnChange := ParamChange;
  FBevelInner.OnChange := ParamChange;
  FBevelOuter.OnChange := ParamChange;
  FScaleSettings.OnChange := ParamChange;
  inherited Loaded;
  EndUpdate;
end;

destructor TAbRMeter.Destroy;
begin
  FFontUnit.Free;
  FBevelInner.Free;
  FBevelOuter.Free;
  FScaleSettings.Free;
  FArrowSettings.Free;
  DelControl(self);
  BmpPointerArea.Free;
  inherited Destroy;
end;

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

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

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

procedure TAbRMeter.SetOptions(Value: TRMeterOptions);
begin
  FOptions := Value;
  if UpdateCount = 0 then Invalidate;
end;

procedure TAbRMeter.PointerFlash;
begin
  if ((opOverflow in Options) and ((PPT > 1000) or (PPT < 0)))
    or ((opLimit in Options) and (LLimit or ULimit)) then
  begin
    AddControl(self, Freq2Hz);
    Flashing := true;
  end
  else
  begin
    Flashing := false;
    DelControl(self);
  end;
end;

procedure TAbRMeter.OverflowChange(PPT: Integer);
begin
  PointerFlash;
end;

procedure TAbRMeter.LimitChange;
begin
  PointerFlash;
end;

procedure TAbRMeter.WMFlash(var Message: TMessage);
begin
  if (not Visible) or vChange then Exit;
  with Message do
  begin
    if isToSmall then Exit;
    if lParam <> 0 then
      FlashColor := cAlarm1
    else
      FlashColor := cAlarm0;
    DrawPointer(Canvas, FlashColor);
  end;
end;

procedure TAbRMeter.DrawRSector(can: TCanvas; rSector: TRect);
var
  A, A1, A2         : Smallint;
  WPP               : Single;
  KombiRgn, regn1, regn2: HRgn;
  rect1, rect2, Cliprect: TRect;
  w                 : Smallint;
begin
  w := (rSector.Right - rSector.Left) div 10 + SectorSettings.WidthOffset;
  Cliprect := can.Cliprect;

  Cliprect := Rect(Left + Cliprect.Left,
    Top + Cliprect.Top ,
    Left + Cliprect.Right,
    Top + Cliprect.Bottom );


  rect1 := Rect(Left + rSector.Left ,
    Top + rSector.Top ,
    Left + rSector.Right ,
    Top + rSector.Bottom + 1);

  rect2 := Rect(rect1.Left + w,
    rect1.Top + w,
    rect1.Right - w,
    rect1.Bottom - w);


  regn1 := CreateEllipticRgnIndirect(rect1);
  regn2 := CreateEllipticRgnIndirect(rect2);

  KombiRgn := CreateRectRgnIndirect(rect1);
  CombineRgn(KombiRgn, regn1, regn2, RGN_DIFF);
  SelectClipRgn(can.Handle, KombiRgn);


  WPP := RotAngle / 1000;
  A := StartAngle;

  can.Brush.Style := bsSolid;

  if (SectorSettings.Sector1To - SectorSettings.Sector1From > 4) and
    (SectorSettings.Sector1To > 0) and (SectorSettings.Sector1From < 1000) then
  begin
    can.Brush.Color := SectorSettings.Sector1Color;
    can.Pen.Color := SectorSettings.Sector1Color;
    if (SectorSettings.Sector1From < 0) then
    begin
      A1 := A;
      A2 := Round(WPP * AbMinInt(1000, SectorSettings.Sector1To));
    end
    else
    begin
      A1 := A + Round(WPP * SectorSettings.Sector1From);
      A2 := Round(WPP * (AbMinInt(1000, SectorSettings.Sector1To) -
        SectorSettings.Sector1From));
    end;
    AbRoundSector(can, rSector, A1, A2);
  end;