第27章 アップダウン、スピン、ツールチップ、ドラグリスト

引き続き、比較的小さなコモンコントロールについて調べていく。 アップダウンコントロールは単独で用いられることはほとんどなく、エディットコントロールと組み合わせてスピンコントロールとして使われているのがほとんどであろう。ツールチップは、VCLでは独自に実装されているが、ここではコモンコントロールとしての使い方を調べることにする。ドラグリストボックスは、ユーザがマウスで項目をドラグして項目を並べ替えることができるリストボックスである。 VCLのリストボックスもこれができるが、CommCtrl.pas の関数を使って単選択リストボックスをドラグリストボックスにすることができる。

27−0 この章の内容

第27章 アップダウン、スピン、ツールチップ、ドラグリスト
27−1 アップダウンコントロールをコードで作る
27−2 TAPIUpDown クラス
27−3 スピンコントロールのラッパークラス
27−4 ツールチップをコードでつくる
27−5 TToolTip クラス
27−6 ドラグリストをコードでつくる
27−7 TAPIDragList クラス
26−8 まとめ


| arrw18c.gif 前の章へ | 総目次へ | 次の章へ arrw18d.gif

27−1 アップダウンコントロールをコードで作る

アップダウンコントロールは、スクロールバーからバーを取り去って上下の矢印部分だけを残したものだ。 一定の範囲の数値をユーザーが簡単に入力できるように設計されている。 アップダウンはまた、バディウィンドウとよばれるエディットコントロールと一体になって、スピンコントロールを構成する部品ともなる。 一般には、 アップダウンだけで使うより、スピンコントロールとして使われている場合が多い。 この節では、アップダウンコントロールの作成と制御方法を調べ、 アップダウンコントロールをコードで作成してテストするプログラムを作ろう。 次節以降で、アップダウンコントロールのラッパークラスを作成し、さらにエディットコントロールと一体となるスピンコントロールのラッパークラスを作成しよう。

アップダウンコントロールは、CreateWindowEx( ) または CreateWindow( )UPDOWN_CLASS をクラス名に指定して作成する。

const
  UPDOWN_CLASS = 'msctls_updown32';

しかし、CommCtrl.pas には、CreateUpDownControl( ) という便利な作成関数が定義されていて、これを使って作成する方が容易である。

   function CreateUpDownControl(dwStyle: Longint; 
                           X, Y, CX, CY: Integer;
                                hParent: HWND;  
                                    nID: Integer; 
                                  hInst: THandle; 
                                 hBuddy: HWND;
                   nUpper, nLower, nPos: Integer): HWND; stdcall;

dwStyle には、一般的なウィンドウスタイルである WS_CHILD(必須!)、WS_BORDERWS_VISIBLE などの他に以下のスタイルを含めることができる。

const
  UDS_WRAP                = $0001; // 範囲を越えたとき値を折り返す
  UDS_SETBUDDYINT         = $0002; // 位置の変更をバディウィンドウに自動的に表示する
  UDS_ALIGNRIGHT          = $0004; // アップダウンをバディウィンドウの右に配置
  UDS_ALIGNLEFT           = $0008; // アップダウンをバディウィンドウの左に配置
  UDS_AUTOBUDDY           = $0010; // Zオーダが一つ前のウィンドウを自動的にバディとする
  UDS_ARROWKEYS           = $0020; // 矢印キーで現在位置を変更できる(スピンコントロールの場合)
  UDS_HORZ                = $0040; // 水平アップダウンにする
  UDS_NOTHOUSANDS         = $0080; // 三桁ごとの区切り記号を表示しない(スピンコントロールの場合)

X, Y には、このコントロールの左上隅の座標、CX, CY には幅と高さを設定する。 hParent は親ウィンドウのハンドルを、nID にはコントロールIDを指定する。 hInst はプログラムのインスタンスハンドル、Delphi の場合は常に hInstance を指定する。 hBuddy にはバディウィンドウのハンドルを指定する。 単独のアップダウンの場合はゼロを指定する。 バディウィンドウは、アップダウン作成後もメッセージを送って設定できる。 nUpper, nLower, nPos は、入力数値の最大値と最小値、および初期値を指定する。

作成後に以下のメッセージを SendMessage( ) を使って送ることにより、 コントロールの動作を制御する。

const  
  UDM_SETRANGE            = WM_USER+101; // 最小値と最大値の設定
  UDM_GETRANGE            = WM_USER+102; // 最小値と最大値の取得
  UDM_SETPOS              = WM_USER+103; // 現在位置の設定
  UDM_GETPOS              = WM_USER+104; // 現在位置の取得
  UDM_SETBUDDY            = WM_USER+105; // スピンボタンのバディウィンドウの設定
  UDM_GETBUDDY            = WM_USER+106; // スピンボタンのバディウィンドウの取得
  UDM_SETACCEL            = WM_USER+107; // アクセル情報の設定
  UDM_GETACCEL            = WM_USER+108; // アクセル情報の取得
  UDM_SETBASE             = WM_USER+109; // 基数(10進か16進)の設定
  UDM_GETBASE             = WM_USER+110; // 基数の取得

Win32.hlp でこれらのメッセージを調べよう。

UDM_SETRANGE 
  wParam = 0; 
  lParam = (LPARAM) MAKELONG( nUpper,nLower); 

UDM_GETRANGE 
  wParam = 0; 
  lParam = 0; 

選択範囲の設定と取得メッセージである。UDM_SETRANGEuUppernLower に設定できる値は以下のようになっている。

const
  UD_MAXVAL  = $7fff;      // 32767
  UD_MINVAL  = -UD_MAXVAL;

つまり、-32767 から 32767 までの範囲を設定できる。 UDM_GETRANGE の戻り値の上位ワードが最小値、下位ワードが最大値である。

UDM_SETPOS 
  wParam = 0; 
  lParam = (LPARAM) MAKELONG((short) nPos, 0);	 

UDM_GETPOS 
  wParam = 0; 
  lParam = 0; 

現在位置の設定・取得メッセージである。 UDM_SETPOSlParam は上位ワードがゼロなので、パスカルでは MakeLong を使わずに直接 nPos を設定できる。 UDM_GETPOS の戻り値の下位ワードが現在位置に相当する。 上位ワードにはバディウィンドウがないなどの理由でエラーが起こるとゼロ以外に設定される。

UDM_SETBUDDY 
  wParam = (WPARAM) (HWND) hwndBuddy; 
  lParam = 0; 


UDM_GETBUDDY 
  wParam = 0; 
  lParam = 0; 

バディウィンドウのハンドルの設定・取得メッセージである。

UDM_SETACCEL 
  wParam = (WPARAM) nAccels; 
  lParam = (LPARAM) (LPUDACCEL) aAccels; 

UDM_GETACCEL 
  wParam = (WPARAM) cAccels; 
  lParam = (LPARAM) (LPUDACCEL) paAccels; 

アップダウンコントロールの矢印ボタンをマウスで押し続けると数値の変化速度がだんだん速くなる。これをアクセレレーションといって、この加速速度を以下のようなレコードの配列を使って設定・取得できる。

type
  PUDAccel = ^TUDAccel;
  TUDAccel = packed record
    nSec: UINT;
    nInc: UINT;
  end;

ここでは、アクセレレーションについてこれ以上調べない。

UDM_SETBASE 
  wParam = (WPARAM) nBase;	 
  lParam = 0; 

UDM_GETBASE 
  wParam = 0; 
  lParam = 0; 

数値の基数の設定・取得メッセージである。 nBase には、10進のときには 10、16進のときには16を指定できる。 他の数値は指定できない。 16進表示のときは 0x008F などとC言語風にバディウィンドウに表示される。

アップダウンコントロールの現在位置が変更されると、親ウィンドウに WM_HSCROLLWM_VSCROLL が送られてくる。これは、トラックバーと同じだ。 lParam に、自分のウィンドウハンドルが設定されているのも同じである。

これまでに調べたことをもとにして、コードでアップダウンコントロールを作成してテストするプログラムのつくろう。

  1. エクスプローラを使って、新しいフォルダを 2701UpDown01 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 2607Colors2 フォルダの Skeleton03.dprUtilFunc.pasGDIObject.pasUtilClass.pasAPIControl.pasAPIWindow.pasCmCtrl.pas をコピーする。
  3. コピーした Skeleton03.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton03.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで UpDown01.dpr という名前で保存する。
  5. [プロジェクト] メニューから [プロジェクトに追加...] を選んで表示されるダイアログから CmCtrl を選ぶ。
  6. コードエディタで以下のように編集する。
  7. [F.9]でコンパイルして実行する。

以下に UpDown01.dpr の全リストを示す。

program UpDown01;

uses
  windows,
  messages,
  commctrl,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas',
  APIWindow in 'APIWindow.pas',
  APIControl in 'APIControl.pas',
  CmCtrl in 'CmCtrl.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  MainWnd: TSDIMainWindow;

  hUD1,hUD2,hUD3: HWND;

  PB: TAPIProgress;
  SB: TAPIStatusBar;
  ED: TAPIEdit;
  ST: TAPIStaticText;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure UDChange(var Msg:TMessage);
var
  UDPos: integer;
begin
  if Msg.LParam = hUD1 then begin
    UDPos := LOWORD(SendMessage(hUD1,UDM_GETPOS,0,0));
    PB.Pos := UDPos;
    SB.Text[0] := 'UD1Pos : '+AIntToStr(UDPos);
  end else if Msg.LParam = hUD2 then begin
    UDPos := LOWORD(SendMessage(hUD2,UDM_GETPOS,0,0));
    SB.Text[1] := 'UD2Pos : '+AIntToStr(UDPos);
  end else if Msg.LParam = hUD3 then begin
    UDPos := LOWORD(SendMessage(hUD3,UDM_GETPOS,0,0));
    SB.Text[2] := 'UD3Pos : '+AIntToStr(UDPos);
  end;
end;

//------------------------------------------------------------
//             Main Window Event Handlers
//------------------------------------------------------------
procedure MainCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := MainWnd.Handle;
  MakeInitMenu(hWindow);

  PB := CreateProgressBar(hWindow,60,20,320,20,40,240,false,true,nil);
  PB.BkColor := RGB(255,230,230);
  PB.BarColor := clrGreen;

  SB := CreateStatusBar(hWindow,false);
  with SB do begin
    NumParts := 3;
    PartsWidth[0] := 120;
    PartsWidth[1] := 120;
  end;

  ED := CreateEdit(hWindow,30,100,80,30,'',nil);
  ST := createStatictext(hWindow,230,100,80,30,nil);
  ST.BkColor := clrWhite;
  ST.SunkenBorder := true;
  ST.Border := true;
  ST.Text := '';

  hUD1 := CreateUpDownControl(WS_CHILD or WS_VISIBLE or WS_TABSTOP or UDS_HORZ,
                             170,50,60,16,
                             hWindow,
                             1000,
                             hInstance,
                             0,
                             240,40,40);

  hUD2 := CreateUpDownControl(WS_CHILD or WS_VISIBLE or WS_TABSTOP or
                              UDS_SETBUDDYINT or UDS_ALIGNRIGHT or UDS_ARROWKEYS,
                             150,100,0,50,
                             hWindow,
                             1001,
                             hInstance,
                             0,
                             240,40,40);

  hUD3 := CreateUpDownControl(WS_CHILD or WS_VISIBLE or WS_TABSTOP or
                              UDS_SETBUDDYINT or UDS_ALIGNRIGHT or UDS_ARROWKEYS,
                             350,100,0,50,
                             hWindow,
                             1001,
                             hInstance,
                             0,
                             240,40,40);

  with MainWnd do begin
    ClientWidth := 400;
    ClientHeight := 200;
    Center;
    Trap(WM_VSCROLL,UDChange);
    Trap(WM_HSCROLL,UDChange);
  end;
end;

procedure OnTest(hWindow: HWND);
begin
  ChangeWindowSize(hUD1,50,20);
  SendMessage(hUD2,UDM_SETBUDDY,ED.Handle,0);
  SendMessage(hUD3,UDM_SETBUDDY,ST.Handle,0);
  //ED.Width := ED.Width+50;
  //ED.YPos := ED.YPos+50;
  //SendMessage(hUD2,UDM_SETBUDDY,ED.Handle,0);
end;

procedure MainCommand(var Msg: TMessage);
begin
  Msg.Msg := MainWnd.Handle;
  InitMenuCommand(Msg,OnTest);
end;

procedure MainDestroy(var Msg: TMessage);
begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MainWnd := TSDIMainWindow.Create(0,GetExeName);
  with MainWnd do begin
    OnCreate := MainCreate;
    OnDestroy := MainDestroy;
    OnCommand := MainCommand;
  end;
  MainWnd.DoCreate;

  Halt(MessageLoopNormal);

end.

DownloadExe.gifUpDown01.zip(18.818kB)
UpDown01.gif

実行すると右図のようになる。三つのアップダウンのうち、横向きのものをクリックして位置を変化させるとプログレスバーにその値が反映される。縦のアップダウンをクリックして値を変化させるとその値がステータスバーに表示される。Test! メニューを選択すると右下図のように縦のアップダウンがそれぞれエディットとスタティックに吸い込まれてスピンコントロールを形成する。左のスピンはエディットとの組み合わせなので、フォーカスを得ることができて上下の矢印キーでも値を変更することができる。右のスピンはスタティックテキストとの組み合わせなので、入力フォーカスが得られないのでマウスでしか値を変更できない。 特別のコードを書かなくても自動的にエディットと協調してスピンコントロールの動作を行う。 エディットに直接キーボードから値を書き込むと、アップダウンの位置も自動的に変化する。

コードを見てみよう。各コントロールを作成したのち MainWndTrap( ) メソッドを使って WM_VSCROLLWM_HSCROLL メッセージをトラップし、UDChange( ) ハンドラでこれらのメッセージを処理している。 OnTest( ) ハンドラでは、横向きアップダウンのサイズを変更してから UDM_SETBUDDY メッセージを送ってスピンコントロールに変身させている。コメントアウトしているコードを試すと分かるがスピンになってからエディットのサイズや位置を変更すると、アップダウンは自動的に追随しないので、再び UDM_SETBUDDY メッセージを送ってやる必要がある。

このテストで、 アップダウンの動作とスピンコントロールの作成法とその動作が理解できただろう。

redball.gifこの章の目次へ戻る

27−2 TAPIUpDown クラス

この節では、 前節で調べたアップダウンのラッパークラスを作成する。 いろいろ試してみた結果、アップダウンのスタイルの UDS_HORZ は作成後に SetWindowLong( ) で設定しても反映されないことが分かった。 そこで、Boolean 型の Vertical プロパティーを変更することにより、新たにウィンドウオブジェクトを作り直すことで対応しよう。 ラッパークラスのインスタンスとしてのパスカルオブジェクトは一つである。

  1. エクスプローラを使って、新しいフォルダを 2702UpDown02 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 2701UpDown01 フォルダの Skeleton03.dprUtilFunc.pasGDIObject.pasUtilClass.pasAPIControl.pasAPIWindow.pasCmCtrl.pas をコピーする。
  3. コピーした Skeleton03.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton03.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで UpDown02.dpr という名前で保存する。
  5. [プロジェクト] メニューから [プロジェクトに追加...] を選んで表示されるダイアログから CmCtrl を選ぶ。
  6. コードエディタで以下のように編集する。
  7. [F.9]でコンパイルして実行する。

最初に CmCtrl.pasTAPIUpDown クラスを作成しよう。宣言部を以下に示す。

//------------- TAPIUpDown  -----------------------------------------
type
TAPIUpDown = class(TCmCtrl)
private
  FDim:TRect;
  FVert:Boolean;
  FOnChange: TNotifyMessage;
  function GetDimension:TRect;
  procedure SetDimension(val:TRect);
  procedure SetVert(val:Boolean);
  function GetPos:integer;
  procedure SetPos(val:integer);
  function GetRangeMin:integer;
  procedure SetRangeMin(val:integer);
  function GetRangeMax:integer;
  procedure SetRangeMax(val:integer);
protected
  procedure CreateControl;override;
  function MakeVertUD:HWND;
  function MakeHorzUD:HWND;
public
  constructor Create(hParent:HWND); override;
  procedure DefaultHandler(var Message);override;
  procedure SetBuddy(BuddyHandle:HWND);
  property Dimension : TRect read GetDimension write SetDimension;
  property Vertical: Boolean read FVert write SetVert;
  property Pos: integer read GetPos write SetPos;
  property RangeMin: integer read GetRangeMin write SetRangeMin;
  property RangeMax: integer read GetRangeMax write SetRangeMax;
  property OnChange: TNotifyMessage read FOnChange write FOnChange;
end;

function CreateUpDown(hParent:HWND;x,y,cx,cy,cRangeMin,cRangeMax:integer;
            cVertical:Boolean;sOnChange:TNotifyMessage):TAPIUpDown;

Vertical プロパティーが true のときは垂直アップダウン、false で 水平アップダウンを作成する。デフォルトは true である。実装部を以下にしめす。

//------------- TAPIUpDown  -----------------------------------------
constructor TAPIUpDown.Create(hParent:HWND);
begin
  inherited Create(hParent);

  CreateControl;
  FVert := true;
  Dispatcher.TrapMessage(WM_HSCROLL,self);
  Dispatcher.TrapMessage(WM_VSCROLL,self);
end;

procedure TAPIUpDown.CreateControl;
begin
  FID := ID_CmCtrl;
  inc(ID_CmCtrl);
  FDim := SetDim(20,20,50,50);
  FHandle := MakeVertUD;
end;

function TAPIUpDown.MakeVertUD:HWND;
begin
  result := CreateUpDownControl(WS_CHILD or WS_TABSTOP or WS_VISIBLE or
                                UDS_SETBUDDYINT or UDS_ALIGNRIGHT or UDS_ARROWKEYS,
                          FDim.Left,FDim.Top,FDim.Right,FDim.Bottom,
                          Parent,
                          FID,
                          hInstance,
                          0,
                          100,0,50);
end;

function TAPIUpDown.MakeHorzUD:HWND;
begin
  result := CreateUpDownControl(WS_CHILD or WS_TABSTOP or WS_VISIBLE or
                                UDS_ARROWKEYS or UDS_HORZ,
                          FDim.Left,FDim.Top,FDim.Right,FDim.Bottom,
                          Parent,
                          FID,
                          hInstance,
                          0,
                          100,0,50);
end;

procedure TAPIUpDown.DefaultHandler(var Message);
var
  AMsg:TMessage;
begin
  AMsg := TMessage(Message);

  if AMsg.LParam <> FHandle then exit;

  case AMsg.Msg of

    WM_HSCROLL, WM_VSCROLL: begin
      AMsg.Msg := UINT(self);  // sender
      if Assigned(FOnChange) then OnCHange(AMsg);
      inherited;
    end;

  end;
end;

procedure TAPIUpDown.SetBuddy(BuddyHandle:HWND);
begin
  SendMessage(Handle,UDM_SETBUDDY,BuddyHandle,0);
end;

function TAPIUpDown.GetDimension:TRect;
var
  r: TRect;
  p: TPoint;
begin
  GetWindowRect(FHandle,r);
  p.x := r.Left; p.y := r.Top;
  ScreenToClient(Parent,p);
  result := SetDim(p.x,p.y,r.Right-r.Left,r.Bottom-r.Top);
end;

procedure TAPIUpDown.SetDimension(val: TRect);
begin
  FDim := val;
  MoveWindow(FHandle,val.left, val.top,val.right, val.bottom, true);
end;


procedure TAPIUpDown.SetVert(val:Boolean);
var
  Min,Max,APos: integer;
begin
  if FVert = val then Exit;
  FVert := val;
  APos := Pos;Min := RangeMin; Max := RangeMax;
  DestroyWindow(FHandle);
  if val then
    FHandle := MakeVertUD
  else
    FHandle := MakeHorzUD;
  RangeMin := Min; RangeMax := Max; Pos := APos; 
end;

function TAPIUpDown.GetPos:integer;
begin
  result := LOWORD(SendMessage(FHandle,UDM_GETPOS,0,0));
end;

procedure TAPIUpDown.SetPos(val: integer);
var
  Msg: TMessage;
begin
  SendMessage(FHandle,UDM_SETPOS,0,val);
  Msg.Msg := WM_VSCROLL;
  Msg.LParam := FHandle;
  Dispatch(Msg);
end;

function TAPIUpDown.GetRangeMin: integer;
begin
  result := HIWORD(SendMessage(FHandle,UDM_GETRANGE,0,0));
end;

procedure TAPIUpDown.SetRangeMin(val: integer);
begin
  SendMessage(FHandle,UDM_SETRANGE,0,MakeLong(RangeMax,val));
end;

function TAPIUpDown.GetRangeMax: integer;
begin
  result := LOWORD(SendMessage(FHandle,UDM_GETRANGE,0,0));
end;

procedure TAPIUpDown.SetRangeMax(val: integer);
begin
  SendMessage(FHandle,UDM_SETRANGE,0,MakeLong(val,RangeMin));
end;

function CreateUpDown(hParent:HWND;x,y,cx,cy,cRangeMin,cRangeMax:integer;
            cVertical:Boolean;sOnChange:TNotifyMessage):TAPIUpDown;
begin
  result := TAPIUpDown.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    RangeMin := cRangeMin;
    RangeMax := cRangeMax;
    Vertical := cVertical;
    OnChange := sOnChange;
  end;
end;

CreateControl メソッドを見ると分かるように、デフォルトでは垂直アップダウンを作成する。 SetVert( ) メソッドを見てみよう。

procedure TAPIUpDown.SetVert(val:Boolean);
var
  Min,Max,APos: integer;
begin
  if FVert = val then Exit;
  FVert := val;
  APos := Pos;Min := RangeMin; Max := RangeMax;
  DestroyWindow(FHandle);
  if val then
    FHandle := MakeVertUD
  else
    FHandle := MakeHorzUD;
  RangeMin := Min; RangeMax := Max; Pos := APos; 
end;

スタイルの変更にともない、現在の位置と範囲を保存し、FHandle で保持しているウィンドウを破棄してから、新たにウィンドウを作り直し、プロパティを元に戻すことにより新しいウィンドウオブジェクトに反映させる。 また、UDM_SETPOS メッセージで現在位置を変更しても、親ウィンドウに WM_VSCROLL のメッセージを送らないので、SetPos( ) メソッドでは、自分のパスカルオブジェクトにメッセージを送って、イベントを呼び出している。

この TAPIUpDown クラスをテストするプログラムを UpDown02.dpr に作ろう。 以下に全リストを示す。

program UpDown02;

uses
  windows,
  messages,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas',
  APIWindow in 'APIWindow.pas',
  APIControl in 'APIControl.pas',
  CmCtrl in 'CmCtrl.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  MainWnd: TSDIMainWindow;

  UD: TAPIUpDown;
  PB: TAPIProgress;
  SB: TAPIStatusBar;
  LB: TAPIListBox;

  ED: TAPIEdit;
  SP: TAPIUpDown;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------
procedure UDInfo;
var
  s: string;
begin
  LB.Clear;
  s := ' スタイル :    '+#9;
  if UD.Vertical then
    s := s+'VERT'
  else
    s := s+'HORZ';
  LB.AddString(s);
  s := ' 最小値 : '+#9+AIntToStr(UD.RangeMin);
  LB.AddString(s);
  s := ' 最大値 : '+#9+AIntToStr(UD.RangeMax);
  LB.AddString(s);
  s := ' 現在位置 :  '+#9+AIntToStr(UD.Pos);
  LB.AddString(s);
end;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure UDChange(var Msg:TMessage);
begin
  PB.Pos := UD.Pos;
  SB.Text[0] := 'Pos : '+AIntToStr(UD.Pos);
end;


procedure SPChange(var Msg:TMessage);
begin
  SB.Text[1] := 'Pos : '+AIntToStr(SP.Pos);
end;

//------------------------------------------------------------
//             Main Window Event Handlers
//------------------------------------------------------------
procedure MainCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := MainWnd.Handle;
  MakeInitMenu(hWindow);

  UD := CreateUpDown(hWindow,20,20,20,50,40,240,true,UDChange);

  PB := CreateProgressBar(hWindow,80,20,300,20,40,240,false,true,nil);

  SB := CreateStatusbar(hWindow,false);
  with SB do begin
    NumParts := 3;
    PartsWidth[0] := 120;
    PartsWidth[1] := 120;
  end;

  LB := CreateListbox(hWindow,80,50,300,100,nil);

  ED := CreateEdit(hWindow,10,80,60,30,'0',nil);
  SP := CreateUpDown(hWindow,10,120,30,40,0,100,true,SPChange);

  with MainWnd do begin
    ClientWidth := 400;
    ClientHeight := 200;
    Center;
  end;
end;

procedure OnTest(hWindow: HWND);
begin
  with UD do begin
    if Vertical then begin
      Vertical := false;
      Dimension := SetDim(20,20,50,20);
    end else begin
      Vertical := true;
      Dimension := SetDim(20,20,20,50);
    end;
  end;
  UDInfo;
  SP.SetBuddy(ED.Handle);
end;

procedure MainCommand(var Msg: TMessage);
begin
  Msg.Msg := MainWnd.Handle;
  InitMenuCommand(Msg,OnTest);
end;

procedure MainDestroy(var Msg: TMessage);
begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MainWnd := TSDIMainWindow.Create(0,GetExeName);
  with MainWnd do begin
    OnCreate := MainCreate;
    OnDestroy := MainDestroy;
    OnCommand := MainCommand;
  end;
  MainWnd.DoCreate;

  Halt(MessageLoopNormal);

end.

DownloadExe.gifUpDown02.zip(19.122kB)
UpDown02.gif

実行すると、 右図のようになる。 アップダウンの値を変化させるとプログレスバーに反映され、 ステータスバーに値が表示される。 Test! メニューを選ぶと Vertical プロパティーが変更され、 リストボックスにアップダウンの現在の状況が表示される。

redball.gifこの章の目次へ戻る

27−3 スピンコントロールのラッパークラス

前に見たように、アップダウンコントロールに UDM_SETBUDDY メッセージを送って、バディウィンドウとしてエディットコントロールを指定すると、アップダウンがエディットに「吸い込まれて」スピンコントロールを形成する。 実は、「吸い込まれて」いるのではなく、バディーウィンドウの右端の部分を削って自分の入る領域を確保しているのである。UDS_SETBUDDYINT スタイルを含むアップダウンコントロールからつくられたスピンコントロール自体の動作は、完全に自動化されており、プログラマがコードを書かなくても完全に動作する。この節では、スピンコントロールのラッパークラスを作ってテストしよう。
スピンコントロールは、アップダウンとエディットからなる複合コントロールであるといえる。 このコントロールのラッパークラスを設計するには三通りの方法が考えられる。 最初は、その見かけどおり TAPIEdit クラスから派生して、アップダウンを取り込む方法、二番目は、その逆に TAPIUpDown クラスから派生して エディットを取り込む方法である。 三番目は、 TObject から派生して TAPIEditTAPIUpDown の両方を取り込む方法である。 これらのどの方法を採ってもよいが、ここでは一番目の方法、つまり TAPIEdit から派生して TAPIUpDown を取り込むことにしよう。

  1. エクスプローラを使って、新しいフォルダを 2703Spin01 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 2702UpDown02 フォルダの Skeleton03.dprUtilFunc.pasGDIObject.pasUtilClass.pasAPIControl.pasAPIWindow.pasCmCtrl.pas をコピーする。
  3. コピーした Skeleton03.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton03.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで Spin01.dpr という名前で保存する。
  5. [プロジェクト] メニューから [プロジェクトに追加...] を選んで表示されるダイアログから CmCtrl を選ぶ。
  6. コードエディタで以下のように編集する。
  7. [F.9]でコンパイルして実行する。

最初に CmCtrl.pasTAPISpinEdit クラスを作成しよう。uses 節に APIControl を追加する。以下に宣言部を示す。

//----------------- TAPISpinEdit -------------------------------------
type
TAPISpinEdit = class(TAPIEdit)
private
  FUpDown: TAPIUpDown;
  FSizeFlag: Boolean;
  function GetPos:integer;
  procedure SetPos(val:integer);
protected
  procedure Initialize; override;
public
  procedure DefaultHandler(var Message); override;
  property UpDown: TAPIUpDown read FUpDown;
  property Pos: integer read GetPos write SetPos;
end;

function CreateSpinEdit(hParent:HWND;x,y,cx,cy,min,max,initpos:integer;
                        sOnChange: TNotifyMessage): TAPISpinEdit;

最初に述べたとおり TAPISpinEditTAPIEdit クラスから派生し、アップダウンのラッパークラスである TAPIUpDown クラスを取り込んでいる。このクラスを外部から参照するために UpDown というプロパティーを設けている。あとは、初期化ための関数と DefaultHandler( ) をオーバーライドしているだけである。実装部を以下に示す。

//----------------- TAPISpinEdit -------------------------------------
procedure TAPISpinEdit.Initialize;
begin
  inherited;
  LeftMargin := 2;
  FSizeFlag := true;
  FUpDown := CreateUpDown(Parent,0,0,10,40,0,100,true,nil);
  FUpDown.Pos := 0;
end;

procedure TAPISpinEdit.DefaultHandler(var Message);
var
  AMsg: TMessage;
  r,UDDim: TRect;
  pTL,pBR: TPoint;
begin
  AMsg := TMessage(Message);

  case AMsg.Msg of

    WM_COMMAND: begin
      if (AMsg.LParam <> Handle) then exit;

      case AMsg.WParamHi of

        EN_SETFOCUS: if Assigned(OnSetFocus) then begin
          AMsg.Msg := UINT(self); // sender
          OnSetFocus(AMsg);
        end;

        EN_KILLFOCUS: if Assigned(OnKillFocus) then begin
          AMsg.Msg := UINT(self); // sender
          OnKillFocus(AMsg);
        end;

        EN_CHANGE: begin
          if Assigned(OnChange) then begin
            AMsg.Msg := UINT(self); // sender
            OnChange(AMsg);
          end;
        end;

        EN_UPDATE: if Assigned(OnUpdate) then begin
          AMsg.Msg := UINT(self); // sender
          OnUpdate(AMsg);
        end;

        EN_ERRSPACE,EN_MAXTEXT:MessageBox(Parent,'Edit Control Buffer Full!',
                                              'Warning',MB_OK);
      end;// case
    end;

    WM_CTLCOLOREDIT:if AMsg.LParam = Handle then begin
                      SetBkColor(AMsg.WParam,Color);
                      SetTextColor(AMsg.WParam,TextColor);
                      TMessage(Message).Result := CreateSolidBrush(Color);
                    end;

    WM_KEYUP, WM_LBUTTONUP:if Assigned(OnNotice) then OnNotice(AMsg);

    WM_SIZE:
      if FSizeFlag then begin
        FSizeFlag := false;
        FUpDown.SetBuddy(Handle);
        FSizeFlag := true;
      end;

    WM_MOVE:begin
      GetWindowRect(Handle,r);
      pTL.x := r.Left; pTL.y := r.Top;
      ScreenToClient(Parent,pTL);
      pBR.x := r.Right; pBR.y := r.Bottom;
      ScreenToClient(Parent,pBR);
      UDDIM := FUpDown.Dimension;
      FUpDown.Dimension := SetDim(pBR.x-1,pTL.y,UDDim.Right,UDDim.Bottom);
      InvalidateRect(FUpDown.Handle,nil,true);
    end;

  end;//case
end;

function TAPISpinEdit.GetPos:integer;
begin
  result := FUpDown.Pos;
end;

procedure TAPISpinEdit.SetPos(val:integer);
begin
  FUpDown.Pos := val;
end;

function CreateSpinEdit(hParent:HWND;x,y,cx,cy,min,max,initpos:integer;
                        sOnChange: TNotifyMessage): TAPISpinEdit;
begin
  result := TApiSpinEdit.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    UpDown.RangeMin := min;
    UpDown.RangeMax := max;
    UpDown.Pos := initpos;
    OnChange := sOnChange;
  end;
end;

初期化のための Initialize 関数で アップダウンを作成している。DefaultHandler( ) の大部分は TAPIEditBase クラスのそれと同じであるが、WM_SIZEWM_MOVE メッセージの処理を追加している。

  
    WM_SIZE:
      if FSizeFlag then begin
        FSizeFlag := false;
        FUpDown.SetBuddy(Handle);
        FSizeFlag := true;
      end;

ここで初めてアップダウンの SetBudyy( ) メソッドを実行する。上でのべたようにバディーウィンドウの設定はエディットの右部分を「削って」行われるので、WM_SIZE メッセージが再帰的に呼び出されないように、FSizeFlag を使っている。 ここでバディーウィンドウの設定をする事により、エディットのサイズが変更されても、アップダウンは自動的に追随する事ができる。

    WM_MOVE:begin
      GetWindowRect(Handle,r);
      pTL.x := r.Left; pTL.y := r.Top;
      ScreenToClient(Parent,pTL);
      pBR.x := r.Right; pBR.y := r.Bottom;
      ScreenToClient(Parent,pBR);
      UDDIM := FUpDown.Dimension;
      FUpDown.Dimension := SetDim(pBR.x-1,pTL.y,UDDim.Right,UDDim.Bottom);
      InvalidateRect(FUpDown.Handle,nil,true);
    end;

エディットは、自分がアップダウンのバディーウィンドウに設定されていることを知らないので、位置を変更するとアップダウンを置き去りにする。ここでは、WM_MOVE メッセージで現在の位置を取得して、その右端の部分にアップダウンを移動させることにより、スピンコントロールとしての一体性を保つようにしている。

このクラスをテストするプログラムを Spin01.dpr につくろう。以下に全リストをしめす。

program Spin01;

uses
  windows,
  messages,
  CommCtrl,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas',
  APIWindow in 'APIWindow.pas',
  APIControl in 'APIControl.pas',
  CmCtrl in 'CmCtrl.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  MainWnd: TSDIMainWindow;

  SE: TAPISpinEdit;

  SB:TAPIStatusbar;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure SpinChange(var Msg:TMessage);
begin
  SB.Text[0] := ' SpinEdit Pos : '+AIntToStr(SE.Pos);
end;

//------------------------------------------------------------
//             Main Window Event Handlers
//------------------------------------------------------------
procedure MainCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := MainWnd.Handle;
  MakeInitMenu(hWindow);

  SE := CreateSpinEdit(hWindow,10,10,70,30,100,200,150,SpinChange);

  SB := CreateStatusBar(hWindow,false);
  SB.NumParts := 3;
  SB.PartsWidth[0] := 200;

  with MainWnd do begin
    ClientWidth := 360;
    ClientHeight := 260;
    Center;
  end;
end;

procedure OnTest(hWindow: HWND);
begin
  //SE.Pos := 120;
  SE.YPos := SE.YPos+10;
  SE.XPos := SE.XPos+10;
end;

procedure MainCommand(var Msg: TMessage);
begin
  Msg.Msg := MainWnd.Handle;
  InitMenuCommand(Msg,OnTest);
end;

procedure MainDestroy(var Msg: TMessage);
begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MainWnd := TSDIMainWindow.Create(0,GetExeName);
  with MainWnd do begin
    OnCreate := MainCreate;
    OnDestroy := MainDestroy;
    OnCommand := MainCommand;
  end;
  MainWnd.DoCreate;

  Halt(MessageLoopNormal);

end.

DownloadExe.gifSpin01.zip.zip(18.167kB)
Spin01.gif

実行すると右図のようになる。エディットにキーボードから数値を入力して、それがアップダウンの位置にどのように反映されるか試してほしい。これらの動作は自動的に行われる。Test! メニューをクリックするとエディットが右下に移動するが、アップダウンもそれに追随することが分かるだろう。

redball.gifこの章の目次へ戻る

27−4 ツールチップをコードでつくる

HintExample.gif

VCLでは、TControl の派生クラスの Hint プロパティーに文字列を設定し、ShowHint プロパティーを true にすると、ユーザーがマウスポインタをコントロール上に短時間だけ置いたときに右図のようにヒントウィンドウが表示される。 このヒントウィンドウは Controls.pas で定義されている THintWindow クラスのインスタンスであり、このユニットファイルの初期化部で自動的につくられる。このように、VCLではヒントウィンドウが独自に実装されている。Win32 から導入されたコモンコントロールには TOOLTIPS_CLASS クラスがあり、このクラスのインスタンスがヒントウィンドウと同等の機能を持っている。

const
  TOOLTIPS_CLASS = 'tooltips_class32';

筆者の Delphi 3.1 では、

const
  TOOTIPS_CLASS = 'tooltips_class32';

という変な綴りの宣言になっている。 この節では、 コードでこのクラスのインスタンスを作ってテストしてみよう。

ツールチップウィンドウは、子コントロールやウィンドウの任意の矩形領域にマウスポインタが一定時間とどまったときに表示されるポップアップウィンドウであり、通常は一行または複数行のテキストを表示する。 ツールチップウィンドウは、CreateWindow( ) または CreateWindowEx( ) に上記のクラスを設定して作成する。そのとき指定できるこのコントロール特有のスタイルには以下のものがある。

const
  TTS_ALWAYSTIP           = $01; // オーナウィンドウが使用不可でも表示する
  TTS_NOPREFIX            = $02; // & 文字を表示しない(文字列リソース使用時に有効)

ウィンドウ作成後は、以下のようなメッセージを送ってこれを遠隔操作する。

const
  TTM_ACTIVATE       = WM_USER + 1;  // アクティブ/インアクティブの切り替え
  TTM_SETDELAYTIME   = WM_USER + 3;  // 遅延時間の設定

  TTM_ADDTOOL        = WM_USER + 4;  // ツールの追加登録
  TTM_DELTOOL        = WM_USER + 5;  // ツールの登録削除
  TTM_NEWTOOLRECT    = WM_USER + 6;  // ツール範囲の再設定
  TTM_RELAYEVENT     = WM_USER + 7;  // マウスメッセージを中継する
  TTM_GETTOOLINFO    = WM_USER + 8;  // 登録ツール情報の取得
  TTM_SETTOOLINFO    = WM_USER + 9;  // 登録ツールの情報を再設定
  TTM_HITTEST        = WM_USER + 10; // 座標を指定してツール情報を取得
  TTM_GETTEXT        = WM_USER + 11; // 登録テキストの取得
  TTM_UPDATETIPTEXT  = WM_USER + 12; // 登録テキストの再設定
  TTM_GETTOOLCOUNT   = WM_USER + 13; // 登録ツールの数を取得
  TTM_ENUMTOOLS      = WM_USER + 14; // 登録ツール情報の取得(列挙)
  TTM_GETCURRENTTOOL = WM_USER + 15; // 「現在のツール」の情報取得
  TTM_WINDOWFROMPOINT= WM_USER + 16; //

  TTM_SETTIPBKCOLOR  = WM_USER + 19; // 背景色の設定
  TTM_SETTIPTEXTCOLOR= WM_USER + 20; // テキスト色の設定
  TTM_GETDELAYTIME   = WM_USER + 21; // 遅延時間の取得
  TTM_GETTIPBKCOLOR  = WM_USER + 22; // 背景色の取得
  TTM_GETTIPTEXTCOLOR= WM_USER + 23; // テキスト色の取得
  TTM_SETMAXTIPWIDTH = WM_USER + 24; // チップウィンドウの最大幅の設定
  TTM_GETMAXTIPWIDTH = WM_USER + 25; // チップウィンドウの最大幅の取得
  TTM_SETMARGIN      = WM_USER + 26; // マージンの設定
  TTM_GETMARGIN      = WM_USER + 27; // マージンの取得
  TTM_POP            = WM_USER + 28; // 強制消去
  TTM_UPDATE         = WM_USER + 29; // 強制再描画

これらのメッセージのうちの幾つかを調べてみよう。 ツールチップの使用可/不可を制御するには、

TTM_ACTIVATE 
wParam = (WPARAM) (BOOL) fActivate; 
lParam = 0;

を送る。wParam のゼロで使用不可、ゼロ以外で使用可になる。デフォルトは使用可である。ツールチップを表示する子ウィンドウや矩形領域は、

TTM_ADDTOOL 
wParam = 0; 
lParam = (LPARAM) (LPTOOLINFO) lpti; 

を送って設定する。lParam には以下のようなレコード型の変数のアドレスを設定する。

  PToolInfo = PToolInfoA;
  TToolInfoA = packed record
    cbSize: UINT;        // このレコードのサイズ(設定は必須)
    uFlags: UINT;        // ツールを特定するためのフラグ 
    hwnd: HWND;          // ツールを「含んでいる」ウィンドウのハンドル
    uId: UINT;           // ツールのID値。uFlags が TTF_IDISHWND を含むときはウィンドウハンドル
    Rect: TRect;         // 矩形領域
    hInst: THandle;      // 文字列リソースを使うときのインスタンスハンドル
    lpszText: PAnsiChar; // ヒント文字列
  end;
  TToolInfo = TToolInfoA;

このうち uFlags は以下のビットフラグの組み合わせで指定する。

  TTF_IDISHWND            = $0001; // uID はウィンドウハンドルである
  TTF_CENTERTIP           = $0002; // チップをツールの中心に表示する
  TTF_RTLREADING          = $0004; // 文字列表示をツールと反対方向に表示する
  TTF_SUBCLASS            = $0010; // ツールをサブクラス化してメッセージを取得する

ツールの設定・取得は上記の説明だけでは理解しにくいので、後の具体例を参考にするとよい。ツールの削除は、

TTM_DELTOOL 
wParam = 0; 
lParam = (LPARAM) (LPTOOLINFO) lpti; 

でおこなう。lParam には削除するツールを特定するために TToolInfo 型の変数のアドレスを指定する。表示されるツールチップの背景色と文字色を設定するには

TTM_SETTIPBKCOLOR
wParam = (WPARAM)(COLORREF) clr;
lParam = 0;

TTM_SETTIPTEXTCOLOR
wParam = (WPARAM)(COLORREF) clr;
lParam = 0;

を送ればよい。 表示されるツールチップウィンドウの最大幅を設定するには、

TTM_SETMAXTIPWIDTH
wParam = 0;
lParam = (LPARAM)(INT) iWidth;

をおくる。表示される文字列がこの幅におさまらないときには、自動的に折り返されて複数行表示される。表示される文字列とツールチップウィンドウの周囲の間のマージンを設定するには、

TTM_SETMARGIN
wParam = 0;
lParam = (LPARAM)(LPRECT) lprc;

を送る。 lParam には、上、左、下、右のマージン値(ピクセル)を設定した TRect 型の変数のアドレスを設定する。

ここまでの知識で、とにかくコードでツールチップウィンドウを作成してテストしてみよう。

  1. エクスプローラを使って、新しいフォルダを 2704ToolTip01 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 2703Spin01 フォルダの Skeleton03.dprUtilFunc.pasGDIObject.pasUtilClass.pasAPIControl.pasAPIWindow.pasCmCtrl.pas をコピーする。
  3. コピーした Skeleton03.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton03.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで ToolTip01.dpr という名前で保存する。
  5. [プロジェクト] メニューから [プロジェクトに追加...] を選んで表示されるダイアログから CmCtrl を選ぶ。
  6. コードエディタで以下のように編集する。
  7. [F.9]でコンパイルして実行する。

以下に ToolTip01.dpr の全リストを示す。

program ToolTip01;

uses
  windows,
  messages,
  CommCtrl,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas',
  APIWindow in 'APIWindow.pas',
  APIControl in 'APIControl.pas',
  CmCtrl in 'CmCtrl.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
const
  TOOLTIPS_CLASS = 'tooltips_class32';

  TTM_SETTIPBKCOLOR        = WM_USER + 19;
  TTM_SETTIPTEXTCOLOR      = WM_USER + 20;
  TTM_GETDELAYTIME         = WM_USER + 21;
  TTM_GETTIPBKCOLOR        = WM_USER + 22;
  TTM_GETTIPTEXTCOLOR      = WM_USER + 23;
  TTM_SETMAXTIPWIDTH       = WM_USER + 24;
  TTM_GETMAXTIPWIDTH       = WM_USER + 25;
  TTM_SETMARGIN            = WM_USER + 26;
  TTM_GETMARGIN            = WM_USER + 27;
  TTM_POP                  = WM_USER + 28;
  TTM_UPDATE               = WM_USER + 29;

var
  MainWnd: TSDIMainWindow;

  hToolTip: HWND;

  Btn:TAPIButton;
  Edt: TAPIEdit;
  Lb:TAPIListBox;
  L1: TAPILabel;
  Spb: TAPISpeedBtn;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------
function CreateToolTip(hParent:HWND):HWND;
begin
  InitCommonControls;

  result := CreateWindowEx(WS_EX_TOPMOST,
                           TOOLTIPS_CLASS,
                           nil,
                           WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP,
                           0,0,0,0,
                           hParent,
                           0,
                           hInstance,
                           nil);
  SetWindowPos(result,HWND_TOPMOST,0,0,0,0,
                SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
end;

function TTMAddToolControl(hToolTip,hCtrl:HWND;Tips:string):Boolean;
var
  TI:TToolInfo;
begin
  ZeroMemory(@TI,SizeOf(TI));
  with TI do begin
    cbSize := SizeOf(TI);
    hwnd := MainWnd.Handle;
    uFlags := TTF_SUBCLASS or TTF_IDISHWND;
    uId := hCtrl;
    lpszText := PChar(Tips);
  end;
  result := Boolean(SendMessage(hToolTip,TTM_ADDTOOL,0,LPARAM(@TI)));
end;

function TTMAddToolRect(hToolTip,hParent:HWND;ID:integer;Rect:TRect;Tips:string):Boolean;
var
  TI:TToolInfo;
  r:Trect;
begin
  ZeroMemory(@TI,SizeOf(TI));
  r := SetDim(Rect.Left,Rect.Top,Rect.Left+Rect.Right,Rect.Top+Rect.Bottom);
  with TI do begin
    cbSize := SizeOf(TI);
    uFlags := TTF_SUBCLASS;
    hwnd := hParent;
    uId := ID;
    Rect := r;
    lpszText := PChar(Tips);
  end;
  result := Boolean(SendMessage(hToolTip,TTM_ADDTOOL,0,LPARAM(@TI)));
end;

procedure TTMSetBkColor(CL:COLORREF);
begin
  SendMessage(hToolTip,TTM_SETTIPBKCOLOR,CL,0);
end;

procedure TTMSetTextColor(CL:COLORREF);
begin
  SendMessage(hToolTip,TTM_SETTIPTEXTCOLOR,CL,0);
end;

procedure TTMSetMaxWidth(MW:Integer);
begin
  SendMessage(hToolTip,TTM_SETMAXTIPWIDTH,0,MW);
end;

procedure TTMSetMargin(R:TRect);
begin
  SendMessage(hToolTip,TTM_SETMARGIN,0,integer(@R));
end;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------

//------------------------------------------------------------
//             Main Window Event Handlers
//------------------------------------------------------------
procedure MainCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := MainWnd.Handle;
  MakeInitMenu(hWindow);

  Btn := CreateButton(hWindow,10,10,100,30,'TEST',nil);
  Edt := CreateEdit(hWindow,130,10,120,25,'EDIT',nil);
  Lb := CreateListBox(hWindow,10,50,200,120,nil);
  L1 := CreateLabel(hWindow,220,50,100,50,'ラベル'+#13+'です');
  L1.DrawFrame := true;
  L1.Data := 123;
  Spb := CreateSpeedBtn(hWindow,220,120,120,35,'SpeedButton',nil);
  Spb.Data := 124;

  hToolTip := CreateToolTip(hWindow);
  TTMAddToolControl(hToolTip,Btn.Handle,'ボタンですよ!!');
  TTMAddToolControl(hToolTip,Edt.Handle,'エディットですよ!!');
  TTMAddToolControl(hToolTip,Lb.Handle,'リストボックスですよ!!');
  TTMAddToolRect(hToolTip,L1.Parent,L1.Data,L1.Dimension,'ラベルです。');
  TTMAddToolRect(hToolTip,Spb.Parent,Spb.Data,Spb.Dimension,'SpeedBtnです。');

  with MainWnd do begin
    ClientWidth := 360;
    ClientHeight := 180;
    Center;
  end;
end;

procedure OnTest(hWindow: HWND);
var
  R:TRect;
begin
  TTMSetMaxWidth(80);
  TTMSetBkColor(RGB(130,130,255));
  TTMSetTextColor(clrYellow);
  R := SetDim(5,5,5,5);
  TTMSetMargin(R);
end;

procedure MainCommand(var Msg: TMessage);
begin
  Msg.Msg := MainWnd.Handle;
  InitMenuCommand(Msg,OnTest);
end;

procedure MainDestroy(var Msg: TMessage);
begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MainWnd := TSDIMainWindow.Create(0,GetExeName);
  with MainWnd do begin
    OnCreate := MainCreate;
    OnDestroy := MainDestroy;
    OnCommand := MainCommand;
  end;
  MainWnd.DoCreate;

  Halt(MessageLoopNormal);

end.

DownloadExe.gifToolTip01.zip(19.454KB)
ToolTip01_1.gif

実行すると右図のようになる。ボタンやエディット、リストボックス、トラックバーでツールチップが表示されるのはもちろん、ラベルやスピードボタンのようなウィンドウではないオブジェクトについても表示されるのが分かる。Test! メニューを選択すると 最大表示幅と背景色、文字色、マージンが変更されて、右下図のようになる。
ToolTip01_2.gif

コードを見てみよう。 筆者の Delphi 3.1CommCtrl.pas には定義されていない定数などが冒頭に定義されている。

const
  TOOLTIPS_CLASS = 'tooltips_class32';

  TTM_SETTIPBKCOLOR        = WM_USER + 19;
  TTM_SETTIPTEXTCOLOR      = WM_USER + 20;
  TTM_GETDELAYTIME         = WM_USER + 21;
  TTM_GETTIPBKCOLOR        = WM_USER + 22;
  TTM_GETTIPTEXTCOLOR      = WM_USER + 23;
  TTM_SETMAXTIPWIDTH       = WM_USER + 24;
  TTM_GETMAXTIPWIDTH       = WM_USER + 25;
  TTM_SETMARGIN            = WM_USER + 26;
  TTM_GETMARGIN            = WM_USER + 27;
  TTM_POP                  = WM_USER + 28;
  TTM_UPDATE               = WM_USER + 29;

これらの定義は Delphi の最新バージョンでは必要ないかもしれない。読者各自、確認されたい。MainCreate( ) では各コントロールを作成後、次の関数を呼び出してツールチップウィンドウを作成している。

function CreateToolTip(hParent:HWND):HWND;
begin
  InitCommonControls;

  result := CreateWindowEx(WS_EX_TOPMOST,
                           TOOLTIPS_CLASS,
                           nil,
                           WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP,
                           0,0,0,0,
                           hParent,
                           0,
                           hInstance,
                           nil);
  SetWindowPos(result,HWND_TOPMOST,0,0,0,0,
                SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
end;

最後の SetWindowPos( ) でZオーダーを最も手前に設定している。 チップウィンドウを作成した後、コントロールをツールとして登録するために、以下の関数を使っている。

function TTMAddToolControl(hToolTip,hCtrl:HWND;Tips:string):Boolean;
var
  TI:TToolInfo;
begin
  ZeroMemory(@TI,SizeOf(TI));
  with TI do begin
    cbSize := SizeOf(TI);
    hwnd := MainWnd.Handle;
    uFlags := TTF_SUBCLASS or TTF_IDISHWND;
    uId := hCtrl;
    lpszText := PChar(Tips);
  end;
  result := Boolean(SendMessage(hToolTip,TTM_ADDTOOL,0,LPARAM(@TI)));
end;

このように、子ウィンドウを登録するためには TToolTip 型のレコードの hwnd フィールドにはそのウィンドウの親ウィンドウを、uFlagsTTF_SUBCLASS or TTF_IDISHWND を指定し、 uId にはウィンドウハンドルを設定する。 一方、ラベルやスピードボタンのように、子ウィンドウではなくウィンドウの特定の矩形領域を設定するには、

function TTMAddToolRect(hToolTip,hParent:HWND;ID:integer;Rect:TRect;Tips:string):Boolean;
var
  TI:TToolInfo;
  r:Trect;
begin
  ZeroMemory(@TI,SizeOf(TI));
  r := SetDim(Rect.Left,Rect.Top,Rect.Left+Rect.Right,Rect.Top+Rect.Bottom);
  with TI do begin
    cbSize := SizeOf(TI);
    uFlags := TTF_SUBCLASS;
    hwnd := hParent;
    uId := ID;
    Rect := r;
    lpszText := PChar(Tips);
  end;
  result := Boolean(SendMessage(hToolTip,TTM_ADDTOOL,0,LPARAM(@TI)));
end;

のようにする。hwnd には親ウィンドウのハンドルを、uID には任意のID値を、Rect には指定領域を設定する。表示最大幅や背景色、文字色、マージンの設定は簡単である。

以上、本節ではツールチップウィンドウを作成して、その幾つかの設定をテストした。

redball.gifこの章の目次へ戻る

27−5 TToolTip クラス

前節でテストしたツールチップウィンドウの機能をカプセル化したクラスを、TCmCtrl クラスから派生して、CmCtrl.pas に作ろう。 前節でテストしたメッセージはもちろん、その他に設定できる機能も取り入れて、メソッドやプロパティーとして装備する。

  1. エクスプローラを使って、新しいフォルダを 2705ToolTip02 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 2704ToolTip01 フォルダの Skeleton03.dprUtilFunc.pasGDIObject.pasUtilClass.pasAPIControl.pasAPIWindow.pasCmCtrl.pas をコピーする。
  3. コピーした Skeleton03.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton03.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで ToolTip02.dpr という名前で保存する。
  5. [プロジェクト] メニューから [プロジェクトに追加...] を選んで表示されるダイアログから CmCtrl を選ぶ。
  6. コードエディタで以下のように編集する。
  7. [F.9]でコンパイルして実行する。

最初に CmCtrl.pasTToolTip クラスを作ろう。 uses 節に GDIObject を追加する。冒頭に以下の定数定義を追加する。

TOOLTIPS_CLASS = 'tooltips_class32';

  TTM_SETTIPBKCOLOR        = WM_USER + 19;
  TTM_SETTIPTEXTCOLOR      = WM_USER + 20;
  TTM_GETDELAYTIME         = WM_USER + 21;
  TTM_GETTIPBKCOLOR        = WM_USER + 22;
  TTM_GETTIPTEXTCOLOR      = WM_USER + 23;
  TTM_SETMAXTIPWIDTH       = WM_USER + 24;
  TTM_GETMAXTIPWIDTH       = WM_USER + 25;
  TTM_SETMARGIN            = WM_USER + 26;
  TTM_GETMARGIN            = WM_USER + 27;
  TTM_POP                  = WM_USER + 28;
  TTM_UPDATE               = WM_USER + 29;

宣言部を以下に示す。

//------------------ TToolTip ----------------------------------------
type
TToolTip = class(TCmCtrl)
private
  FTool:TintegerList;
  FEnable:Boolean;
  FDefBkColor:COLORREF;
  FOnHide:TNotifyNotify;
  FOnShow:TNotifyNotify;
  procedure SetEnable(val:Boolean);
  function GetToolCount:integer;
  function GetBkColor:COLORREF;
  procedure SetBkColor(val:COLORREF);
  function GetTextColor:COLORREF;
  procedure SetTextColor(val:COLORREF);
  function GetMargin:integer;
  procedure SetMargin(val:integer);
  function GetMaxWidth:Integer;
  procedure SetMaxWidth(val:integer);
protected
  procedure CreateControl;override;
public
  constructor Create(hParent:HWND); override;
  destructor Destroy; override;
  procedure DefaultHandler(var Message);override;
  function AddTool(Obj:TSubClass;Tips:string):Boolean;
  procedure DelTool(Obj:TSubClass);
  function GetTool(indx:integer): TSubClass;
  function GetToolID(indx:integer): integer;
  procedure ChangeToolText(Obj:TSubClass;Tips:string);
  function GetText(Obj:TSubClass):string;
  function GetCurrentTool(var TI:TToolInfo):Boolean;
  property Enable:Boolean read FEnable write SetEnable;
  procedure ChangeRect(Obj:TGDIObject);
  property ToolCount:integer read GetToolCount;
  property BkColor:COLORREF read GetBkColor write SetBkColor;
  property TextColor:COLORREF read GetTextColor write SetTextColor;
  property Margin:integer read GetMargin write SetMargin;
  property MaxWidth:integer read GetMaxWidth write SetMaxWidth;
  property OnHide:TNotifyNotify read FOnHide write FOnHide;
  property OnShow:TNotifyNotify read FOnShow write FOnShow;
end;

プロパティーやメソッドは、その名前から機能が想像できるだろう。ツールチップウィンドウが表示される直前と表示が消える直前に送ってくる通知メッセージをトラップしてイベントにしている。 実装部を以下に示す。

//------------------ TToolTip ----------------------------------------
constructor TToolTip.Create(hParent:HWND);
begin
  inherited Create(hParent);

  CreateControl;

  FEnable := true;
end;

procedure TToolTip.CreateControl;
begin

  FHandle := CreateWindowEx(WS_EX_TOPMOST,
                           TOOLTIPS_CLASS,
                           nil,
                           WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP,
                           0,0,0,0,
                           Parent,
                           0,
                           hInstance,
                           nil);

  SetWindowPos(FHandle,HWND_TOPMOST,0,0,0,0,
                SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);

  FID := ID_CmCtrl;
  inc(ID_CmCtrl);

  FTool := TIntegerList.Create(0,0);
  FDefBkColor := BkColor;
end;

destructor TToolTip.Destroy;
begin
  FTool.Free;
  inherited;
end;

procedure TToolTip.DefaultHandler(var Message);
var
  AMsg:TMessage;
  phdr: PNMHdr;
begin
  AMsg := TMessage(Message);

  case AMsg.Msg of

    WM_NOTIFY:begin
      phdr := Pointer(AMsg.LParam);
      if FHandle <> phdr^.hwndFrom then exit;
      AMsg.Msg := UINT(self); // Sender
      case phdr^.code of
        TTN_POP:if Assigned(FOnHide) then FOnHide(AMsg,phdr^);
        TTN_SHOW:if Assigned(FOnShow) then FOnShow(AMsg,phdr^);
      end;
    end;

  end;
end;

function TToolTip.AddTool(Obj:TSubClass;Tips:string):Boolean;
var
  TI:TToolInfo;
  r,Dim:TRect;
begin
  result := false;
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);

  if (Obj is TAPIControl) then begin           // TAPIControl
    with TI do begin
      uFlags := TTF_SUBCLASS or TTF_IDISHWND;
      hwnd := TAPIControl(Obj).Parent;
      uId := TAPIControl(Obj).Handle;
      lpszText := PChar(Tips);
    end;
    result := Boolean(SendMessage(FHandle,TTM_ADDTOOL,0,LPARAM(@TI)));
  end else if (Obj is TGDIObject) then begin   // TGDIObject
    Dim := TGDIObject(Obj).Dimension;
    r := SetDim(Dim.Left,Dim.Top,Dim.Left+Dim.Right,Dim.Top+Dim.Bottom);
    with TI do begin
      uFlags := TTF_SUBCLASS;
      hwnd := TGDIObject(Obj).Parent;
      uId := integer(Obj);
      Rect := r;
      lpszText := PChar(Tips);
    end;
    result := Boolean(SendMessage(FHandle,TTM_ADDTOOL,0,LPARAM(@TI)));
  end else if (Obj is TCmCtrl) then begin      // TCmCtrl
    with TI do begin
      uFlags := TTF_SUBCLASS or TTF_IDISHWND;
      hwnd := TCmCtrl(Obj).Parent;
      uId := TCmCtrl(Obj).Handle;
      lpszText := PChar(Tips);
    end;
    result := Boolean(SendMessage(FHandle,TTM_ADDTOOL,0,LPARAM(@TI)));
  end;
  FTool.Add(integer(Obj));
end;

procedure TToolTip.DelTool(Obj:TSubClass);
var
  TI:TToolInfo;
begin
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);

  if (Obj is TAPIControl) then begin           // TAPIControl
    with TI do begin
      hwnd := TAPIControl(Obj).Parent;
      uId := TAPIControl(Obj).Handle;
     end;
    SendMessage(FHandle,TTM_DELTOOL,0,LPARAM(@TI));
  end else if (Obj is TGDIObject) then begin   // TGDIObject
    with TI do begin
      hwnd := TGDIObject(Obj).Parent;
      uId := integer(Obj);
    end;
    SendMessage(FHandle,TTM_DELTOOL,0,LPARAM(@TI));
  end else if (Obj is TCmCtrl) then begin      // TCmCtrl
    with TI do begin
      hwnd := TCmCtrl(Obj).Parent;
      uId := TCmCtrl(Obj).Handle;
    end;
    SendMessage(FHandle,TTM_DELTOOL,0,LPARAM(@TI));
  end;
  FTool.Delete(FTool.Search(integer(Obj)));
end;

function TToolTip.GetTool(indx:integer): TSubClass;
begin
  result := TSubClass(FTool.Item[indx]);
end;

function TToolTip.GetToolID(indx:integer): integer;
var
  TI:TToolInfo;
begin
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);
  SendMessage(FHandle,TTM_ENUMTOOLS,indx,LPARAM(@TI));
  result := TI.uId;
end;

procedure TToolTip.ChangeToolText(Obj:TSubClass;Tips:string);
var
  TI:TToolInfo;
begin
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);

  if (Obj is TAPIControl) then begin           // TAPIControl
    with TI do begin
      hwnd := TAPIControl(Obj).Parent;
      uId := TAPIControl(Obj).Handle;
     end;
    SendMessage(FHandle,TTM_GETTOOLINFO,0,LPARAM(@TI));
  end else if (Obj is TGDIObject) then begin   // TGDIObject
    with TI do begin
      hwnd := TGDIObject(Obj).Parent;
      uId := integer(Obj);
    end;
    SendMessage(FHandle,TTM_GETTOOLINFO,0,LPARAM(@TI));
  end else if (Obj is TCmCtrl) then begin      // TCmCtrl
    with TI do begin
      hwnd := TCmCtrl(Obj).Parent;
      uId := TCmCtrl(Obj).Handle;
    end;
    SendMessage(FHandle,TTM_GETTOOLINFO,0,LPARAM(@TI));
  end;
  TI.lpszText := PChar(Tips);
  SendMessage(FHandle,TTM_SETTOOLINFO,0,LPARAM(@TI));
end;

function TToolTip.GetText(Obj:TSubClass):string;
var
  TI:TToolInfo;
begin
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);
  GetMem(TI.lpszText,200);
  try
    if (Obj is TAPIControl) then begin           // TAPIControl
      with TI do begin
        hwnd := TAPIControl(Obj).Parent;
        uId := TAPIControl(Obj).Handle;
       end;
      SendMessage(FHandle,TTM_GETTEXT,0,LPARAM(@TI));
    end else if (Obj is TGDIObject) then begin   // TGDIObject
      with TI do begin
        hwnd := TGDIObject(Obj).Parent;
        uId := integer(Obj);
      end;
      SendMessage(FHandle,TTM_GETTEXT,0,LPARAM(@TI));
    end else if (Obj is TCmCtrl) then begin      // TCmCtrl
      with TI do begin
        hwnd := TCmCtrl(Obj).Parent;
        uId := TCmCtrl(Obj).Handle;
      end;
      SendMessage(FHandle,TTM_GETTEXT,0,LPARAM(@TI));
    end;
    SetString(result,TI.lpszText,lstrlen(TI.lpszText));
  finally
    FreeMem(TI.lpszText);
  end;
end;

procedure TToolTip.ChangeRect(Obj:TGDIObject);
var
  TI:TToolInfo;
  Dim:TRect;
begin
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);

  with TI do begin
    hwnd := TGDIObject(Obj).Parent;
    uId := integer(Obj);
  end;
  SendMessage(FHandle,TTM_GETTOOLINFO,0,LPARAM(@TI));
  Dim := Obj.Dimension;
  TI.Rect := SetDim(Dim.Left,Dim.Top,Dim.Left+Dim.Right,Dim.Top+Dim.Bottom);
  TI.lpszText := PChar(GetText(Obj));
  SendMessage(FHandle,TTM_SETTOOLINFO,0,LPARAM(@TI));
end;

function TToolTip.GetCurrentTool(var TI:TToolInfo):Boolean;
begin
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);
  result := Boolean(SendMessage(FHandle,TTM_GETCURRENTTOOL,0,LPARAM(@TI)));
end;

procedure TToolTip.SetEnable(val:Boolean);
begin
  if val = FEnable then exit;
  FEnable := val;
  if val then
    SendMessage(FHandle,TTM_ACTIVATE,1,0)
  else
    SendMessage(FHandle,TTM_ACTIVATE,0,0);
end;

function TToolTip.GetToolCount:integer;
begin
  result := SendMessage(FHandle,TTM_GETTOOLCOUNT,0,0);
end;

function TToolTip.GetBkColor:COLORREF;
begin
  result := SendMessage(FHandle,TTM_GETTIPBKCOLOR,0,0);
end;

procedure TToolTip.SetBkColor(val:COLORREF);
begin
  if val <> 0 then
    SendMessage(FHandle,TTM_SETTIPBKCOLOR,val,0)
  else
    SendMessage(FHandle,TTM_SETTIPBKCOLOR,FDefBkColor,0);
end;

function TToolTip.GetTextColor:COLORREF;
begin
  result := SendMessage(FHandle,TTM_GETTIPTEXTCOLOR,0,0);
end;

procedure TToolTip.SetTextColor(val:COLORREF);
begin
  SendMessage(FHandle,TTM_SETTIPTEXTCOLOR,val,0)
end;

function TToolTip.GetMargin:integer;
var
  r:TRect;
begin
  SendMessage(FHandle,TTM_GETMARGIN,0,integer(@r));
  result := r.Left;
end;

procedure TToolTip.SetMargin(val:integer);
var
  r:TRect;
begin
  r := SetDim(val,val,val,val);
  SendMessage(FHandle,TTM_SETMARGIN,0,integer(@r));
end;

function TToolTip.GetMaxWidth:Integer;
begin
  result := SendMessage(FHandle,TTM_GETMAXTIPWIDTH,0,0);
end;

procedure TToolTip.SetMaxWidth(val:integer);
begin
  SendMessage(FHandle,TTM_SETMAXTIPWIDTH,0,val);
end;

コンストラクタから呼び出される CreateControl メソッドでは、 前節と同様にしてツールチップウィンドウを作成している。 ツールを登録する AddTool( ) メソッドを見てみよう。

function TToolTip.AddTool(Obj:TSubClass;Tips:string):Boolean;
var
  TI:TToolInfo;
  r,Dim:TRect;
begin
  result := false;
  ZeroMemory(@TI,SizeOf(TI));
  TI.cbSize := SizeOf(TI);

  if (Obj is TAPIControl) then begin           // TAPIControl
    with TI do begin
      uFlags := TTF_SUBCLASS or TTF_IDISHWND;
      hwnd := TAPIControl(Obj).Parent;
      uId := TAPIControl(Obj).Handle;
      lpszText := PChar(Tips);
    end;
    result := Boolean(SendMessage(FHandle,TTM_ADDTOOL,0,LPARAM(@TI)));
  end else if (Obj is TGDIObject) then begin   // TGDIObject
    Dim := TGDIObject(Obj).Dimension;
    r := SetDim(Dim.Left,Dim.Top,Dim.Left+Dim.Right,Dim.Top+Dim.Bottom);
    with TI do begin
      uFlags := TTF_SUBCLASS;
      hwnd := TGDIObject(Obj).Parent;
      uId := integer(Obj);
      Rect := r;
      lpszText := PChar(Tips);
    end;
    result := Boolean(SendMessage(FHandle,TTM_ADDTOOL,0,LPARAM(@TI)));
  end else if (Obj is TCmCtrl) then begin      // TCmCtrl
    with TI do begin
      uFlags := TTF_SUBCLASS or TTF_IDISHWND;
      hwnd := TCmCtrl(Obj).Parent;
      uId := TCmCtrl(Obj).Handle;
      lpszText := PChar(Tips);
    end;
    result := Boolean(SendMessage(FHandle,TTM_ADDTOOL,0,LPARAM(@TI)));
  end;
end;

本稿で作った可視コントロールのラッパークラスはすべて TSubClass の派生クラスなので、登録するオブジェクトを TSubClass のインスタンスとして受け取っている。 そして、TAPIControlTGDIObjectTCmCtrl の各クラスを特定してから、TToolTip 型の変数を組み立てて登録している。TGDIObject クラスにはID値がないので uID にはオブジェクト参照そのものを integer にキャストして設定している。これにより、オブジェクトと uID 値が一対一に対応付けられる。登録ツールを削除する DelTool( ) メソッドや登録文字列を変更する ChangeToolText( ) メソッド、登録文字列を取得する GetText( ) メソッドなども同様である。 TGDIObject の派生クラスのサイズが動的に変更された場合は、ChangeRect( ) メソッドにより登録矩形領域を更新する。登録ツールの数を求めるには読みとり専用の ToolCount プロパティーを参照する。 そのアクセスメソッド

function TToolTip.GetToolCount:integer;
begin
  result := SendMessage(FHandle,TTM_GETTOOLCOUNT,0,0);
end;

では、TTM_GETTOOLCOUNT メッセージを送って取得している。 DefaultHandler( ) を見てみよう。

procedure TToolTip.DefaultHandler(var Message);
var
  AMsg:TMessage;
  phdr: PNMHdr;
begin
  AMsg := TMessage(Message);

  case AMsg.Msg of

    WM_NOTIFY:begin
      phdr := Pointer(AMsg.LParam);
      if FHandle <> phdr^.hwndFrom then exit;
      AMsg.Msg := UINT(self); // Sender
      case phdr^.code of
        TTN_POP:if Assigned(FOnHide) then FOnHide(AMsg,phdr^);
        TTN_SHOW:if Assigned(FOnShow) then FOnShow(AMsg,phdr^);
      end;
    end;

  end;
end;

ここでは、WN_NOTIFY メッセージをトラップして以下の通知メッセージをトラップしてイベントハンドラを呼び出している。

const
  TTN_FIRST                = 0-520;       { tooltips }
  TTN_LAST                 = 0-549;

  TTN_SHOW                = TTN_FIRST - 1; // ツールチップが表示されようとしてる
  TTN_POP                 = TTN_FIRST - 2; // ツールチップが隠されようとしている

TTN_SHOW 通知では、ゼロを返すとデフォルトの位置に表示されるが SetWindowPos( ) で位置を変えてノンゼロを返すことにより、チップの表示位置を動的に変更できる。

このクラスをテストするプログラムを ToolTip02.dpr につくろう。以下に全リストを示す。

program ToolTip02;

uses
  windows,
  messages,
  CommCtrl,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas',
  APIWindow in 'APIWindow.pas',
  APIControl in 'APIControl.pas',
  CmCtrl in 'CmCtrl.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  MainWnd: TSDIMainWindow;

  TT: TToolTip;

  Btn:TAPIButton;
  Edt: TAPIEdit;
  Lb:TAPIListBox;
  L1: TAPILabel;
  Spb: TAPISpeedBtn;
  Trb: TAPITrackbar;

  BG: TBtnGroup;

  CF: TAPICFont;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure TTShow(var Msg:TMessage;NMHdr:TNMHdr);
var
  TI:TToolInfo;
begin
  TT.GetCurrentTool(TI);
  if (TI.uId = integer(Spb)) then MessageBeep($FFFFFFFF);
end;

procedure BGClick(var MSG:TMessage);
var
  i:integer;
  r:TRect;
begin
  case Msg.WParam of
    0:begin
      TT.Enable := not TT.Enable;
      if TT.Enable then
        BG.Captions[0] := 'Enable'
      else
        BG.Captions[0] := 'not Enable';
    end;
    1:begin
      Lb.Clear;
      for i := 0 to TT.ToolCount-1 do
        Lb.AddString(TT.GetText(TT.GetTool(i)));
    end;
    2: begin
      if BG.Captions[2] = 'DelTool' then begin
        TT.DelTool(Edt);
        TT.DelTool(L1);
        TT.DelTool(Trb);
        BG.Captions[2] := 'AddTool';
      end else begin
        TT.AddTool(Edt,'エディットですよ!!');
        TT.AddTool(L1,'ラベルです。');
        TT.AddTool(Trb,'トラックバーですよ!!');
        BG.Captions[2] := 'DelTool';
      end;
    end;
    3:begin
      TT.ChangeToolText(Edt,'変更されました!');
      TT.ChangeToolText(L1,'変更されました!');
      TT.ChangeToolText(Trb,'変更されました!');
    end;
    4:begin
      TT.BkColor := clrGreen;
      TT.TextColor := clrYellow;
      TT.Margin := 5;
      TT.MaxWidth := 90;
      Lb.Clear;
      Lb.AddString('ToolCount : '+AIntToStr(TT.ToolCount));
      Lb.AddString('Margin : '+AIntToStr(TT.Margin));
      Lb.AddString('MaxWidth : '+AIntToStr(TT.MaxWidth));
    end;
    5:begin
      if BG.Captions[5] = 'SetFont' then begin
        CF.SetHandle(TT.Handle);
        BG.Captions[5] := 'ResetFont';
      end else begin
        CF.ResetHandle(TT.Handle);
        BG.Captions[5] := 'SetFont';
      end;
    end;
    6:begin
      r := Spb.Dimension;
      r.Bottom := r.Bottom+20;
      Spb.Dimension := r;
      TT.ChangeRect(Spb);
    end;
  end;
end;
//------------------------------------------------------------
//             Main Window Event Handlers
//------------------------------------------------------------
procedure MainCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := MainWnd.Handle;
  MakeInitMenu(hWindow);

  Btn := CreateButton(hWindow,10,10,100,30,'TEST',nil);
  Edt := CreateEdit(hWindow,130,10,120,25,'EDIT',nil);
  Lb := CreateListBox(hWindow,10,50,200,120,nil);
  L1 := CreateLabel(hWindow,220,50,100,50,'ラベル'+#13+'です');
  L1.DrawFrame := true;
  Spb := CreateSpeedBtn(hWindow,220,120,120,35,'SpeedButton',nil);
  Trb := CreateTrackbar(hWindow,false,10,180,240,30,0,100,10,nil);

  TT := TToolTip.Create(hWindow);
  TT.OnShow := TTShow;
  TT.OnHide := TTShow;
  TT.AddTool(Btn,'ボタンですよ!!');
  TT.AddTool(Edt,'エディットですよ!!');
  TT.AddTool(Lb,'リストボックスですよ!!');
  TT.AddTool(L1,'ラベルです。');
  TT.AddTool(Spb,'SpeedBtnです。');
  TT.AddTool(Trb,'トラックバーですよ!!');

  BG := CreateBtnGroup(hWindow,true,350,10,140,240,7,BGClick);
  BG.Captions[0] := 'Enable';
  BG.Captions[1] := 'GetText';
  BG.Captions[2] := 'DelTool';
  BG.Captions[3] := 'ChangeText';
  BG.Captions[4] := 'ChangeColor';
  BG.Captions[5] := 'SetFont';
  BG.Captions[6] := 'ChangeRect';

  CF := TAPICFont.Create;
  CF.Name := 'MS 明朝';
  CF.Size := 14;
  CF.GetHandle;


  with MainWnd do begin
    ClientWidth := 500;
    ClientHeight := 260;
    Center;
  end;
end;

procedure OnTest(hWindow: HWND);
begin
  Lb.AddString('ToolID Btn : '+AIntToStr(TT.GetToolID(0)));
  Lb.AddString('Btn Handle : '+AIntToStr(Btn.Handle));
  Lb.AddString('ToolID L1 : '+AIntToStr(TT.GetToolID(3)));
  Lb.AddString('L1 instance : '+AIntToStr(integer(L1)));
end;

procedure MainCommand(var Msg: TMessage);
begin
  Msg.Msg := MainWnd.Handle;
  InitMenuCommand(Msg,OnTest);
end;

procedure MainDestroy(var Msg: TMessage);
begin
  CF.Free;
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MainWnd := TSDIMainWindow.Create(0,GetExeName);
  with MainWnd do begin
    OnCreate := MainCreate;
    OnDestroy := MainDestroy;
    OnCommand := MainCommand;
  end;
  MainWnd.DoCreate;

  Halt(MessageLoopNormal);

end.

DownloadExe.gifToolTip02.zip(23.316kB)
ToolTip02.gif

実行して、ボタングループの 'ChangeColor''SetFont' ボタンを押した後の様子を右図に示す。 ボタングループのキャプションどおり、ここで作った TToolTip クラスのメソッドやプロパティーをテストしている。スピードボタンについてだけツールチップの表示前後にシステムブザーが鳴ることも確かめてほしい。

redball.gifこの章の目次へ戻る

27−6 ドラグリストをコードでつくる

ドラグリストボックスは、普通の単選択リストボックスにユーザがマウスで項目をドラグして並べ替える機能を追加したものである。 コモンコントロールとしての子ウィンドウを新たに作成するのではなく、既存の単選択リストボックスのハンドルを指定して CommCtrl.pas に宣言されている MakeDragList( ) という関数を実行して作成する。この節ではこの機能をコードで試してみよう。

  procedure MakeDragList(hLB: HWND); stdcall;

パラメータは、第8章 リストボックス で調べた標準コントロールである単選択リストボックスのハンドルである。この関数を実行するとドラグリストボックスとしての特別なメッセージを発行するようになる。そのメッセージは、以下のような「呪文」を設定して RegisterWindowMessage( ) で取得する。

const
  DRAGLISTMSGSTRING = 'commctrl_DragListMsg';

この文字列を指定して、

function RegisterWindowMessage(lpString: PChar): UINT; stdcall;

により、メッセージの数値を取得するわけである。RegisterWindowMessage( ) を使って MakeDragList( ) 関数の中であらかじめシステムにドラグリスト用のメッセージを登録してあるので、これを同じ呪文を使って取得するのである。

MSG_DRAGLIST := RegisterWindowMessage(DRAGLISTMSGSTRING);

このようにして取得したメッセージはドラグリストボックスの親ウィンドウのウィンドウ関数に送られる。この WParam には、このメッセージを送ったリストボックスのIDが設定されている。そして、LParam には、以下のようなレコードのポインタが設定されている。

type
  PDragListInfo = ^TDragListInfo;
  TDragListInfo = packed record
    uNotification: UINT;    // 通知メッセージ (下記のいずれか)
    hWnd: HWND;             // ドラグリストボックスのハンドル
    ptCursor: TPoint;       // 現在のマウスポインタの位置を示す
  end;

このレコードの uNotification フィールドには、以下のいずれかの通知メッセージが設定されている。

const
  DL_BEGINDRAG            = WM_USER+133; // ドラグ開始
  DL_DRAGGING             = WM_USER+134; // ドラグ中
  DL_DROPPED              = WM_USER+135; // ドロップされた
  DL_CANCELDRAG           = WM_USER+136; // ドラグが中止された

これらの通知メッセージに対する処理の仕方は、以下の実行例を試しながら説明しよう。それではさっそく試してみよう。

  1. エクスプローラを使って、新しいフォルダを 2706DragList01 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 2705ToolTip02 フォルダの Skeleton03.dprUtilFunc.pasGDIObject.pasUtilClass.pasAPIControl.pasAPIWindow.pasCmCtrl.pas をコピーする。
  3. コピーした Skeleton03.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton03.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで DragList01.dpr という名前で保存する。
  5. コードエディタで以下のように編集する。
  6. [F.9]でコンパイルして実行する。

以下に、DragList01.dpr の全リストを示す。

program DragList01;

uses
  windows,
  messages,
  CommCtrl,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas',
  APIWindow in 'APIWindow.pas',
  APIControl in 'APIControl.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  MainWnd: TSDIMainWindow;

  DL: TAPIListBox;
  L1:TAPILabel;

  MSG_DRAGLIST:UINT;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
var
  DragItem:integer;
  AllowDrag:Boolean;

procedure DGLEvent(var Msg:TMessage);
var
  pDLI:PDragListInfo;
  Itm:integer;
  s:string;
  r:TRect;
begin
  if Msg.WParam <> DL.ID then exit;
  pDLI := pointer(Msg.LParam);
  case pDLI^.uNotification of
    DL_BEGINDRAG: begin
      DragItem := LBItemFromPt(DL.Handle,pDLI^.ptCursor,false);
      if DragItem =1 then
      begin
        Msg.result := 0;
        AllowDrag := false;
      end else begin
        Msg.Result := 1;
        AllowDrag := true;
      end;
    end;
    DL_DRAGGING: begin
      Itm := LBItemFromPt(DL.Handle,pDLI^.ptCursor,true);
      DrawInsert(MainWnd.Handle,DL.Handle,Itm);
    end;
    DL_DROPPED: begin
      Itm := LBItemFromPt(DL.Handle,pDLI^.ptCursor,false);
      if Itm = -1 then exit;
      if not AllowDrag then exit;
      s := DL.ItemString[DragItem];
      DL.DeleteString(DragItem);
      if Itm > DragItem then Itm := Itm-1;
      DL.InsertString(Itm,s);
      DL.SelIndex := Itm;
      r := SetDim(DL.XPos-20,DL.YPos-5,DL.XPos,DL.YPos+DL.Height);
      InvalidateRect(DL.Parent,@r,true);
    end;
    DL_CANCELDRAG: begin
      r := SetDim(DL.XPos-15,DL.YPos-15,DL.XPos,DL.YPos+DL.Height);
      InvalidateRect(DL.Parent,nil,true);
    end;
  end;
end;

procedure DLSelChange(var Msg:TMessage);
begin
  L1.Text := DL.SelText;
end;
//------------------------------------------------------------
//             Main Window Event Handlers
//------------------------------------------------------------
procedure MainCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := MainWnd.Handle;
  MakeInitMenu(hWindow);

  L1 := CreateLabel(hWindow,20,10,220,30,'');

  InitCommonControls;

  DL := CreateListBox(hWindow,20,50,220,130,DLSelChange);
  MakeDragList(DL.Handle);
  MSG_DRAGLIST := RegisterWindowMessage(DRAGLISTMSGSTRING);
  DL.AddString('000000000000000');
  DL.AddString('111111111111111');
  DL.AddString('222222222222222');
  DL.AddString('333333333333333');
  DL.AddString('444444444444444');
  DL.AddString('555555555555555');
  DL.AddString('666666666666666');
  DL.AddString('777777777777777');
  DL.AddString('888888888888888');
  DL.AddString('999999999999999');

  with MainWnd do begin
    ClientWidth := 250;
    ClientHeight := 190;
    Center;
    Trap(MSG_DRAGLIST,DGLEvent);
  end;
end;

procedure OnTest(hWindow: HWND);
begin
  MessageBeep($FFFFFFFF);
end;

procedure MainCommand(var Msg: TMessage);
begin
  Msg.Msg := MainWnd.Handle;
  InitMenuCommand(Msg,OnTest);
end;

procedure MainDestroy(var Msg: TMessage);
begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MainWnd := TSDIMainWindow.Create(0,GetExeName);
  with MainWnd do begin
    OnCreate := MainCreate;
    OnDestroy := MainDestroy;
    OnCommand := MainCommand;
  end;
  MainWnd.DoCreate;

  Halt(MessageLoopNormal);

end.

DownloadExe.gifDragList01.zip(18.354kB)
DragList01.gif

実行すると右図のようになる。項目をドラグすると挿入位置を示す矢印がリストボックスの左側に描画される。上から二番目の項目はコードによりドラグ禁止にしている。

コードを見てみよう。MainCreate( ) で単選択リストボックスを作成した後、

  MakeDragList(DL.Handle);
  MSG_DRAGLIST := RegisterWindowMessage(DRAGLISTMSGSTRING);

を実行してドラグリストにし、専用メッセージを取得し、このメッセージを親ウィンドウであるメインウィンドウでトラップしている。

  Trap(MSG_DRAGLIST,DGLEvent);

このメッセージの処理ハンドラを見てみよう。
項目の上でマウスの左ボタンを押してドラグし始めると DL_BEGINDRAG 通知が届く。

    DL_BEGINDRAG: begin
      DragItem := LBItemFromPt(DL.Handle,pDLI^.ptCursor,false);
      if DragItem =1 then
      begin
        Msg.result := 0;
        AllowDrag := false;
      end else begin
        Msg.Result := 1;
        AllowDrag := true;
      end;
    end;

あらかじめ MSG_DRAGLIST メッセージの LParam を型キャストして TDragListInfo 型レコードへのポインタを取得している。

  pDLI := pointer(Msg.LParam);

そしてこのレコードの ptCursor フィールドを使って LBItemFromPt( ) 関数によりドラグされている項目のインデックスを取得してグローバル変数 DragItem に代入している。

  function LBItemFromPt(hLB: HWND; 
                         pt: TPoint; 
                bAutoScroll: Bool): Integer; stdcall;

ここで hLB にはドラグリストのウィンドウハンドルを、pt には TDragListInfo 型レコードから得られるマウスポインタの位置を、bAutoScroll にはドラグ中にマウスがリストボックスの上下に出たときはその方向に自動的にスクロールするときは true を設定する。戻り値は pt の位置にある項目のインデックスである。この値が(上から二番目)のときは result フィールドにゼロを指定してドラグ禁止にしている。そして、グローバル変数 AllowDragfalse を設定している。 それ以外の項目には result にゼロ以外を設定してドラグを許可し、AllowDragtrue にしている。
ドラグの最中はマウスが移動するたびに適切な間隔で DL_DRAGGING 通知が届く。

    DL_DRAGGING: begin
      Itm := LBItemFromPt(DL.Handle,pDLI^.ptCursor,true);
      DrawInsert(MainWnd.Handle,DL.Handle,Itm);
    end;

ここではやはり現在のマウスポインタの位置からを項目のインデックスを取得し、DrawInsert( ) 関数により親ウィンドウにインサートアイコン(矢印の絵)を描画している。

  procedure DrawInsert(hwndParent: HWND; 
                              hLB: HWND; 
                            nItem: Integer); stdcall;

hParent には親ウィンドウのハンドル、nItem には現在のマウスポインタ下にある項目インデックスを指定する。矢印は指定項目の「上」を指すように描画される。
ドラグ中に [ESC] キーを押したりマウスの右ボタンをクリックすると、ドラグが中止され DL_CANCELDRAG が発行される。

    DL_CANCELDRAG: begin
      r := SetDim(DL.XPos-15,DL.YPos-15,DL.XPos,DL.YPos+DL.Height);
      InvalidateRect(DL.Parent,nil,true);
    end;

ここでは、リストボックスの左側の親ウィンドウの矩形領域を背景を含めて更新し、矢印アイコンを消去している。
ユーザがマウスの左ボタンを離してドラグを完了すると DL_DROPPED 通知が発行される。

    DL_DROPPED: begin
      Itm := LBItemFromPt(DL.Handle,pDLI^.ptCursor,false);
      if Itm = -1 then exit;
      if not AllowDrag then exit;
      s := DL.ItemString[DragItem];
      DL.DeleteString(DragItem);
      if Itm > DragItem then Itm := Itm-1;
      DL.InsertString(Itm,s);
      DL.SelIndex := Itm;
      r := SetDim(DL.XPos-20,DL.YPos-5,DL.XPos,DL.YPos+DL.Height);
      InvalidateRect(DL.Parent,@r,true);
    end;

このコードを見ても分かるように、ドラグリストボックスはリストボックスの項目の並べ替えを行わない。 コードで行わなければならないのである。上記のコードでは、項目インデックスがー1のときは不適切な位置にドロップしたことを示しているので何も行わない。項目を上にドラグしたときと下にドラグしたときを判断して項目の削除と挿入により並べ替えを行っている。そして矢印アイコンを消去している。

このテストプログラムではリストボックスの OnSelChange イベントハンドラで選択項目をラベルに表示しているが、試してみると分かるようにドラグの開始によっても選択項目の変化がおこる。したがって、ユーザがドラグを開始したのか選択項目を変更したのかの区別がつかない( AllowDrag フラグを参照してもダメ)ので OnSelChange イベントで何かコードを実行するときには注意する必要がある。

redball.gifこの章の目次へ戻る

27−7 TAPIDragList クラス

前節で調べたドラグリストコントロールのラッパークラスを TAPLIListBox クラスから派生して、CmCtrl.pas に作ろう。 リストボックスとしての機能は TAPIListbox から継承するので、前節で調べた新たなメッセージ処理に関する機能を追加するだけで良いだろう。

  1. エクスプローラを使って、新しいフォルダを 2707DragList02 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 2706DragList01 フォルダの Skeleton03.dprUtilFunc.pasGDIObject.pasUtilClass.pasAPIControl.pasAPIWindow.pasCmCtrl.pas をコピーする。
  3. コピーした Skeleton03.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton03.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで DragList02.dpr という名前で保存する。
  5. [プロジェクト] メニューから [プロジェクトに追加...] を選んで表示されるダイアログから CmCtrl を選ぶ。
  6. コードエディタで以下のように編集する。
  7. [F.9]でコンパイルして実行する。

最初に、CmCtrl.pasTAPIDragList クラスを作成しよう。宣言部を以下に示す。

//---------------- TAPIDragList ----------------------------------
type
TAPIDragList = class(TAPIListBox)
private
  MSG_DRAGLIST:UINT;
  FDragItem:integer;
  FAllowDrag:Boolean;
  FDropPos:integer;
  FAllowDrop:Boolean;
  FOnBeginDrag:TNotifyMessage;
  FOnEndDrag:TNotifyMessage;
protected
  procedure Initialize; override;
public
  constructor Create(hParent: HWND); override;
  procedure DefaultHandler(var Message); override;
  property DragItem: integer read FDragItem;
  property DropPos: integer read FDropPos;
  property AllowDrag: Boolean read FAllowDrag write FAllowDrag;
  property AllowDrop: Boolean read FAllowDrop write FAllowDrop;
  property OnBeginDrag: TNotifyMessage read FOnBeginDrag write FOnBeginDrag;
  property OnEndDrag: TNotifyMessage read FOnEndDrag write FOnEndDrag;
end;

function CreateDragList(hParent: HWND; x,y,cx,cy: integer;
                      sOnSelChange:TNotifyMessage): TAPIDragList;

ユーザがドラグ開始と終了のタイミングを知ることができるように OnBeginDragOnEndDrag イベントを追加している。 そしてそのとき、どの項目をドラグしているのか、また、どこにドロップしようとしているのかを知らせるために DragItemDropPos プロパティーを設けている。 AllowDrag はユーザがドラグを禁止するときに false にする事ができる。また、AllowDrop はユーザが DropPos を参照してドロップによる項目の並び替えを禁止することができる。実装部を以下に示す。

//---------------- TAPIDragList ----------------------------------
constructor TAPIDragList.Create(hParent: HWND);
begin
  InitCommonControls;
  inherited Create(hParent);
end;

procedure TAPIDragList.Initialize;
begin
  inherited Initialize;
  MakeDragList(Handle);
  MSG_DRAGLIST := RegisterWindowMessage(DRAGLISTMSGSTRING);
  Dispatcher.TrapMessage(MSG_DRAGLIST,self);
end;

procedure TAPIDragList.DefaultHandler(var Message);
var
  AMsg: TMessage;
  pDLI:PDragListInfo;
  Itm:integer;
  s:string;
  r:TRect;
begin
  AMsg := TMessage(Message);
  case AMsg.Msg of
    WM_COMMAND: begin
      if (AMsg.LParam <> Handle) then exit;
      if AMsg.WParamHi = LBN_ERRSPACE then
        MessageBox(Parent,'ListBox Error Space','Warning',MB_OK);
      AMsg.Msg := UINT(self); // Sender
      case AMsg.WParamHi of
        LBN_SELCHANGE: if Assigned(OnSelChange) then OnSelChange(AMsg);
        LBN_DBLCLK: if Assigned(OnDoubleClick) then OnDoubleClick(AMsg);
      end; // case
    end;
    WM_CTLCOLORLISTBOX: if AMsg.LParam = Handle then begin
      SetBkColor(AMsg.WParam,Color);
      SetTextColor(AMsg.WParam,TextColor);
      TMessage(Message).Result := CreateSolidBrush(Color);
    end;
  else
    if (AMsg.Msg = MSG_DRAGLIST) and (AMsg.WParam = ID) then begin
      pDLI := pointer(AMsg.LParam);
      case pDLI^.uNotification of
        DL_BEGINDRAG: begin
          FDragItem := LBItemFromPt(Handle,pDLI^.ptCursor,false);
          FAllowDrag := true;
          AMsg.Msg := UINT(self); // Sender
          if Assigned(FOnBeginDrag) then FOnBeginDrag(AMsg);
          if FAllowDrag then
            TMessage(Message).Result := 1
          else
            TMessage(Message).Result := 0;
        end;
        DL_DRAGGING: begin
          Itm := LBItemFromPt(Handle,pDLI^.ptCursor,true);
          DrawInsert(Parent,Handle,Itm);
        end;
        DL_DROPPED: begin
          FDropPos := LBItemFromPt(Handle,pDLI^.ptCursor,false);
          if FDropPos = -1 then exit;
          if not FAllowDrag then exit;
          FAllowDrop := true;
          AMsg.Msg := UINT(self); // Sender
          if Assigned(FOnEndDrag) then FOnEndDrag(AMsg);
          if FAllowDrop then begin
            s := ItemString[FDragItem];
            DeleteString(FDragItem);
            if FDropPos > FDragItem then FDropPos := FDropPos-1;
            InsertString(FDropPos,s);
            SelIndex := FDropPos;
          end else
            SelIndex := FDragItem;
          r := SetDim(XPos-20,YPos-5,XPos,YPos+Height);
          InvalidateRect(Parent,@r,true);
        end;
        DL_CANCELDRAG: begin
          r := SetDim(XPos-15,YPos-15,XPos,YPos+Height);
          InvalidateRect(Parent,nil,true);
        end;
      end;
    end;
  end; // case
end;

function CreateDragList(hParent: HWND; x,y,cx,cy: integer;
                      sOnSelChange:TNotifyMessage): TAPIDragList;
begin
  result := TAPIDragList.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    OnSelChange := sOnSelChange;
  end;
end;

コンストラクタでは、 InitCommonControls を継承メソッドを呼び出すまえに実行している。Initialize メソッドでは、MakeDragList( ) を実行してドラグリストにしてから、MSG_DRAGLIST を取得し、それを Dispatcher に配送してくれるように依頼している。 DefaultHandler( ) では、前節と同様に MSG_DRAGLIST メッセージを処理している。

このクラスをテストする DragList02.dpr の全リストを以下に示す。

program DragList02;

uses
  windows,
  messages,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas',
  APIWindow in 'APIWindow.pas',
  APIControl in 'APIControl.pas',
  CmCtrl in 'CmCtrl.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  MainWnd: TSDIMainWindow;

  DL: TAPIDragList;
  L1:TAPILabel;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure DLSelChange(var Msg:TMessage);
begin
  L1.Text := DL.SelText;
end;

procedure DLBeginDrag(var Msg: TMessage);
begin
  if DL.DragItem < 2 then DL.AllowDrag := false;
end;

procedure DLEndDrag(var Msg: TMessage);
begin
  if DL.DropPos < 2 then DL.AllowDrop := false;
end;
//------------------------------------------------------------
//             Main Window Event Handlers
//------------------------------------------------------------
procedure MainCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := MainWnd.Handle;
  MakeInitMenu(hWindow);

  L1 := CreateLabel(hWindow,20,10,220,30,'');

  DL := CreateDragList(hWindow,20,50,220,130,DLSelChange);
  DL.Color := RGB(255,240,240);
  DL.TextColor := clrBlue;
  DL.OnBeginDrag := DLBeginDrag;
  DL.OnEndDrag := DLEndDrag;
  DL.AddString('000000000000000');
  DL.AddString('111111111111111');
  DL.AddString('222222222222222');
  DL.AddString('333333333333333');
  DL.AddString('444444444444444');
  DL.AddString('555555555555555');
  DL.AddString('666666666666666');
  DL.AddString('777777777777777');
  DL.AddString('888888888888888');
  DL.AddString('999999999999999');

  with MainWnd do begin
    ClientWidth := 360;
    ClientHeight := 260;
    Center;
  end;
end;

procedure OnTest(hWindow: HWND);
begin
  MessageBeep($FFFFFFFF);
end;

procedure MainCommand(var Msg: TMessage);
begin
  Msg.Msg := MainWnd.Handle;
  InitMenuCommand(Msg,OnTest);
end;

procedure MainDestroy(var Msg: TMessage);

begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MainWnd := TSDIMainWindow.Create(0,GetExeName);
  with MainWnd do begin
    OnCreate := MainCreate;
    OnDestroy := MainDestroy;
    OnCommand := MainCommand;
  end;
  MainWnd.DoCreate;

  Halt(MessageLoopNormal);

end.

DownloadExe.gifDragList02.zip(18.608kB)
DragList02.gif

実行すると右図のようになる。

ほぼ前節のプログラムと同じ動作をするがリストの上から二番目までは、ドラグすることもそこに他からドロップする事も禁止している。これは、以下のイベントハンドラで設定している。

procedure DLBeginDrag(var Msg: TMessage);
begin
  if DL.DragItem < 2 then DL.AllowDrag := false;
end;

procedure DLEndDrag(var Msg: TMessage);
begin
  if DL.DropPos < 2 then DL.AllowDrop := false;
end;

全ての項目と位置についてドラグドロップを許可するときはこれらのイベントハンドラを記述する必要はない。

redball.gifこの章の目次へ戻る

27−8 まとめ

本章では、 引き続き比較的小規模なコモンコントロールとして、アップダウン、スピン、ツープチップ、ドラグリストを調べ、そのラッパークラスを作成した。ここまで通読してきた読者には、簡単すぎて退屈かもしれない。 もう少しガマンしてほしい。

redball.gifこの章の目次へ戻る


ここまでのプログラムファイル

  1. Skeleton03.dpr (2 kB)
  2. UtilFunc.pas (19 kB)
  3. UtilClass.pas (74 kB)
  4. GDIObject.pas (21 kB)
  5. APIControl.pas (69 kB)
  6. APIWindow.pas (35 kB)
  7. CmCtrl.pas (49 kB)



redball.gifこの章の目次へ戻る