abvind.pas

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

unit AbVInd;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                          Component TAbValueInd                               }
{                                                                              }
{******************************************************************************}
{        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,
  _AbInfo,
  AbFlashT;

type
  TValueIndOption = (opBevelInner, opBevelOuter, opName1, opName2, opUnit);
  TValueIndOptions = set of TValueIndOption;

  TAbValueInd = class(TAbAnalogGControl)
  private
    FAutoSize: Boolean;
    FBevelInner: TAbSBevel;
    FBevelOuter: TAbSBevel;
    FBevelValue: TAbSBevel;
    FFontValue: TFont;
    FOptions: TValueIndOptions;
    sName1: TSize;
    sName2: TSize;
    sValue: TSize;
    sUnit: TSize;
    rValue: TRect;
    min_h: Smallint;
    min_w: Smallint;
  protected
    procedure Paint; override;
    procedure ValueChange; override;
    procedure ParamChange(Sender: TObject); override;
    procedure OverflowChange(PPT: Integer); override;
    procedure SetAbAutoSize(Value: Boolean);
    procedure SetOptions(Value: TValueIndOptions);
    procedure SetFontValue(Value: TFont);
    procedure CalcSize;
    procedure WMFlash(var Message: TMessage); message WM_FLASH;
  public
    procedure Loaded; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Font;
    property Visible;
    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: TValueIndOptions read FOptions write SetOptions;
  end;


implementation


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

  Height := 48;
  Width := 67;

  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 := [opName1, opName2, opUnit];

  if (csDesigning in Componentstate) then Loaded;
end;

procedure TAbValueInd.Loaded;
begin
  inherited Loaded;

  FFontValue.OnChange := ParamChange;
  FBevelInner.OnChange := ParamChange;
  FBevelOuter.OnChange := ParamChange;
  FBevelValue.OnChange := ParamChange;
  EndUpdate;

end;

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

procedure TAbValueInd.SetAbAutoSize(Value: Boolean);
begin
  FAutoSize := Value;
  Change;
end;

procedure TAbValueInd.SetFontValue(Value: TFont);
begin
  FFontValue.Assign(Value);
  Change;
end;

procedure TAbValueInd.SetOptions(Value: TValueIndOptions);
begin
  FOptions := Value;
  Change;
end;

procedure TAbValueInd.OverflowChange(PPT: Integer);
begin
  if PPT < 0 then
  begin
 {     AddControl(self,Freq2Hz);}
  end
  else
    if PPT > 1000 then
    begin
{      AddControl(self,Freq2Hz);}
    end
    else
    begin
{      DelControl(self); }
    end;
end;

procedure TAbValueInd.WMFlash(var Message: TMessage);
begin
  with Message do
  begin
  end;
end;


procedure TAbValueInd.CalcSize;
var
  w                 : Smallint;

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

  procedure GetMax(var Max: Smallint; Value: Smallint);
  begin
    if Max < Value then Max := Value;
  end;
begin
  w := 0;
  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;


  min_h := 0;
  min_w := 0;
  if opBevelOuter in FOptions then
  begin
    min_h := min_h + BevelOuter.TotalWidth * 2;

    min_w := BevelOuter.TotalWidth * 2;
  end;

  if opName1 in FOptions then
  begin
    min_h := min_h + sName1.cy;
    w := 0;
    if opBevelOuter in FOptions then w := BevelOuter.TotalWidth * 2;
    GetMin(min_w, w + sName1.cx);
  end;
  if opName2 in FOptions then
  begin
    min_h := min_h + sName2.cy;
    w := 0;
    if opBevelOuter in FOptions then w := BevelOuter.TotalWidth * 2;
    GetMin(min_w, w + sName2.cx);
  end;

  if opBevelInner in FOptions then
  begin
    min_h := min_h + BevelInner.TotalWidth * 2;
    w := w + BevelInner.TotalWidth * 2;
    GetMin(min_w, w);
  end;


  w := 0;
  if opBevelOuter in FOptions then w := w + BevelOuter.TotalWidth * 2;
  if opBevelInner in FOptions then w := w + BevelInner.TotalWidth * 2;

  min_h := min_h + sValue.cy + BevelValue.TotalWidth * 2;


  GetMin(min_w, w + sValue.cx + sUnit.cx + BevelValue.TotalWidth * 2 + sValue.cy
    { div 3});

  if not AutoSize and ((Width < min_w) or (Height < min_h)) then
  begin
    if Width < min_w then
    begin
      Width := min_w;
    end;
    if Height < min_h then
    begin
      Height := min_h;
    end;
  end;

  if AutoSize and ((Width <> min_w) or (Height <> min_h)) then
  begin
    SetBounds(Left, Top, min_w, min_h);
  end;

end;


procedure TAbValueInd.Paint;
var
  r                 : TRect;
  h, w, Offset      : Smallint;
  space             : Smallint;

begin

  CalcSize;

  r := ClientRect;

  if opBevelOuter in FOptions then
  begin
    FBevelOuter.PaintFilledBevel(Canvas, r);
    space := BevelOuter.Spacing div 2;
  end
  else
    space := 0;

  Canvas.Brush.Style := bsClear;
  Canvas.Font := Font;
  if opName2 in FOptions then
  begin
    r.Bottom := r.Bottom - sName2.cy;
    Canvas.textout(r.Left + ((r.Right - r.Left - sName2.cx) div 2), r.Bottom +
      space, SignalSettings.Name2);
  end;
  if opName1 in FOptions then
  begin
    r.Bottom := r.Bottom - sName1.cy;
    Canvas.textout(r.Left + ((r.Right - r.Left - sName1.cx) div 2), r.Bottom +
      space, SignalSettings.Name1);
  end;

  if opBevelInner in FOptions then FBevelInner.PaintFilledBevel(Canvas, r);


  Canvas.Font := FontValue;

  h := FBevelValue.TotalWidth * 2 + sValue.cy;

  w := sValue.cy div 3;

  rValue.Left := r.Left + (r.Right - r.Left - sValue.cx - sUnit.cx - w) div 2 -
    w;
  rValue.Right := rValue.Left + sValue.cx + BevelValue.TotalWidth * 2 + w + w;

  rValue.Top := r.Top;
  rValue.Bottom := r.Top + h;

  FBevelValue.PaintFilledBevel(Canvas, rValue);
  Canvas.Font.Color := Font.Color;
  Canvas.Brush.Style := bsClear;
  if opUnit in FOptions then
    Canvas.textout(rValue.Right + w, rValue.Top, SignalSettings.ValueUnit);
  rValue.Left := rValue.Left + w;
  rValue.Right := rValue.Right - w;
  r.Top := r.Top + h + BevelOuter.Spacing;

  Offset := 0;
  r.Top := r.Top + Offset div 2;
  r.Bottom := r.Bottom - Offset div 2;

  ValueChange;
end;

procedure TAbValueInd.ValueChange;
var
  TempBmp           : TBitmap;
begin
  inherited ValueChange;
  if not (Visible or (csDesigning in Componentstate)) then Exit;

  TempBmp := TBitmap.Create;
  TempBmp.Width := rValue.Right - rValue.Left;
  TempBmp.Height := rValue.Bottom - rValue.Top;
  TempBmp.Canvas.Font := FontValue;
  with TempBmp.Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := FBevelValue.Color;
    Pen.Color := FBevelValue.Color;
    Rectangle(0, 0, Width, Height);
    Brush.Style := bsClear;
    if csDesigning in Componentstate then
      textout(TempBmp.Width - TextWidth(SignalSettings.ValueSizeStr), 0,
        SignalSettings.ValueSizeStr)
    else
      textout(TempBmp.Width - TextWidth(ValueStr), 0, ValueStr);
  end;
  Canvas.Draw(rValue.Left, rValue.Top, TempBmp);
  TempBmp.Free;

end;


procedure TAbValueInd.ParamChange(Sender: TObject);

begin
  inherited ParamChange(Sender);
  Invalidate;
end;

end.