前の章へ
| 総目次へ
| 次の章へ 
｜引き続き、比較的小さなコモンコントロールについて調べていく｡ アップダウンコントロールは単独で用いられることはほとんどなく、エディットコントロールと組み合わせてスピンコントロールとして使われているのがほとんどであろう。ツールチップは、ＶＣＬでは独自に実装されているが、ここではコモンコントロールとしての使い方を調べることにする。ドラグリストボックスは、ユーザがマウスで項目をドラグして項目を並べ替えることができるリストボックスである｡ ＶＣＬのリストボックスもこれができるが、CommCtrl.pas の関数を使って単選択リストボックスをドラグリストボックスにすることができる。
| 第２７章 アップダウン、スピン、ツールチップ、ドラグリスト |
| ２７−１ アップダウンコントロールをコードで作る |
| ２７−２ TAPIUpDown クラス |
| ２７−３ スピンコントロールのラッパークラス |
| ２７−４ ツールチップをコードでつくる |
| ２７−５ TToolTip クラス |
| ２７−６ ドラグリストをコードでつくる |
| ２７−７ TAPIDragList クラス |
| ２６−８ まとめ |
前の章へ
| 総目次へ
| 次の章へ ｜アップダウンコントロールは、スクロールバーからバーを取り去って上下の矢印部分だけを残したものだ｡ 一定の範囲の数値をユーザーが簡単に入力できるように設計されている｡ アップダウンはまた、バディウィンドウとよばれるエディットコントロールと一体になって、スピンコントロールを構成する部品ともなる｡ 一般には､ アップダウンだけで使うより、スピンコントロールとして使われている場合が多い｡ この節では、アップダウンコントロールの作成と制御方法を調べ､ アップダウンコントロールをコードで作成してテストするプログラムを作ろう｡ 次節以降で、アップダウンコントロールのラッパークラスを作成し、さらにエディットコントロールと一体となるスピンコントロールのラッパークラスを作成しよう｡
アップダウンコントロールは、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_BORDER、WS_VISIBLE などの他に以下のスタイルを含めることができる｡
const UDS_WRAP = $0001; // 範囲を越えたとき値を折り返す UDS_SETBUDDYINT = $0002; // 位置の変更をバディウィンドウに自動的に表示する UDS_ALIGNRIGHT = $0004; // アップダウンをバディウィンドウの右に配置 UDS_ALIGNLEFT = $0008; // アップダウンをバディウィンドウの左に配置 UDS_AUTOBUDDY = $0010; // Ｚオーダが一つ前のウィンドウを自動的にバディとする UDS_ARROWKEYS = $0020; // 矢印キーで現在位置を変更できる（スピンコントロールの場合） UDS_HORZ = $0040; // 水平アップダウンにする UDS_NOTHOUSANDS = $0080; // 三桁ごとの区切り記号を表示しない（スピンコントロールの場合）
X, Y には、このコントロールの左上隅の座標、CX, CY には幅と高さを設定する｡ hParent は親ウィンドウのハンドルを、nID にはコントロールＩＤを指定する｡ 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_SETRANGE の uUpper と nLower に設定できる値は以下のようになっている｡
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_SETPOS の lParam は上位ワードがゼロなので、パスカルでは 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進のときには １０、16進のときには１６を指定できる｡ 他の数値は指定できない｡ 16進表示のときは 0x008F などとＣ言語風にバディウィンドウに表示される｡
アップダウンコントロールの現在位置が変更されると、親ウィンドウに WM_HSCROLL か WM_VSCROLL が送られてくる。これは、トラックバーと同じだ｡ lParam に、自分のウィンドウハンドルが設定されているのも同じである｡
これまでに調べたことをもとにして、コードでアップダウンコントロールを作成してテストするプログラムのつくろう。
以下に 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.
UpDown01.zip(18.818kB)
実行すると右図のようになる。三つのアップダウンのうち、横向きのものをクリックして位置を変化させるとプログレスバーにその値が反映される。縦のアップダウンをクリックして値を変化させるとその値がステータスバーに表示される。Test! メニューを選択すると右下図のように縦のアップダウンがそれぞれエディットとスタティックに吸い込まれてスピンコントロールを形成する。左のスピンはエディットとの組み合わせなので、フォーカスを得ることができて上下の矢印キーでも値を変更することができる。右のスピンはスタティックテキストとの組み合わせなので、入力フォーカスが得られないのでマウスでしか値を変更できない｡ 特別のコードを書かなくても自動的にエディットと協調してスピンコントロールの動作を行う｡ エディットに直接キーボードから値を書き込むと、アップダウンの位置も自動的に変化する。
コードを見てみよう。各コントロールを作成したのち MainWnd の Trap( ) メソッドを使って WM_VSCROLL と WM_HSCROLL メッセージをトラップし、UDChange( ) ハンドラでこれらのメッセージを処理している｡ OnTest( ) ハンドラでは、横向きアップダウンのサイズを変更してから UDM_SETBUDDY メッセージを送ってスピンコントロールに変身させている。コメントアウトしているコードを試すと分かるがスピンになってからエディットのサイズや位置を変更すると、アップダウンは自動的に追随しないので、再び UDM_SETBUDDY メッセージを送ってやる必要がある｡
このテストで､ アップダウンの動作とスピンコントロールの作成法とその動作が理解できただろう｡
この節では､ 前節で調べたアップダウンのラッパークラスを作成する｡ いろいろ試してみた結果､アップダウンのスタイルの UDS_HORZ は作成後に SetWindowLong( ) で設定しても反映されないことが分かった｡ そこで、Boolean 型の Vertical プロパティーを変更することにより、新たにウィンドウオブジェクトを作り直すことで対応しよう｡ ラッパークラスのインスタンスとしてのパスカルオブジェクトは一つである｡
最初に CmCtrl.pas に TAPIUpDown クラスを作成しよう。宣言部を以下に示す｡
//------------- 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.UpDown02.zip(19.122kB)
実行すると､ 右図のようになる｡ アップダウンの値を変化させるとプログレスバーに反映され､ ステータスバーに値が表示される｡ Test! メニューを選ぶと Vertical プロパティーが変更され､ リストボックスにアップダウンの現在の状況が表示される｡
前に見たように、アップダウンコントロールに UDM_SETBUDDY メッセージを送って、バディウィンドウとしてエディットコントロールを指定すると、アップダウンがエディットに「吸い込まれて」スピンコントロールを形成する｡ 実は、「吸い込まれて」いるのではなく、バディーウィンドウの右端の部分を削って自分の入る領域を確保しているのである。UDS_SETBUDDYINT スタイルを含むアップダウンコントロールからつくられたスピンコントロール自体の動作は、完全に自動化されており、プログラマがコードを書かなくても完全に動作する。この節では、スピンコントロールのラッパークラスを作ってテストしよう｡
スピンコントロールは、アップダウンとエディットからなる複合コントロールであるといえる｡ このコントロールのラッパークラスを設計するには三通りの方法が考えられる｡ 最初は、その見かけどおり TAPIEdit クラスから派生して、アップダウンを取り込む方法、二番目は、その逆に TAPIUpDown クラスから派生して エディットを取り込む方法である｡ 三番目は､ TObject から派生して TAPIEdit と TAPIUpDown の両方を取り込む方法である｡ これらのどの方法を採ってもよいが、ここでは一番目の方法、つまり TAPIEdit から派生して TAPIUpDown を取り込むことにしよう｡
最初に CmCtrl.pas に TAPISpinEdit クラスを作成しよう。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;最初に述べたとおり TAPISpinEdit は TAPIEdit クラスから派生し、アップダウンのラッパークラスである 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_SIZE と WM_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.Spin01.zip.zip(18.167kB)
実行すると右図のようになる。エディットにキーボードから数値を入力して、それがアップダウンの位置にどのように反映されるか試してほしい。これらの動作は自動的に行われる。Test! メニューをクリックするとエディットが右下に移動するが、アップダウンもそれに追随することが分かるだろう｡
ＶＣＬでは、TControl の派生クラスの Hint プロパティーに文字列を設定し、ShowHint プロパティーを true にすると、ユーザーがマウスポインタをコントロール上に短時間だけ置いたときに右図のようにヒントウィンドウが表示される｡ このヒントウィンドウは Controls.pas で定義されている THintWindow クラスのインスタンスであり、このユニットファイルの初期化部で自動的につくられる。このように、ＶＣＬではヒントウィンドウが独自に実装されている。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; // ツールのＩＤ値。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 型の変数のアドレスを設定する。
ここまでの知識で、とにかくコードでツールチップウィンドウを作成してテストしてみよう｡
以下に 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.ToolTip01.zip(19.454KB)
実行すると右図のようになる。ボタンやエディット、リストボックス、トラックバーでツールチップが表示されるのはもちろん、ラベルやスピードボタンのようなウィンドウではないオブジェクトについても表示されるのが分かる。Test! メニューを選択すると 最大表示幅と背景色、文字色、マージンが変更されて、右下図のようになる。
コードを見てみよう｡ 筆者の Delphi 3.1 の CommCtrl.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( ) でＺオーダーを最も手前に設定している｡ チップウィンドウを作成した後、コントロールをツールとして登録するために、以下の関数を使っている｡
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 フィールドにはそのウィンドウの親ウィンドウを、uFlags に TTF_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 には任意のＩＤ値を、Rect には指定領域を設定する。表示最大幅や背景色、文字色、マージンの設定は簡単である。
以上、本節ではツールチップウィンドウを作成して、その幾つかの設定をテストした｡
前節でテストしたツールチップウィンドウの機能をカプセル化したクラスを、TCmCtrl クラスから派生して、CmCtrl.pas に作ろう｡ 前節でテストしたメッセージはもちろん、その他に設定できる機能も取り入れて、メソッドやプロパティーとして装備する。
最初に CmCtrl.pas に TToolTip クラスを作ろう｡ 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 のインスタンスとして受け取っている｡ そして、TAPIControl、TGDIObject、TCmCtrl の各クラスを特定してから、TToolTip 型の変数を組み立てて登録している。TGDIObject クラスにはＩＤ値がないので 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 := 'ＭＳ 明朝';
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.ToolTip02.zip(23.316kB)
実行して、ボタングループの 'ChangeColor' と 'SetFont' ボタンを押した後の様子を右図に示す｡ ボタングループのキャプションどおり、ここで作った TToolTip クラスのメソッドやプロパティーをテストしている。スピードボタンについてだけツールチップの表示前後にシステムブザーが鳴ることも確かめてほしい。
ドラグリストボックスは、普通の単選択リストボックスにユーザがマウスで項目をドラグして並べ替える機能を追加したものである｡ コモンコントロールとしての子ウィンドウを新たに作成するのではなく、既存の単選択リストボックスのハンドルを指定して CommCtrl.pas に宣言されている MakeDragList( ) という関数を実行して作成する。この節ではこの機能をコードで試してみよう。
procedure MakeDragList(hLB: HWND); stdcall;
パラメータは、第８章 リストボックス で調べた標準コントロールである単選択リストボックスのハンドルである。この関数を実行するとドラグリストボックスとしての特別なメッセージを発行するようになる。そのメッセージは、以下のような「呪文」を設定して RegisterWindowMessage( ) で取得する。
const DRAGLISTMSGSTRING = 'commctrl_DragListMsg';
この文字列を指定して、
function RegisterWindowMessage(lpString: PChar): UINT; stdcall;
により、メッセージの数値を取得するわけである。RegisterWindowMessage( ) を使って MakeDragList( ) 関数の中であらかじめシステムにドラグリスト用のメッセージを登録してあるので、これを同じ呪文を使って取得するのである｡
MSG_DRAGLIST := RegisterWindowMessage(DRAGLISTMSGSTRING);
このようにして取得したメッセージはドラグリストボックスの親ウィンドウのウィンドウ関数に送られる。この WParam には、このメッセージを送ったリストボックスのＩＤが設定されている。そして、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; // ドラグが中止された
これらの通知メッセージに対する処理の仕方は、以下の実行例を試しながら説明しよう。それではさっそく試してみよう。
以下に、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.DragList01.zip(18.354kB)
実行すると右図のようになる。項目をドラグすると挿入位置を示す矢印がリストボックスの左側に描画される。上から二番目の項目はコードによりドラグ禁止にしている。
コードを見てみよう。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 フィールドにゼロを指定してドラグ禁止にしている。そして、グローバル変数 AllowDrag に false を設定している｡ それ以外の項目には result にゼロ以外を設定してドラグを許可し、AllowDrag を true にしている｡
ドラグの最中はマウスが移動するたびに適切な間隔で 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;このコードを見ても分かるように、ドラグリストボックスはリストボックスの項目の並べ替えを行わない｡ コードで行わなければならないのである。上記のコードでは、項目インデックスがー１のときは不適切な位置にドロップしたことを示しているので何も行わない。項目を上にドラグしたときと下にドラグしたときを判断して項目の削除と挿入により並べ替えを行っている。そして矢印アイコンを消去している｡
このテストプログラムではリストボックスの OnSelChange イベントハンドラで選択項目をラベルに表示しているが、試してみると分かるようにドラグの開始によっても選択項目の変化がおこる。したがって、ユーザがドラグを開始したのか選択項目を変更したのかの区別がつかない（ AllowDrag フラグを参照してもダメ）ので OnSelChange イベントで何かコードを実行するときには注意する必要がある｡
前節で調べたドラグリストコントロールのラッパークラスを TAPLIListBox クラスから派生して、CmCtrl.pas に作ろう｡ リストボックスとしての機能は TAPIListbox から継承するので、前節で調べた新たなメッセージ処理に関する機能を追加するだけで良いだろう。
最初に、CmCtrl.pas に TAPIDragList クラスを作成しよう。宣言部を以下に示す｡
//---------------- 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;ユーザがドラグ開始と終了のタイミングを知ることができるように OnBeginDrag と OnEndDrag イベントを追加している｡ そしてそのとき、どの項目をドラグしているのか、また、どこにドロップしようとしているのかを知らせるために DragItem と DropPos プロパティーを設けている｡ 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.DragList02.zip(18.608kB)
実行すると右図のようになる。
ほぼ前節のプログラムと同じ動作をするがリストの上から二番目までは、ドラグすることもそこに他からドロップする事も禁止している。これは、以下のイベントハンドラで設定している｡
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;
全ての項目と位置についてドラグドロップを許可するときはこれらのイベントハンドラを記述する必要はない｡
本章では､ 引き続き比較的小規模なコモンコントロールとして、アップダウン、スピン、ツープチップ、ドラグリストを調べ、そのラッパークラスを作成した。ここまで通読してきた読者には、簡単すぎて退屈かもしれない｡ もう少しガマンしてほしい。
ここまでのプログラムファイル