abhslide.pas

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

unit AbHSlide;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                 TAbHSlider (poti, 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,
  Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, extctrls,
  _GClass,
  _AbProc;

type
  THSliderOption = (opBevelOuter, opName1, opName2, opScaleText);
  THSliderOptions = set of THSliderOption;

  TAbHSlider = class(TAbAnalogCControl)
  private
    { Private-Deklarationen }
    FBevelOuter: TAbSBevel;

    FButtonSize: Integer;
    FColorTrench: TColor;
    FOptions: THSliderOptions;
    FScaleSettings: TScaleSettings;
    isToSmall : Boolean;

    BtnHeight: Integer;
    BtnWidth: Integer;
    BtnDir: Boolean;
    pCenter: TPoint;
    FillCol: TColor;
    MaxpointWidth: Integer;
    BmpSliderArea: TBitmap;
    BmpValid: Boolean;
    rTemp: TRect;
    rSlide: TRect;
    Init: Boolean;
    rScale: TRect;
    rMove: TRect;

  protected
    { Protected-Deklarationen }
    procedure SetButtonSize(Value: Integer);
    procedure SetColorTrench(Value: TColor);
    procedure SetOptions(Value: THSliderOptions);
    procedure MouseSlide(Shift: TShiftState; x, y: Integer; SlideStartPos:
      TPoint); 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 EnableMouseJump;
    property Font;
    property BevelOuter: TAbSBevel read FBevelOuter write FBevelOuter;
    property ButtonSize: Integer read FButtonSize write SetButtonSize;
    property ColorTrench: TColor read FColorTrench write SetColorTrench;
    property Options: THSliderOptions read FOptions write SetOptions;
    property ScaleSettings: TScaleSettings read FScaleSettings write
    FScaleSettings;
  end;

implementation

procedure TAbHSlider.SetButtonSize(Value: Integer);
begin
  if FButtonSize <> Value then
  begin
    FButtonSize := Value;
    if FButtonSize > Width then FButtonSize := Width;
    if FButtonSize < 18 then FButtonSize := 18;
    ParamChange(self);
  end;
end;

procedure TAbHSlider.SetColorTrench(Value: TColor);
begin
  FColorTrench := Value;
  ParamChange(self);
end;

procedure TAbHSlider.MouseSlide(Shift: TShiftState; x, y: Integer;
  SlideStartPos: TPoint);
var
  xPos              : Integer;
begin
  inherited MouseSlide(Shift, x, y, SlideStartPos);

  xPos := x;
  if xPos < rSlide.Left then xPos := rSlide.Left;
  if xPos > rSlide.Right then xPos := rSlide.Right;

  xPos := xPos - rSlide.Left;
  Update;
  Digit := SignalSettings.DigitalFrom + Round((xPos) * (SignalSettings.TotalDigit
    / (rSlide.Right - rSlide.Left)));
end;


procedure TAbHSlider.ValueChange;
var
  TempBmp           : TBitmap;
  PosSlider         : Integer;
begin
  inherited ValueChange;
  if isToSmall then Exit;

  if not (Visible or (csDesigning in Componentstate)) then Exit;

  if BmpValid then
  begin
    rTemp := Rect(0, 0, BmpSliderArea.Width, BmpSliderArea.Height);
    TempBmp := TBitmap.Create;
    TempBmp.Assign(BmpSliderArea);

    PosSlider := Round(BtnWidth div 2 + ((rSlide.Right - rSlide.Left) /
      SignalSettings.TotalDigit) * (Digit - SignalSettings.DigitalFrom));
    pCenter := Point(PosSlider, TempBmp.Height div 2);

    if EnableMouseJump then
    begin
      SlideRect := rMove;
    end
    else
    begin
      SlideRect.Left := rMove.Left + pCenter.x - Round(ButtonSize * 0.2) + 1;
      SlideRect.Right := SlideRect.Left + Round(ButtonSize * 0.4) + 1;
    end;

    if Enabled then
    begin
      if Focused then
        AbThumb(TempBmp.Canvas, pCenter, ButtonSize, 0, BtnDir, ColorFocus)
      else
        AbThumb(TempBmp.Canvas, pCenter, ButtonSize, 0, BtnDir, ColorNonFocus);
    end
    else
      AbThumb(TempBmp.Canvas, pCenter, ButtonSize, 0, BtnDir, clBtnShadow);


    Canvas.CopyRect(rMove, TempBmp.Canvas, TempBmp.Canvas.Cliprect);


    TempBmp.Free;
  end;

end;

procedure TAbHSlider.Paint;
var
  r                 : TRect;
  w                 : Smallint;
  TempBmp           : TBitmap;
begin
  if (csLoading in Componentstate) then Exit;
  if Painting then Exit;
  Painting := true;

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

  r := ClientRect;
  Canvas.Brush.Style := bsClear;


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

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

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

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

  isToSmall := (r.right - r.left < 2) or (r.Bottom - r.top < 2);
  if isToSmall then begin
    Canvas.Draw(0, 0, TempBmp);
    TempBmp.Free;
    Exit;
  end;

  if (opScaleText in Options) then
  begin
    ScaleSettings.CalcHSize(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;

  if FButtonSize > Width then FButtonSize := Width;
  if FButtonSize < 18 then FButtonSize := 18;
  if BtnDir then
  begin
    BtnHeight := Round(ButtonSize * 0.4);
    BtnWidth := ButtonSize;
  end
  else
  begin
    BtnHeight := ButtonSize;
    BtnWidth := Round(ButtonSize * 0.4);
  end;

  w := ScaleSettings.TextW div 2;
  if w < BtnWidth div 2 then w := BtnWidth div 2;
  r.Left := r.Left + w;
  r.Right := r.Right - w;


  rTemp := r;

  rScale := r;
  rScale.Top := rScale.Top + ScaleSettings.TextH div 3;

  ScaleSettings.FPosLeftTop := true;
  ScaleSettings.HorizScala(TempBmp.Canvas, rScale);

  rSlide := r;
  rSlide.Left := rSlide.Left - 1;
  rSlide.Right := rSlide.Right + 1;
  rSlide.Top := rScale.Top + 4 + ScaleSettings.TextH div 2 +
    ScaleSettings.Spacing + ScaleSettings.sl1;
  rSlide.Bottom := rSlide.Top + 5;


  rMove.Top := rSlide.Top - BtnHeight div 2 + 2;
  rMove.Bottom := rMove.Top + BtnHeight + 1;
  rMove.Left := rSlide.Left - BtnWidth div 2;
  rMove.Right := rSlide.Right + BtnWidth div 2;
  SlideRect := rMove;


  rScale := r;
  rScale.Top := rSlide.Bottom + 4;

  ScaleSettings.FPosLeftTop := false;
  ScaleSettings.HorizScala(TempBmp.Canvas, rScale);

  Frame3D(TempBmp.Canvas, rSlide, clBtnShadow, clBtnHighlight, 1);
  TempBmp.Canvas.Brush.Color := ColorTrench;
  TempBmp.Canvas.Pen.Color := ColorTrench;
  TempBmp.Canvas.Rectangle(rSlide.Left, rSlide.Top, rSlide.Right,
    rSlide.Bottom);

  BmpSliderArea.Width := (rMove.Right - rMove.Left);
  BmpSliderArea.Height := (rMove.Bottom - rMove.Top);
  rTemp := Rect(0, 0, BmpSliderArea.Width, BmpSliderArea.Height);

  BmpSliderArea.Canvas.CopyRect(rTemp, TempBmp.Canvas, rMove);


  BmpValid := true;

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

  Painting := false;
  ValueChange;
end;

procedure TAbHSlider.SetOptions(Value: THSliderOptions);
begin
  FOptions := Value;
  ParamChange(self);
end;

constructor TAbHSlider.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  //if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  Init := false;
  Width := 313;
  Height := 105;
  isToSmall := false;

  FOptions := [opBevelOuter, opName1, opName2, opScaleText];


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

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

  FillCol := clGreen;
  MaxpointWidth := 6;

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

  Value := 10;
  FButtonSize := 30;
  BtnHeight := ButtonSize;
  BtnWidth := Round(ButtonSize * 0.4);

  FColorTrench := clGreen;
  BtnDir := false;

  EnableMouseJump := true;

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

end;



procedure TAbHSlider.Loaded;
begin

  FBevelOuter.OnChange := ParamChange;


  FScaleSettings.OnChange := ParamChange;
  inherited;
end;


destructor TAbHSlider.Destroy;
begin
  FBevelOuter.Free;
  FScaleSettings.Free;
  BmpSliderArea.Free;
  inherited Destroy;
end;


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

end.