abhbar.pas

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

unit AbHBar;

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

type
  THBarOption = (opBevelInner, opBevelOuter, opValue, opName1, opName2,
    opOverflow, opUnit);
  THBarOptions = set of THBarOption;

  TAbHBar = class(TAbAnalogGControl)
  private
    FAutoSize: Boolean;
    FBarSettings: TBarSettings;
    FBevelInner: TAbSBevel;
    FBevelOuter: TAbSBevel;
    FBevelValue: TAbSBevel;
    FFontValue: TFont;
    FOptions: THBarOptions;
    pUOverflow: array[0..3] of TPoint;
    pLOverflow: array[0..3] of TPoint;
    sName1: TSize;
    sName2: TSize;
    sValue: TSize;
    sUnit: TSize;
    rValue: TRect;
    rBuffer: TRect;                     // buffer rect for the Min/max indication
    hMinMax: Integer;
    BmpBuffer: TBitmap;
    pos0: Integer;                      {scale position 0%}
    pos100: Integer;                    {scale position 100%}
    minPointer: array[0..2] of TPoint;  // pointer for min values
    maxPointer: array[0..2] of TPoint;  // pointer for max values
  protected
    procedure Paint; override;
    procedure ValueChange; override;
    procedure ParamChange(Sender: TObject); override;
    procedure SetAbAutoSize(Value: Boolean);
    procedure SetOptions(Value: THBarOptions);
    procedure SetFontValue(Value: TFont);
    procedure DrawOverflow(can: TCanvas; UColor, LColor: TColor);
    procedure OverflowChange(PPT: Integer); override;
    procedure WMFlash(var Message: TMessage); message WM_FLASH;
    procedure MinMaxChange(Sender: TObject); override;
  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 BarSettings: TBarSettings read FBarSettings write FBarSettings;
    property BevelInner: TAbSBevel read FBevelInner write FBevelInner;
    property BevelOuter: TAbSBevel read FBevelOuter write FBevelOuter;
    property BevelValue: TAbSBevel read FBevelValue write FBevelValue;
    property Options: THBarOptions read FOptions write SetOptions;
  end;

implementation

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

  SetBounds(0, 0, 115, 74);

  FAutoSize := true;

  FFontValue := TFont.Create;
  FFontValue.Color := clLime;
  FFontValue.Name := 'System';
  FFontValue.Size := 10;

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

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

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

  FBarSettings := TBarSettings.Create;
  FBarSettings.minWidth := 100;
  FBarSettings.minHeight := 9;
  FBarSettings.Bevel.Spacing := 1;
  FBarSettings.Bevel.Color := clBlack;

  FOptions := [opValue, opName1, opName2, opOverflow, opUnit];

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

  if (csDesigning in Componentstate) then Loaded;

end;

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

  FBevelOuter.OnChange := ParamChange;

  FBevelInner.OnChange := ParamChange;

  FBevelValue.OnChange := ParamChange;

  FBarSettings.OnChange := ParamChange;
  EndUpdate;
end;

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

procedure TAbHBar.MinMaxChange(Sender: TObject);
begin
  inherited;
  if (csDesigning in Componentstate) then Invalidate;
end;

procedure TAbHBar.SetAbAutoSize(Value: Boolean);
begin
  FAutoSize := Value;
  Invalidate;
end;

procedure TAbHBar.SetFontValue(Value: TFont);
begin
  FFontValue.Assign(Value);
  Invalidate;
end;

procedure TAbHBar.SetOptions(Value: THBarOptions);
begin
  if not (opOverflow in Value) then
    DelControl(self)
  else
    if (UOverflow or LOverflow) then AddControl(self, Freq2Hz);
  FOptions := Value;
  Invalidate;
end;

procedure TAbHBar.OverflowChange(PPT: Integer);
begin
  if (opOverflow in FOptions) then
  begin
    if LOverflow or UOverflow then
    begin
      AddControl(self, Freq2Hz);
    end
    else
    begin
      DelControl(self);
      if Visible or (csDesigning in Componentstate) then
        DrawOverflow(Canvas, clBtnFace, clBtnFace);
    end;
  end;
end;

procedure TAbHBar.WMFlash(var Message: TMessage);
begin
  with Message do
  begin
    if not Visible then Exit;
    if PPT >= 1000 then
      if lParam <> 0 then
        DrawOverflow(Canvas, clBtnFace, cAlarm1)
      else
        DrawOverflow(Canvas, clBtnFace, cAlarm0)
    else
      if lParam <> 0 then
        DrawOverflow(Canvas, cAlarm1, clBtnFace)
      else
        DrawOverflow(Canvas, cAlarm0, clBtnFace);
  end;
end;

procedure TAbHBar.DrawOverflow(can: TCanvas; UColor, LColor: TColor);
begin
  with can do
  begin
    Pen.Width := 1;
    Pen.Color := clBtnShadow;
    Brush.Color := UColor;
    Brush.Style := bsSolid;

    Polygon(pUOverflow);

    Pen.Color := clBtnShadow;
    Brush.Color := LColor;
    Polygon(pLOverflow);
  end;
end;


procedure TAbHBar.Paint;
var
  r                 : TRect;
  h, w, x, y, Offset: Smallint;
  min_h, min_w      : Smallint;
  space             : Smallint;


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

begin
  hMinMax := BarSettings.minHeight + BarSettings.Bevel.Spacing * 2;
  Canvas.Font := Font;
  sName1.cx := Canvas.TextWidth(SignalSettings.Name1);
  sName1.cy := Canvas.Textheight(SignalSettings.Name1);
  sName2.cx := Canvas.TextWidth(SignalSettings.Name2);
  sName2.cy := Canvas.Textheight(SignalSettings.Name2);

  Canvas.Font := FontValue;

  sValue.cx := Canvas.TextWidth(SignalSettings.ValueSizeStr);
  sValue.cy := Canvas.Textheight(SignalSettings.ValueSizeStr);
  sUnit.cx := Canvas.TextWidth(SignalSettings.ValueUnit);
  sUnit.cy := Canvas.Textheight(SignalSettings.ValueUnit);
  if not (opUnit in FOptions) then sUnit.cx := 0;

  BarSettings.ValueUnit := SignalSettings.ValueUnit;

  if opBevelOuter in FOptions then
  begin
    min_h := BarSettings.Bevel.TotalWidth * 2
      + BevelOuter.TotalWidth * 2
      + BarSettings.minHeight;
    w := BevelOuter.TotalWidth * 2 + BarSettings.minWidth;
  end
  else
  begin
    min_h := BarSettings.Bevel.TotalWidth * 2
      + BarSettings.minHeight;
    w := BarSettings.minWidth;
  end;