abvslide.pas

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

unit AbVSlide;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                 TAbVSlider (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
  TVSliderOption = (opBevelOuter, opUnit, opValue, opName1, opName2,
    opScaleText);
  TVSliderOptions = set of TVSliderOption;

  TAbVSlider = class(TAbAnalogCControl)
  private
    { Private-Deklarationen }
    FBevelOuter: TAbSBevel;
    FBevelValue: TAbSBevel;
    FButtonSize: Integer;
    FColorTrench: TColor;
    BtnHeight: Integer;
    BtnWidth: Integer;
    BtnDir: Boolean;
    FFontValue: TFont;
    FOptions: TVSliderOptions;
    FScaleSettings: TScaleSettings;
    isToSmall : Boolean;
    pCenter: TPoint;
    FillCol: TColor;
    MaxpointWidth: Integer;
    BmpSliderArea: TBitmap;
    rTemp: TRect;
    sValue: TSize;
    sUnit: TSize;
    rValue: TRect;
    rSlide: TRect;
    BmpValid: Boolean;
    Init: Boolean;
    rScale: TRect;
    rMove: TRect;

  protected
    { Protected-Deklarationen }
    procedure SetButtonSize(Value: Integer);
    procedure SetColorTrench(Value: TColor);
    procedure SetFontValue(Value: TFont);
    procedure SetOptions(Value: TVSliderOptions);
    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 BevelValue: TAbSBevel read FBevelValue write FBevelValue;
    property ButtonSize: Integer read FButtonSize write SetButtonSize default
    30;
    property ColorTrench: TColor read FColorTrench write SetColorTrench default
    clGreen;
    property FontValue: TFont read FFontValue write SetFontValue;
    property Options: TVSliderOptions read FOptions
    write SetOptions
      default [opBevelOuter, opUnit, opValue, opName1, opName2, opScaleText];
    property ScaleSettings: TScaleSettings read FScaleSettings write
    FScaleSettings;
  end;

implementation

procedure TAbVSlider.SetButtonSize(Value: Integer);
begin
  if FButtonSize <> Value then
  begin
    FButtonSize := Value;
    if FButtonSize > Width then FButtonSize := Width;
    if FButtonSize < 18 then FButtonSize := 18;
    Change;
  end;
end;

procedure TAbVSlider.SetColorTrench(Value: TColor);
begin
  FColorTrench := Value;
  Change;
end;

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

  yPos := y;
  if yPos < rSlide.Top then yPos := rSlide.Top;
  if yPos > rSlide.Bottom then yPos := rSlide.Bottom;

  yPos := rSlide.Bottom - yPos;
  Update;
  Digit := SignalSettings.DigitalFrom + Round((yPos) * (SignalSettings.TotalDigit
    / (rSlide.Bottom - rSlide.Top)));
end;

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


procedure TAbVSlider.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(TempBmp.Height - BtnHeight div 2 - 1 - ((rSlide.Bottom -
      rSlide.Top) /
      SignalSettings.TotalDigit) * (Digit - SignalSettings.DigitalFrom));

    pCenter := Point(TempBmp.Width div 2, PosSlider);

    if EnableMouseJump then
    begin
      SlideRect := rMove;
    end
    else
    begin
      SlideRect.Top := rMove.Top + pCenter.y - Round(ButtonSize * 0.2);
      SlideRect.Bottom := rMove.Top + pCenter.y + Round(ButtonSize * 0.2);
    end;

    pMouseOld.x := pCenter.x + rMove.Top;
    pMouseOld.y := pCenter.y + rMove.Left;

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

    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 TAbVSlider.Paint;
var
  r                 : TRect;
  h, w              : Smallint;
  TempBmp           : TBitmap;
  wUnit             : Integer;
begin


  r := ClientRect;


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

  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.CalcHSize(TempBmp.Canvas, SignalSettings.ValueFrom,
    SignalSettings.ValueTo);

  TempBmp.Canvas.Font := FFontValue;

  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;

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

  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.CalcSize(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;
  h := ScaleSettings.TextH div 3;

  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;

  if h < BtnHeight div 2 then h := BtnHeight div 2;

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

  rMove.Top := r.Top - BtnHeight div 2;
  rMove.Bottom := r.Bottom + BtnHeight div 2;
  rMove.Left := r.Left + (r.Right - r.Left) div 2 - ButtonSize div 2;
  rMove.Right := rMove.Left + ButtonSize + 1;

  SlideRect := rMove;

  rTemp := r;

  w := (r.Right - r.Left - ScaleSettings.TotalWidth * 2 - 4) div 2;

  rScale := r;
  rScale.Right := rScale.Left + w - 5 + ScaleSettings.TotalWidth;
  rScale.Top := rScale.Top + 1;
  rScale.Bottom := rScale.Bottom - 1;

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

  rSlide := r;
  rSlide.Left := r.Left + w + ScaleSettings.TotalWidth;
  rSlide.Right := rSlide.Left + 5;

  rScale := r;
  rScale.Left := rScale.Left + w + 5 + 4 + ScaleSettings.TotalWidth;
  rScale.Top := rScale.Top + 1;
  rScale.Bottom := rScale.Bottom - 1;

  ScaleSettings.FPosLeftTop := false;
  ScaleSettings.VertiScala(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;


  ValueChange;
end;

procedure TAbVSlider.SetOptions(Value: TVSliderOptions);
begin
  FOptions := Value;
  Change;
end;

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

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

  MaxPosDeviation := 5;

  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;

  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;

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

  Value := 10;
  FButtonSize := 30;
  FColorTrench := clGreen;
  BtnDir := true;

  EnableMouseJump := true;

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

end;

procedure TAbVSlider.Loaded;
begin
  inherited Loaded;

  FFontValue.OnChange := ParamChange;

  FScaleSettings.Change;
  FScaleSettings.OnChange := ParamChange;


  FBevelOuter.OnChange := ParamChange;

  FBevelValue.OnChange := ParamChange;

  EndUpdate;

end;

destructor TAbVSlider.Destroy;
begin
  FFontValue.Free;
  FBevelOuter.Free;
  FBevelValue.Free;
  FScaleSettings.Free;
  BmpSliderArea.Free;
  inherited Destroy;
end;

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

end.