この発言に対し以下のコメントが寄せられています

#01354　凛              さん　RE:Mouseイベント付きのTrackBar




TTrackBarにOnMouseDownとOnMouseUpがないのでマウスイベント付きのTrackBar
を作りました。
 OnChangeで毎回更新したくなくて、OnMouseUpで一度だけ更新したい場合に使い
ます。例えばTMediaPlayerのPositionと連動させるような用途に向いていると思
います。極基本的な機能しか実装していないのであとは自分でつけて下さい。
ご自由に改変してお使い下さい。
(欲を出して3D化したため長いソースになってしまいました(^^;)

unit YTrackBar;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
Dialogs,
  ExtCtrls;
type
  TYTrackBar = class(TGraphicControl)
  private
    //ゲージ周りのマージン
    lm,tm,bm,rm:integer;
    FMax: integer;
    FMin: integer;
    FGageColor: TColor;
    FThumbColor: TColor;
    FPosition: integer;
    FTW: integer;
    moving: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);
    { 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;
  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;
  end;

procedure Register;

implementation

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

{ TYTrackBar }
const
  //サムの上下マージン
  ttm=1;
  tbm=1;
constructor TYTrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  lm:=4;tm:=8;bm:=10;rm:=4;
  Width:=160;Height:=30;
  FThumbColor:=clBtnFace;
  FGageColor:=clWhite;
  FMax:=100;FMin:=0;FTW:=10;
  GW:=Width-lm-rm;
end;

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

procedure TYTrackBar.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  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
  if moving then
  begin
    moving:=False;
    invalidate;
  end;
  inherited;
end;

procedure TYTrackBar.Paint;
var
  aRect:TRect;
begin
  //まずはゲージの幅を得ておく
  GW:=Width-lm-rm;
  TC:=Trunc(FPosition/(FMax-FMin)*GW)+lm;
  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;
    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.☆☆☆　　かわいいコードにゃ旅をさせよう　いざサンプル蔵へ!!　☆☆☆
                                 99/11/23(火) 15:23 凛(MXB01744)
 


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

Original document by 凛              氏 ID:(MXB01744)

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