この発言は
#00980　凛              さんのMouseイベント付きのTrackBar
に対するコメントです



Minにマイナスをセットしたときの挙動がおかしい等の問題点を修正しました。



unit YTrackBar;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
  ExtCtrls;
type
  TYTrackBar = class(TCustomControl)
    private
    //ゲージ周りのマージン
    lm,tm,bm,rm:integer;
    FMax: integer;
    FMin: integer;
    FGageColor: TColor;
    FThumbColor: TColor;
    FPosition: integer;
    FTW: integer;
    FMoving:boolean;//サムがドラッグ中かどうか
    TC,       //サムのセンタ
    GW,       //ゲージの幅 by pixcel
    preX,     //動き始めたときのマウスの位置
    prePosition,   //動き始めたときのFPosition
    preTC:integer; //ラバーバンド用
    FOnChange: TNotifyEvent;
    procedure setMax(const Value: integer);
    procedure setMin(const Value: integer);
    procedure setGageColor(const Value: TColor);
    procedure setThumbColor(const Value: TColor);
    procedure setPosition(const Value: integer);
    procedure setTW(const Value: integer);
    function ThumbCenter:integer;
    { Private 宣言 }
    protected
    { Protected 宣言 }
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); OverRide;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); OverRide;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); OverRide;
  public
    { Public 宣言 }
    procedure Paint;OverRide;
    constructor Create(AOwner:TComponent);overRide;
    property Moving:boolean read FMoving;
  published
    { Published 宣言 }
    property Max:integer read FMax write setMax;
    property Min:integer read FMin write setMin;
    property ThumbColor: TColor read FThumbColor write setThumbColor;
    property ThumbWidth: integer read FTW write setTW;
    property GageColor :TColor read FGageColor write setGageColor;
    property Position:integer read FPosition write setPosition;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnMouseDown;
    property OnMouseUp;
    property OnMouseMove;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TYTrackBar]);
end;

const
  //サムの上下マージン
  ttm=1;
  tbm=1;

constructor TYTrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  lm:=5;tm:=8;bm:=10;rm:=6;
  Width:=160;Height:=30;
  FThumbColor:=clBtnFace;
  FGageColor:=clWhite;
  FMax:=100;FMin:=0;FTW:=10;
  GW:=Width-lm-rm;
  FMoving:=False;
end;

procedure TYTrackBar.MouseDown(Button: TMouseButton; Shift: TShiftState;
X,
  Y: Integer);
begin
  TC:=ThumbCenter;
  if (x<=TC+FTW div 2) and (x>=TC-FTW div 2) then
  begin
    FMoving :=True;
    preX:=x;
    prePosition:=FPosition;
    preTC:=-1;
  end
  else FMoving:=False;
  inherited;
end;

procedure TYTrackBar.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  TC:=ThumbCenter;
  if moving then
  begin
    if preTC<>-1 then preTC:=TC;
    FPosition:=prePosition+Trunc((X-preX)*(FMax-FMin)/GW);
    if FPosition<FMin then FPosition:=FMin else if FPosition>FMax then
FPosition:=FMax;
    if prePosition<>FPosition then paint;
    inherited;
    if Assigned(FOnChange) then FOnChange(self);
  end;
end;

procedure TYTrackBar.MouseUp(Button: TMouseButton; Shift: TShiftState;
X,
  Y: Integer);
begin
  TC:=ThumbCenter;
  if moving then
  begin
    FMoving:=False;
    invalidate;
  end;
  inherited;
end;

function TYTrackBar.ThumbCenter:integer;
begin
  result:=Trunc((FPosition-FMin)/(FMax-FMin)*GW)+lm;
end;

procedure TYTrackBar.Paint;
var
  aRect:TRect;
begin
  //まずはゲージの幅を得ておく
  GW:=Width-lm-rm;
  TC:=ThumbCenter;
  With Canvas do
  begin
    //ゲージフラット部
    Brush.Color:=FGageColor;
    FillRect(Rect(lm,tm,Width-rm,Height-bm));
    //ゲージ3D黒
    Pen.Width:=2;
    Pen.Color:=clBlack;
    Pen.Mode:=pmCopy;
    MoveTo(lm,Height-bm);
    LineTo(lm,tm);
    LineTo(width-rm,tm);
    //ゲージ3D白
    Pen.Width:=1;
    Pen.Color:=clWhite;
    MoveTo(width-rm+1,tm-1);
    LineTo(width-rm+1,Height-bm+1);
    LineTo(rm,Height-bm+1);
    //サム
    aRect.Left:=TC-FTW div 2;
    aRect.Right:=TC+FTW div 2;
    aRect.Top:=ttm;
    aRect.Bottom:=Height-tbm;
    if moving then
    begin
      // pmNotでラバーバンド
      Brush.style:=bsClear;
      Pen.Mode:=pmNot;
      //前のを消す
      if preTC=-1 then preTC:=TC
      else
      begin
        Rectangle(preTC-FTW div 2,
                  aRect.Top,preTC+FTW div 2,aRect.Bottom);
      end;
      Rectangle(arect);
    end
    else
    begin
      Brush.Color:=clBlack;
      FillRect(aRect);
      aRect:=Rect(aRect.Left+1,aRect.Top+1,
                  aRect.Right-1,aRect.Bottom-2);
      Brush.Color:=FThumbColor;
      FillRect(aRect);
      Pen.Color:=clWhite;
      MoveTo(aRect.Left,aRect.Bottom);
      LineTo(aRect.Left,aRect.Top);
      LineTo(aRect.Right,aRect.Top);
    end;
  end;
end;
procedure TYTrackBar.setGageColor(const Value: TColor);
begin
  FGageColor := Value;
end;
procedure TYTrackBar.setMax(const Value: integer);
begin
  if (value<>FMax) and (value>FMin) then
  begin
    FMax := Value;
    invalidate;
  end;
end;

procedure TYTrackBar.setMin(const Value: integer);
begin
  if (value<>FMin) and (value<FMax) then
  begin
    FMin:=value;
    invalidate;
  end;
end;

procedure TYTrackBar.setPosition(const Value: integer);
begin
  if ( value<>FPosition) then
  begin
    if value>FMax then FPosition:=FMax
    else
      if value<FMin then FPosition:=FMin
      else
      begin
        FPosition := Value;
      end;
    if Assigned(FOnChange) then FOnChange(Self);
    invalidate;
  end;
end;
procedure TYTrackBar.setThumbColor(const Value: TColor);
begin
  FThumbColor := Value;
end;
procedure TYTrackBar.setTW(const Value: integer);
begin
  if (value<>FTW) and (value>1) then
  begin
    FTW := Value;
    lm:=FTW div 2+1;
    rm:=lm;
    invalidate;
  end;
end;
end.
                              2001/07/20(Fri) 09:52am  MXB01744 凛
 


- FDELPHI  MES(16):玉石混淆みんなで作るSample蔵【見本蓄積】 01/07/20 -

Original document by 凛              氏 ID:(MXB01744)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。