abvmeter.pas

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

unit AbVMeter;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                            component TAbVMeter                               }
{                                                                              }
{******************************************************************************}
{        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 ******}
  _AbInfo,
  _GClass,
  _AbProc,
  AbFlashT;

type
  TAbVMeterOption = (opBevelInner, opBevelOuter, opValue, opName1, opName2,
    opOverflow, opLimit, opSector, opUnit);
  TAbVMeterOptions = set of TAbVMeterOption;

  TAbVMeter = class(TAbAnalogGControl)
  private
    FAutoSize: Boolean;
    FBevelInner: TAbSBevel;
    FBevelOuter: TAbSBevel;
    FBevelValue: TAbSBevel;
    FFontValue: TFont;
    FScaleSettings: TScaleSettings;
    FOptions: TAbVMeterOptions;
    BmpBuffer: TBitmap;

    sName1: TSize;
    sName2: TSize;
    sValue: TSize;
    sUnit: TSize;
    rValue: TRect;
    rPointer: TRect;
    rBuffer: TRect;                     // meter inner part
    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
    isToSmall : Boolean;
    AltPosPointer: Smallint;
    min_h: Smallint;
    min_w: Smallint;
    Flashing: Boolean;
    FlashColor: TColor;
  protected
    procedure PointerFlash;
    procedure Paint; override;
    procedure ValueChange; override;
    procedure LimitChange; override;
    procedure LogScaleChanged; override;
    procedure ParamChange(Sender: TObject); override;
    procedure OverflowChange(PPT: Integer); override;
    procedure SetAbAutoSize(Value: Boolean);
    procedure SetOptions(Value: TAbVMeterOptions);
    procedure SetFontValue(Value: TFont);
    procedure DrawVSector(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 FontValue: TFont read FFontValue write SetFontValue;
    property BevelInner: TAbSBevel read FBevelInner write FBevelInner;
    property BevelOuter: TAbSBevel read FBevelOuter write FBevelOuter;
    property BevelValue: TAbSBevel read FBevelValue write FBevelValue;
    property Options: TAbVMeterOptions read FOptions write SetOptions;
    property ScaleSettings: TScaleSettings read FScaleSettings write
    FScaleSettings;
  end;


implementation


constructor TAbVMeter.Create(AOwner: TComponent);
begin
  BeginUpdate;
  inherited Create(AOwner);
  if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  Height := 273;
  Width := 98;
  isToSmall := false;
  FAutoSize := true;

  FFontValue := TFont.Create;
  FFontValue.Color := clLime;
  FFontValue.Name := 'System';
  FFontValue.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;

  FBevelValue := TAbSBevel.Create;
  FBevelValue.Style := bsLowered;
  FBevelValue.Width := 2;
  FBevelValue.Color := clBlack;
  FBevelValue.Spacing := 0;

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

  FScaleSettings := TScaleSettings.Create;

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

  Flashing := false;
  FlashColor := clRed;

  if (csDesigning in Componentstate) then Loaded;
end;

procedure TAbVMeter.Loaded;
begin
  inherited Loaded;
  FFontValue.OnChange := ParamChange;

  FBevelInner.OnChange := ParamChange;

  FBevelOuter.OnChange := ParamChange;

  FBevelValue.OnChange := ParamChange;

  FScaleSettings.OnChange := ParamChange;
  EndUpdate;
end;

destructor TAbVMeter.Destroy;
begin
  FFontValue.Free;
  FBevelInner.Free;
  FBevelOuter.Free;
  FBevelValue.Free;
  FScaleSettings.Free;
  DelControl(self);
  BmpBuffer.Free;
  inherited Destroy;
end;

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

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

procedure TAbVMeter.SetFontValue(Value: TFont);
begin
  FFontValue.Assign(Value);
  if UpdateCount = 0 then Invalidate;
end;


procedure TAbVMeter.DrawPointer(can: TCanvas);
var
  TempBmp           : TBitmap;
  Pos, posMin, posMax : Smallint;
  // posUL, posLL: Smallint;
  cl                : TColor;
  PixPerPPT         : Single;
  y1, y2            : Integer;          // Scale top/bottom position
  ah                : Integer;          // arrow half
begin

  if Assigned(BmpBuffer) then
  begin
    if isToSmall then Exit;

    ah := FScaleSettings.sl1 div 2;

    y1 := ScaleSettings.pos100 - rBuffer.Top; // top
    y2 := (ScaleSettings.pos0 - rBuffer.Top); // bottom

    TempBmp := TBitmap.Create;
    TempBmp.Assign(BmpBuffer);

    PixPerPPT := (((y2 - y1)) / 1000);

    Pos := y2 - Round(PixPerPPT * PPT);
    posMax := y2 - Round(PixPerPPT * MaxPPT);
    posMin := y2 - Round(PixPerPPT * MinPPT);

    {  calculation of lower/upper limitation
    posUL := y2 - Round(PixPerPPT * ULimitPPT);
    posLL := y2 - Round(PixPerPPT * LLimitPPT);
    }
    AltPosPointer := Pos;
    if FScaleSettings.PosLeftTop then
    begin
      zeiger[0].x := rPointer.Right - 1 - rBuffer.Left;
      zeiger[0].y := Pos + ah;
      zeiger[1].x := zeiger[0].x;
      zeiger[1].y := Pos - ah;
      zeiger[2].x := zeiger[0].x - FScaleSettings.sl1;
      zeiger[2].y := Pos;

      minPointer[0].x := zeiger[2].x - FScaleSettings.sl1 + 4;
      minPointer[0].y := posMin;
      minPointer[1].x := minPointer[0].x;
      minPointer[1].y := posMin + ah;
      minPointer[2].x := minPointer[0].x + FScaleSettings.sl1;
      minPointer[2].y := posMin;

      maxPointer[0].x := minPointer[0].x;
      maxPointer[0].y := posMax;
      maxPointer[1].x := minPointer[1].x;
      maxPointer[1].y := posMax - ah;
      maxPointer[2].x := minPointer[2].x;
      maxPointer[2].y := posMax;

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

      minPointer[0].x := zeiger[0].x + FScaleSettings.sl1 - 4;
      minPointer[0].y := posMin;
      minPointer[1].x := minPointer[0].x + FScaleSettings.sl1;
      minPointer[1].y := posMin + ah;
      minPointer[2].x := minPointer[1].x;
      minPointer[2].y := posMin;

      maxPointer[0].x := minPointer[0].x;
      maxPointer[0].y := posMax;
      maxPointer[1].x := minPointer[1].x;
      maxPointer[1].y := posMax - ah;
      maxPointer[2].x := minPointer[2].x;
      maxPointer[2].y := posMax;

    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 TAbVMeter.SetOptions(Value: TAbVMeterOptions);
begin
  FOptions := Value;
  if UpdateCount = 0 then Invalidate;
end;


procedure TAbVMeter.DrawVSector(can: TCanvas; rSector: TRect);
var
  h, y1, y2         : Smallint;
  PPP               : Single;
begin
  if isToSmall then Exit;
  h := rSector.Bottom - rSector.Top;
  PPP := h / 1000;
  can.Brush.Style := bsSolid;

  can.Pen.Style := psClear;