abgeardial.pas

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

unit AbGearDial;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                 TAbGearDial (knob, analog Value adjuster)                    }
{                                                                              }
{******************************************************************************}
{        e-Mail: [e-mail] , Web: http://www.abaecker.de             }
{------------------------------------------------------------------------------}
{          (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

  TAbGearDial = class(TAbAnalogCControl)
  private
    { Private-Deklarationen }
    FBevelGearDial: TAbSBevel;
    pCenter: TPoint;
    pPos: TPoint;
    pStartPos: TPoint;
    rKnob: TRect;
    FillCol: TColor;
    pointWidth: Integer;
    MaxpointWidth: Integer;
    BmpGearDialArea: TBitmap;
    rTemp: TRect;
    BmpValid: Boolean;
    Init: Boolean;

    ClipRgn: HRgn;                      {Cliparea}

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

    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    { Protected-Deklarationen }
    procedure SetRotAngle(Value: Integer);
    procedure SetStartAngle(Value: Integer);
    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;
    procedure CreateWnd; Override;
    procedure WMEraseBkgnd(var Message: TWMERASEBKGND); message WM_ERASEBKGND;
  public
    { Public-Deklarationen }
    procedure Loaded; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published-Deklarationen }
    property RotAngle: Integer read FRotAngle write SetRotAngle;
    property StartAngle: Integer read FStartAngle write SetStartAngle;
    property BevelGearDial: TAbSBevel read FBevelGearDial write FBevelGearDial;
  end;

implementation

procedure TAbGearDial.WMEraseBkgnd(var Message: TWMERASEBKGND);
begin
   if (csDesigning in Componentstate) then inherited;
end;

procedure TAbGearDial.CreateWnd;
begin
  inherited CreateWnd;
  SetWindowLong(Parent.Handle, GWL_STYLE,
    GetWindowLong(Parent.Handle, GWL_STYLE) and not WS_CLIPCHILDREN);
end;

procedure TAbGearDial.WMSize(var Message: TWMSize);
begin
  inherited;
   { create the round clip-region }
end;

procedure TAbGearDial.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 TAbGearDial.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 TAbGearDial.SetRotAngle(Value: Integer);
begin
  if FRotAngle <> Value then
  begin
    FRotAngle := Value;
    ValueChange;
  end;
end;

procedure TAbGearDial.SetStartAngle(Value: Integer);
begin
  if FStartAngle <> Value then
  begin
    FStartAngle := Value;
    ParamChange(self);
  end;
end;


procedure TAbGearDial.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, BmpGearDialArea.Width, BmpGearDialArea.Height);
    TempBmp := TBitmap.Create;
    TempBmp.Assign(BmpGearDialArea);

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

    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);

      TempBmp.Transparent := true;

    if (csPaintCopy in ControlState) then begin
      DeleteObject(ClipRgn);
      ClipRgn := CreateEllipticRgn(left, top, left+Width, top+Height);
      SelectObject(canvas.Handle, ClipRgn);
    end;

    Canvas.CopyRect(rKnob, TempBmp.Canvas, rTemp);

    TempBmp.Free;
  end;
end;


procedure TAbGearDial.Paint;
var
  r                 : TRect;
  TempBmp           : TBitmap;
begin
  if (csLoading in Componentstate) then Exit;

  if Width <> Height then
  begin                                 // adjust width = height
    if Width > Height then Height := Width;
    if Width < Height then Width := Height;
    Exit;
  end;

   { create the round clip-region }
  DeleteObject(ClipRgn);
  ClipRgn := CreateEllipticRgn(0, 0, Width, Height);

  SetWindowRgn(WindowHandle, ClipRgn, true);

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

  r := TempBmp.Canvas.Cliprect;


  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);


  SlideRect := rKnob;

  FBevelGearDial.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;
    BmpGearDialArea.Width := (rKnob.Right - rKnob.Left);
    BmpGearDialArea.Height := (rKnob.Right - rKnob.Left);
    rTemp := Rect(0, 0, BmpGearDialArea.Width, BmpGearDialArea.Height);
    BmpGearDialArea.Canvas.CopyRect(rTemp, TempBmp.Canvas, rKnob);
  end
  else
    BmpValid := false;


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

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

  TempBmp.Transparent := true;
  TempBmp.TransparentColor := clWhite;

  if (csPaintCopy in ControlState) then begin
    DeleteObject(ClipRgn);
    ClipRgn := CreateEllipticRgn(left, top, left+Width, top+Height);
    SelectObject(canvas.Handle, ClipRgn);
  end;

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

  ValueChange;
end;

constructor TAbGearDial.Create(AOwner: TComponent);
begin
  BeginUpdate;
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csOpaque] ;
  //if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  Init := false;

  SetBounds(0, 0, 100, 100);

  oldAngle := 0;
  Rotation := 0;
  FRotAngle := 3600;

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

  FillCol := clGreen;
  MaxpointWidth := 6;

  BmpGearDialArea := TBitmap.Create;
  BmpGearDialArea.Height := 1;
  BmpGearDialArea.Width := 1;
  BmpGearDialArea.Transparent := true;

  isCircle := true;

  Value := 0;
  Init := true;
  if (csDesigning in Componentstate) then Loaded;

end;

procedure TAbGearDial.Loaded;
begin
  inherited Loaded;
  FBevelGearDial.OnChange := ParamChange;
  EndUpdate;
end;

destructor TAbGearDial.Destroy;
begin
  FBevelGearDial.Free;
  BmpGearDialArea.Free;
  DeleteObject(ClipRgn);
  inherited Destroy;
end;

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

end.