abdial.pas

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

unit AbDial;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                 TAbDial (knob, analog Value adjuster)                        }
{                                                                              }
{******************************************************************************}
{        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;

type
  TDialOption = (opBevelOuter, opUnit, opValue, opName1, opName2, opScale,
    opScaleText);
  TDialOptions = set of TDialOption;

  TAbDial = class(TAbAnalogCControl)
  private
    { Private-Deklarationen }
    FBevelOuter: TAbSBevel;
    FBevelValue: TAbSBevel;
    FBevelDial: TAbSBevel;
    FFontValue: TFont;
    FOptions: TDialOptions;
    FScaleSettings: TScaleSettings;
    pCenter: TPoint;
    pPos: TPoint;
    pStartPos: TPoint;
    rKnob: TRect;
    FillCol: TColor;
    pointWidth: Integer;
    MaxpointWidth: Integer;
    BmpDialArea: TBitmap;
    rTemp: TRect;
    sValue, sUnit: TSize;
    rValue: TRect;
    BmpValid: Boolean;
    Init: Boolean;

    oldAngle: Single;                   // old angle
    FRotAngle: Integer;                 // maximum rotation
    FStartAngle: Integer;               // Startposition knob
    Rotation: Single;                   // present rotation


  protected
    { Protected-Deklarationen }
    procedure SetFontValue(Value: TFont);
    procedure SetOptions(Value: TDialOptions);
    procedure MouseSlide(Shift: TShiftState; x, y: Integer; SlideStartPos:
      TPoint); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; x, y:
      Integer);
      override;
    procedure Paint; override;
    procedure ParamChange(Sender: TObject); override;
    procedure ValueChange; override;
  public
    { Public-Deklarationen }
    procedure Loaded; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published-Deklarationen }
    property Font;
    property BevelOuter: TAbSBevel read FBevelOuter write FBevelOuter;
    property BevelValue: TAbSBevel read FBevelValue write FBevelValue;
    property BevelDial: TAbSBevel read FBevelDial write FBevelDial;
    property FontValue: TFont read FFontValue write SetFontValue;
    property Options: TDialOptions read FOptions
    write SetOptions
      default [opBevelOuter, opUnit, opValue, opName1, opName2, opScale,
      opScaleText];
    property ScaleSettings: TScaleSettings read FScaleSettings write
    FScaleSettings;
  end;

implementation

procedure TAbDial.MouseDown(Button: TMouseButton; Shift: TShiftState; x, y:
  Integer);
begin
  oldAngle := AbGetAngle(pCenter, Point(x - rKnob.Left, y - rKnob.Top));
  inherited MouseDown(Button, Shift, x, y);
end;

procedure TAbDial.MouseSlide(Shift: TShiftState; x, y: Integer; SlideStartPos:
  TPoint);
var
  NewAngle          : Single;
  diff              : Single;
begin
  inherited MouseSlide(Shift, x, y, SlideStartPos);

  NewAngle := AbGetAngle(pCenter, Point(x - rKnob.Left, y - rKnob.Top));
  diff := NewAngle - oldAngle;

  if ABS(diff) > 200 then               // check for jumps 360 <> 0
    if (diff > 0) then
      diff := diff - 360
    else
      if (diff < 0) then diff := diff + 360;


  Rotation := Rotation + diff;
  if Rotation > FRotAngle then
    Rotation := FRotAngle
  else
    if Rotation < 0 then Rotation := 0;

  oldAngle := NewAngle;

  Digit := SignalSettings.DigitalFrom +
    Round(SignalSettings.TotalDigit * ((Rotation + 0.0001) / FRotAngle));

end;

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


procedure TAbDial.ValueChange;
var
  Alpha             : Single;
  TempBmp           : TBitmap;
begin
  inherited ValueChange;
  if not (Visible or (csDesigning in Componentstate)) then Exit;
  if BmpValid then
  begin
    rTemp := Rect(0, 0, BmpDialArea.Width, BmpDialArea.Height);
    TempBmp := TBitmap.Create;
    TempBmp.Assign(BmpDialArea);

    Rotation := SignalSettings.GetPPT(Value) * (FRotAngle / 1000);
    Alpha := Rotation;                  // - StartAngle ;

    pPos := AbRotate(pStartPos, pCenter, Alpha, true);


    if Enabled then
    begin
      if Focused then
        AbCircleAtPoint(TempBmp.Canvas, pPos, pointWidth, clBlack, ColorFocus)
      else
        AbCircleAtPoint(TempBmp.Canvas, pPos, pointWidth, clBlack,
          ColorNonFocus);
    end
    else
      AbCircleAtPoint(TempBmp.Canvas, pPos, pointWidth, clBlack, clBtnShadow);
    Canvas.CopyRect(rKnob, TempBmp.Canvas, rTemp);

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

    TempBmp.Free;
  end;

end;

procedure TAbDial.Paint;
var
  r                 : TRect;
  h, w              : Smallint;
  TempBmp           : TBitmap;
  wUnit             : Integer;
begin

  TempBmp := TBitmap.Create;
  TempBmp.Width := Width;
  TempBmp.Height := Height;

  r := TempBmp.Canvas.Cliprect;

  if opBevelOuter in FOptions then
  begin
    FBevelOuter.PaintFilledBevel(TempBmp.Canvas, r);
  end
  else
  begin
    TempBmp.Canvas.Brush.Color := FBevelOuter.Color;
    TempBmp.Canvas.Pen.Color := FBevelOuter.Color;
    TempBmp.Canvas.Rectangle(-1, -1, TempBmp.Width + 1, TempBmp.Height + 1);
  end;

  ScaleSettings.CalcRSize(TempBmp.Canvas, SignalSettings.ValueFrom,
    SignalSettings.ValueTo);

  TempBmp.Canvas.Font := FontValue;
  sValue.cx := TempBmp.Canvas.TextWidth(SignalSettings.ValueSizeStr);
  sValue.cy := TempBmp.Canvas.Textheight(SignalSettings.ValueSizeStr);
  sUnit.cx := TempBmp.Canvas.TextWidth(SignalSettings.ValueUnit);
  sUnit.cy := TempBmp.Canvas.Textheight(SignalSettings.ValueUnit);

  if opValue in FOptions then
  begin
    h := FBevelValue.TotalWidth * 2 + sValue.cy;
    w := sValue.cy div 3;
    if opUnit in Options then
      wUnit := sUnit.cx
    else
      wUnit := 0;
    rValue.Left := r.Left + (r.Right - r.Left - sValue.cx - wUnit - 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(TempBmp.Canvas, rValue);

    TempBmp.Canvas.Font.Color := Font.Color;
    TempBmp.Canvas.Brush.Style := bsClear;
    if opUnit in Options then
      TempBmp.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;


  if (opScaleText in Options) then
  begin
    ScaleSettings.CalcRSize(TempBmp.Canvas, SignalSettings.ValueFrom,
      SignalSettings.ValueTo);
    ScaleSettings.PenW1 := 2;
  end
  else
  begin
    ScaleSettings.PenW1 := 2;
    ScaleSettings.Spacing := 0;
    ScaleSettings.TextW := 0;
    ScaleSettings.TextH := 0;
    ScaleSettings.Text := '';
  end;

  TempBmp.Canvas.Font := Font;
  TempBmp.Canvas.Brush.Style := bsClear;
  rTemp := r;

  if (opName2 in Options) then
  begin
    AbTextOut(TempBmp.Canvas, Width div 2, rTemp.Bottom, SignalSettings.Name2,
      toBotCenter);
    rTemp.Bottom := rTemp.Bottom - TempBmp.Canvas.Textheight('X');
  end;
  if (opName1 in Options) then
  begin
    AbTextOut(TempBmp.Canvas, Width div 2, rTemp.Bottom, SignalSettings.Name1,
      toBotCenter);
    rTemp.Bottom := rTemp.Bottom - TempBmp.Canvas.Textheight('X');
  end;

  if (opScale in Options) then
  begin
    ScaleSettings.DialScala(TempBmp.Canvas, r, 225, 270);
    pCenter := ScaleSettings.cp;
    rKnob := r;
    AbBorder(rKnob, ScaleSettings.sl1 + 4);
  end
  else
  begin
    pCenter.x := r.Left + (r.Right - r.Left) div 2;
    pCenter.y := r.Top + (r.Right - r.Left) div 2;
    rKnob := r;
    rKnob.Bottom := r.Top + (r.Right - r.Left);
  end;


  SlideRect := rKnob;

  FBevelDial.PaintRoundBevel(TempBmp.Canvas, rKnob, 0, 0);

  pointWidth := (rKnob.Right - rKnob.Left) div 13;
  if pointWidth < 2 then pointWidth := 2;
  if pointWidth > MaxpointWidth then pointWidth := MaxpointWidth;

  if ((rKnob.Right - rKnob.Left) > 10) then
  begin
    BmpValid := true;
    BmpDialArea.Width := (rKnob.Right - rKnob.Left);
    BmpDialArea.Height := (rKnob.Right - rKnob.Left);
    rTemp := Rect(0, 0, BmpDialArea.Width, BmpDialArea.Height);
    BmpDialArea.Canvas.CopyRect(rTemp, TempBmp.Canvas, rKnob);
  end
  else
    BmpValid := false;


  pCenter.x := BmpDialArea.Width div 2;
  pCenter.y := BmpDialArea.Width div 2;

  pStartPos.x := pCenter.x;
  pStartPos.y := rTemp.Top + pointWidth;
  pStartPos := AbRotate(pStartPos, pCenter, 225, true);

  Canvas.Draw(0, 0, TempBmp);
  TempBmp.Free;

  ValueChange;
end;

procedure TAbDial.SetOptions(Value: TDialOptions);
begin
  FOptions := Value;
  ParamChange(self);
end;

constructor TAbDial.Create(AOwner: TComponent);
begin
  BeginUpdate;
  inherited Create(AOwner);
  //if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  Init := false;
  Width := 113;
  Height := 161;

  FOptions := [opBevelOuter, opUnit, opValue, opName1, opName2, opScale,
    opScaleText];

  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;

  FBevelDial := TAbSBevel.Create;
  FBevelDial.ColorShadowFrom := clBtnHighlight;
  FBevelDial.ColorShadowTo := clBtnShadow;
  FBevelDial.isRound := true;
  FBevelDial.BevelLine := blOuter;
  FBevelDial.PenColor := clBtnShadow;
  FBevelDial.Spacing := 1;

  FScaleSettings := TScaleSettings.Create;
  FScaleSettings.Font.Size := 8;
  FillCol := clGreen;
  MaxpointWidth := 6;

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

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

  isCircle := true;

  Value := 10;


  FRotAngle := 270;
  FStartAngle := 225;

  Init := true;

  if (csDesigning in Componentstate) then Loaded;

end;

procedure TAbDial.Loaded;
begin
  inherited Loaded;

  FFontValue.OnChange := ParamChange;


  FBevelOuter.OnChange := ParamChange;


  FBevelValue.OnChange := ParamChange;


  FBevelDial.OnChange := ParamChange;


  FScaleSettings.OnChange := ParamChange;
  EndUpdate;
end;

destructor TAbDial.Destroy;
begin
  FBevelOuter.Free;
  FBevelValue.Free;
  FBevelDial.Free;
  FScaleSettings.Free;
  FFontValue.Free;
  BmpDialArea.Free;
  inherited Destroy;
end;

procedure TAbDial.ParamChange(Sender: TObject);
begin
  inherited ParamChange(Sender);
  Invalidate;
end;

end.