近頃「ぐりぐり」がはやってるようなので、あるソフトに搭載予定のぐりぐり
ぼたん、もとい(^^;　'TDialBtn'コンポーネントをアップします。

カメラやビデオの、シャッターボタンと、セレクタースイッチのコンボをイ
メージして作りました。センターボタンでは、OnClick イベントが、セレク
ター部では、OnChange イベントが発生します、追加したプロパティはご覧に
なればわかるでしょう。(^^)　なんかありましたら、8番あたりでどうぞ。

でわでわ。~＼(^^)

                                 Yukimi Sake GHE01746@nifty.ne.jp

unit DialBtn;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,ExtCtrls,
  Math;
type
  TDialBtn = class(TPaintBox)
  private
    FDivide,FCount,FNotchLen,PrevCount:integer;
    FNotchClr:TColor;
    origin:Tpoint;
    AryS,AryC:array[0..23] of extended ;
    ox,oy,r:extended;
    drag,inButton,init:Boolean;
    FOnChange: TNotifyEvent;
  protected
    procedure MouseDown( Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override ;
    procedure MouseUp( Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X,
      Y: Integer); override;
    procedure Paint;override;
    procedure DrawGuage(N:integer;R,L:extended;canvas:TCanvas);
    procedure Change; dynamic;
    property Canvas;
  public
    constructor Create(AOwner: TComponent); override;
  published
    procedure Click;override;
    property Color default clBtnFace;
    property Width default 64;
    property Height default 64;
    property NDivide:integer read Fdivide write FDivide;
    property Position :integer read FCount write Fcount Default 0;
    property NotchLength : integer read FNotchLen write FNotchLen
              Default 4;
    property NotchColor :TColor read FNotchClr write FNotchClr
              default clBlack;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;

procedure Register;

implementation

constructor TDialBtn.Create(AOwner: TComponent);
begin
  inherited create(AOwner);
  Color := clBtnFace;
  Width := 64 ;
  Height := 64;
  FDivide := 24;
  FCount := 0;
  FNotchLen := 4;
  FNotchClr := clBlack;
  inButton := false;
  init := true;
end;

procedure TDialBtn.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TDialBtn.Click;
begin
if  inButton then
  inherited Click;
end;

procedure TdialBtn.Paint;
var
  i,n:integer;
begin
  if Fcount <> PrevCount then
  begin
    PrevCount := Fcount mod FDivide;
  end;
  with Self.Canvas do
  begin
    ox := width/2 ; oy := height/2; r := width/2-8;
  for i := 0 to FDivide-1 do
    sincos(i* Pi/FDivide,AryS[i],AryC[i]) ;
    Brush.Style:= bsSolid;
    brush.Color := Color;
    ellipse( 4,4,width-4,height-4);
    pen.Width:=1;
    pen.Color:= cl3DDkShadow;
    Arc(4,4,width-4,height-4,0,0,0,0);
    Arc(width div 4+2,height div 4+2,width div 4*3-2,height div 4*3-2,
        0,0,0,0);
    pen.Color:= clWhite;
    Arc(5,5,width-5,height-5,width,0,0,height);
    Arc(6,6,width-6,height-6,width,0,0,height);
    Arc(width div 4+1,height div 4+1,width div 4*3-1,height div 4*3-1,
        0,width,height,0);
    Arc(width div 4+3,height div 4+3,width div 4*3-3,height div 4*3-3,
        width,0,0,height);
    pen.Color:= clBtnShadow;
    Arc(5,5,width-5,height-5,0,width,height,0);
    Arc(6,6,width-6,height-6,0,width,height,0);
    Arc(width div 4+1,height div 4+1,width div 4*3-1,height div 4*3-1,
        width,0,0,height);
    Arc(width div 4+3,height div 4+3,width div 4*3-3,height div 4*3-3,
        0,width,height,0);
    canvas.Pen.Color := clBlack;
    canvas.Pen.width := 1;
    for n:= 0 to FDivide-1 do
    begin
      DrawGuage(n,r+5,3,canvas);
    end;
    canvas.Pen.Color := FNotchClr;
    DrawGuage(PrevCount,r+1,-FNotchLen,canvas);
  end;
end;

procedure TDialBtn.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  dx,dy,etha:extended;
begin
  inButton := false;
  with Self.Canvas do
  begin
    dx := X-width/2; dy := Y-height/2 ;
    etha := sqr(dx) + sqr(dy);
    if sqr( width/4-2) >= etha then
    begin
      pen.Color := clBtnHighlight;
      brush.Color := clBtnHighlight;
      brush.Style := bsSolid;
      ellipse(width div 4+3,height div 4+3,width div 4*3-3,height
              div 4*3-3);
      inButton := true;
    end
    else if  sqr(width/2-2) >= etha then
    begin
      origin.x:= round(dx); origin.y:= round(dy); drag := true;
    end;
  end;
end;

procedure TDialBtn.MouseUp( Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  PrevCount := FCount;
  drag := false;
  Self.refresh;
end;

procedure TDialBtn.MouseMove( Shift: TShiftState; X,
  Y: Integer);
var
  theta:extended;
  n:Integer;
begin
  if drag then
  begin
    theta :=ArcTan2(origin.y,origin.x)-Arctan2(Y-height/2,X-width/2);
    n := round(Theta/(2*pi/FDivide));
    canvas.Pen.width := 1;
    canvas.Pen.Color := FNotchClr;
    canvas.Pen.Mode := pmNotXor;
    DrawGuage(FCount,r+1,-FNotchLen,Canvas);//前の線消去
    //-FDivide/2 < FCount <= FDivide/2 にする
    FCount := (n+PrevCount) mod FDivide;
    if (Fcount > NDivide/2) or (FCount <= -NDivide/2) then
      FCount := Fcount - NDivide*round(FCount/abs(FCount));
    DrawGuage(FCount,r+1,-FNotchLen,Canvas);//改めて線描画
    canvas.Pen.Mode := pmCopy;
    Change;
  end;
end;

procedure TDialBtn.DrawGuage(N:integer;R,L:extended;canvas:TCanvas);
var S,C:extended;
begin
  sincos(N*2*pi/FDivide,S,C);
  canvas.moveto(round(ox+r*C),round(oy-r*S)) ;
  canvas.LineTo(round(ox+(R+L)*C),round(oy-(R+L)*S));
end;

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

end.

Original document by 雪見酒          氏 ID:(GHE01746)

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