abthmet.pas

来自「著名的虚拟仪表控件,包含全部源码, 可以在,delphi2007 下安装运行」· PAS 代码 · 共 542 行

unit AbThMet;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                             component TAbThermometer                         }
{                                                                              }
{******************************************************************************}
{        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;

type
  TThMetOption = (opBevelInner, opBevelOuter, opValue, opName1, opName2,
    opUnit);
  TThMetOptions = set of TThMetOption;

  TAbThermometer = class(TAbAnalogGControl)
  private
    FAutoSize: Boolean;
    FBarSettings: TBarSettings;
    FBevelInner: TAbSBevel;
    FBevelOuter: TAbSBevel;
    FBevelValue: TAbSBevel;
    FFontValue: TFont;
    FOptions: TThMetOptions;
    FScaleSettings: TScaleSettings;
    FScaleSpacing: Integer;
    isToSmall : Boolean;
    rBuffer: TRect;
    BmpBuffer: TBitmap;
    sName1: TSize;
    sName2: TSize;
    sValue: TSize;
    sUnit: TSize;
    rValue: TRect;
    rScale: TRect;
    min_h: Smallint;
    min_w: Smallint;
  protected
    procedure Paint; override;
    procedure ValueChange; override;
    procedure ParamChange(Sender: TObject); override;
    procedure LogScaleChanged; override;
    procedure SetAbAutoSize(Value: Boolean);
    procedure SetOptions(Value: TThMetOptions);
    procedure SetFontValue(Value: TFont);
    procedure SetScaleSpacing(Value: Integer);
    procedure CalcSize;
  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: TThMetOptions read FOptions write SetOptions;
    property ScaleSettings: TScaleSettings read FScaleSettings write
    FScaleSettings;
    property ScaleSpacing: Integer read FScaleSpacing write SetScaleSpacing;
  end;

implementation


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

  Height := 172;
  Width := 82;
  isToSmall := false;

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

  FAutoSize := true;

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

  FBarSettings := TBarSettings.Create;
  FBarSettings.minWidth := 3;
  FBarSettings.minHeight := 100;
  FBarSettings.Color := clBlue;
  FBarSettings.BkColor := clBtnFace;
  FBarSettings.Bevel.Spacing := 1;
  FBarSettings.Bevel.Color := clBtnFace;
  FBarSettings.Bevel.Style := bsRaised;

  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 := clBtnFace;
  FBevelValue.Spacing := 0;

  FScaleSettings := TScaleSettings.Create;
  FScaleSettings.DrawLine := false;
  FScaleSettings.SubSteps := 5;
  FScaleSettings.Font.Size := 8;

  FScaleSpacing := 2;


  SignalSettings.ValueUnit := '癈';
  SignalSettings.ValueFrom := -40;
  SignalSettings.ValueTo := 60;

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

  if (csDesigning in Componentstate) then Loaded;

end;

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


  FBevelOuter.OnChange := ParamChange;


  FBevelInner.OnChange := ParamChange;


  FBevelValue.OnChange := ParamChange;


  FScaleSettings.OnChange := ParamChange;

  FBarSettings.OnChange := ParamChange;
  EndUpdate;
end;

destructor TAbThermometer.Destroy;
begin
  FFontValue.Free;
  FBevelInner.Free;
  FBevelOuter.Free;
  FBevelValue.Free;
  FScaleSettings.Free;
  FBarSettings.Free;
  BmpBuffer.Free;
  inherited Destroy;
end;

procedure TAbThermometer.LogScaleChanged;
begin
  // notify TScaleSettings...
  FScaleSettings.LogScale := LogScale;
  Invalidate;
end;

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

procedure TAbThermometer.SetScaleSpacing(Value: Integer);
begin
  if FScaleSpacing <> Value then
  begin
    FScaleSpacing := Value;
    Invalidate;
  end;
end;

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

procedure TAbThermometer.SetOptions(Value: TThMetOptions);
begin
  FOptions := Value;
  Invalidate;
end;


procedure TAbThermometer.CalcSize;
var
  w, w2             : 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
  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);

  ScaleSettings.CalcSize(Canvas, SignalSettings.ValueFrom,
    SignalSettings.ValueTo);

  if not (opUnit in FOptions) then sUnit.cx := 0;

  BarSettings.ValueUnit := SignalSettings.ValueUnit;
  min_h := BarSettings.minHeight;

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

    w2 := (ScaleSettings.TotalWidth + BevelOuter.TotalWidth) * 2 +
      BarSettings.minWidth;
  end
  else
  begin
    min_h := min_h + BarSettings.Bevel.TotalWidth * 2;
    w2 := BarSettings.minWidth + (ScaleSettings.TotalWidth) * 2;
  end;
  min_w := w2;

  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 := min_w + (BevelInner.TotalWidth) * 2;
    GetMin(min_w, w);
  end;

  if opValue in FOptions then
  begin
    min_h := min_h + sValue.cy + BevelValue.TotalWidth * 2 +
      BevelInner.TotalWidth;

    GetMin(min_w, sValue.cx + sUnit.cx + BevelValue.TotalWidth * 2 + sValue.cy);
  end;

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

end;

procedure TAbThermometer.Paint;
var
  r                 : TRect;
  h, w, x2, 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;

  Canvas.Font := FontValue;
  if opValue in FOptions then
  begin
    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.Top := r.Top;
    rValue.Right := rValue.Left + sValue.cx + BevelValue.TotalWidth * 2 + w + w;
    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;

  end;

  Canvas.Font := ScaleSettings.Font;

  Offset := 0;

  if opBevelInner in FOptions then
    FBevelInner.PaintFilledBevel(Canvas, r)
  else
    Offset := Canvas.Textheight('X') div 2;

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

  rBuffer := r;

  isToSmall := (r.right - r.left < 2) or (r.Bottom - r.top < 2);
  if isToSmall then Exit;

  AbBorder(rBuffer, -FBevelInner.Spacing);

  x2 := FBarSettings.Bevel.TotalWidth * 2 + FBarSettings.minWidth;

  r.Left := (Width - x2) div 2;
  r.Right := r.Left + x2;



  FBarSettings.Bevel.PaintFilledBevel(Canvas, r);
  FBarSettings.BarRect := r;

  ScaleSettings.CalcSize(Canvas, SignalSettings.ValueFrom,
    SignalSettings.ValueTo);

  rScale := r;
  rScale.Right := rScale.Left + FScaleSpacing - 1;
  rScale.Left := r.Right - FScaleSpacing;
  rScale.Bottom := rScale.Bottom - 1;

  ScaleSettings.FPosLeftTop := true;
  ScaleSettings.VertiScala(Canvas, rScale); {left}

  ScaleSettings.FPosLeftTop := false;
  ScaleSettings.VertiScala(Canvas, rScale); {right}


   // save inner rect
  BmpBuffer.Width := rBuffer.Right - rBuffer.Left;
  BmpBuffer.Height := rBuffer.Bottom - rBuffer.Top;
  //BmpBuffer.Canvas.CopyRect(BmpBuffer.Canvas.Cliprect, Canvas, rBuffer);
  GetBkUpImage(Canvas,BmpBuffer,rBuffer);

  FBarSettings.BarRect.Top := FBarSettings.BarRect.Top - rBuffer.Top;
  FBarSettings.BarRect.Bottom := FBarSettings.BarRect.Bottom - rBuffer.Top;
  FBarSettings.BarRect.Left := FBarSettings.BarRect.Left - rBuffer.Left;
  FBarSettings.BarRect.Right := FBarSettings.BarRect.Left +
    FBarSettings.minWidth;

  ValueChange;
end;

procedure TAbThermometer.ValueChange;
var
  TempBmp           : TBitmap;
  r                 : TRect;
  posMin, posMax : Integer;
  //posUL, posLL: Single;
  PixPerPPT         : Single;
  y1, y2            : Integer;
  minPointer, maxPointer: array[0..2] of TPoint; // pointer for min-/max values
  ah                : Integer;          // arrow half
  cl                : TColor;
begin
  inherited ValueChange;
  if isToSmall then exit;
  if not (Visible or (csDesigning in Componentstate)) then Exit;

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

  r := FBarSettings.BarRect;
  r.Left := r.Right;
  r.Right := r.Left + ScaleSettings.sl1;
  r.Top := r.Top;

  y1 := r.Top;
  y2 := r.Bottom - 1;

  PixPerPPT := (((y2 - y1)) / 1000);
  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);
  }
  
  ah := FScaleSettings.sl1 div 2;
  minPointer[0].x := r.Left;
  minPointer[0].y := posMin;
  minPointer[1].x := minPointer[0].x + FScaleSettings.sl1;
  minPointer[1].y := posMin;
  minPointer[2].x := minPointer[1].x;
  minPointer[2].y := posMin + ah;

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

  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;


  FBarSettings.Value := ValueStr;

  if (opUseSectorCol in FBarSettings.Options)
    and (InSector1 or InSector2 or InSector3) then
    FBarSettings.SectorCol := ActSectorCol
  else
    FBarSettings.SectorCol := FBarSettings.Color;

  FBarSettings.PaintBar(TempBmp.Canvas, PPT);

  Canvas.Draw(rBuffer.Left, rBuffer.Top, TempBmp);
  TempBmp.Free;

  if opValue in FOptions then
  begin
    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;

end;


procedure TAbThermometer.ParamChange(Sender: TObject);

begin
  inherited ParamChange(Sender);
  if Assigned(BarSettings) then BarSettings.ppt0 := SignalSettings.GetPPT(0);
  Invalidate;
end;

end.