第５章 スピードボタンとラベル、タイマ

前章までにつくった TSubClass から派生して TAPISpeedBtn クラスをつくる。 TSpeedBtn は、ボタンとは言えない外観をもっていたし、マウスボタンのアップダウンに同期してボタンのアニメーションをしなかった。また、メッセージには応答することができるがイベントとして公開していなかった。 ＶＣＬの TSpeedButton や TLabel や TPaintBox などは、TGraphicControl の派生クラスであり、したがってウィンドウではなく「絵を描く」機能を Object Pascal のコードで包み込んだクラスである。 本稿でもこのような機能を持ったクラスをつくりたいので、まず、TGraphicControl に相当するような、これらのクラスに共通のプロパティーとメソッドを持った TGDIObject をつくろう。 TAPISpeedBtn や TAPILabel などのクラスは TGDIObject から派生する。 さらに、 TSubClass から派生して、タイマの機能をカプセル化した TAPITimer をつくろう。 最後に、まとめとしてここでつくったボタンやタイマを使って簡単なゲームをつくる。クラスを使うとコードが劇的に簡潔になることや、コードの再利用が容易になることなどＯＯＰの利点を実感できるだろう。

5−0 この章の内容

第５章 スピードボタンとラベル、タイマ
５−１ ボタンの外観を描く
５−２ TGDIObject の実装
５−３ TAPISpeedBtn の実装
５−４ メッセージの取得 ： ＲＡＤ環境での確認
５−５ Skeleton02 プログラム
５−６ カラーボタン
５−７ ラベル
５−８ タイマ ： ＡＰＩレベルでの使用
５−９ TAPITimer クラス
５−１０ カスタムボタンと ColorMind ゲーム
５−１１ まとめ


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

５−１ ボタンの外観を描く

マインスイーパゲームに使われている多数のボタンや TSpeedButton のような三次元的な外観はどうやって描画するのだろうか。 この章でつくる TAPISpeedBtn は、通常の凸状態、マウスボタンのダウンに同期した凹状態、Enable プロパティーが false のときにメッセージに応答しない使用不可の状態、 Visible プロパティー が false のときは不可視の状態、を WM_PAINT メッセージに同期して描画しなければならない。 ここでは、 ＧＤＩ関数を用いて上記のような外観を描画する方法を示そう。

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

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

program DrawButton;

uses
  windows,
  messages,
  UtilFunc in 'UtilFunc.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

  Edge: UINT;
  Enable, Visible: Boolean;

  BtnRect: TRect;




//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------
procedure DrawBtn(hWindow: HWND; Rect: TRect; Caption: string);
var
  DC: HDC;
  hBr: HBRUSH;
begin
  if not Visible then Exit;
  DC := GetDC(hWindow);
    hBr := CreateSolidBrush(clrBtnFace);
    FillRect(DC, Rect, hBr);
    DeleteObject(hBr);
    DrawEdge(DC, Rect, Edge, BF_RECT);
    if Length(Caption)>0 then begin
      if not Enable then SetTextColor(DC,clrGrayText);
      SetBkMode(DC,TRANSPARENT);
      DrawText(DC,PChar(Caption),Length(Caption),
               Rect,DT_CENTER or DT_SINGLELINE or DT_VCENTER);
    end;
  ReleaseDC(hWindow,DC);
end;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  BtnRect := SetDim(150,10,290,40);
  Edge := EDGE_RAISED;
end;

procedure OnTest(hWindow: HWND);
var
  r: TRect;
begin

  Enable := true;
  Visible := true;
  Edge := EDGE_RAISED;
  r := SetDim(20,10,110,40);
  DrawBtn(hWindow,r,'通 常');

  Edge := EDGE_SUNKEN;
  r := SetDim(20,50,110,80);
  DrawBtn(hWindow,r,'凹');

  Enable := false;
  Edge := EDGE_RAISED;
  r := SetDim(20,90,110,120);
  DrawBtn(hWindow,r,'使用不可');

  Visible := false;
  Enable := true;
  r := SetDim(20,130,110,160);
  DrawBtn(hWindow,r,'不可視');
end;

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnPaint(var Msg: TMessage);
var
  hWindow: HWND;
  ps: TPaintStruct;
begin
  hWindow := Msg.Msg;
  BeginPaint(hWindow,ps);

  EndPaint(hWindow,ps);

  Enable := true;
  Visible := true;
  DrawBtn(hWindow,BtnRect,'SpeedBtn');
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

procedure OnLButtonDown(var Msg: TMessage);
var
  p: TPoint;
begin
  p.x := Msg.LParamLo;
  p.y := Msg.LParamHi;
  if PtInRect(BtnRect,p) then begin
    Edge := EDGE_SUNKEN;
    InvalidateRect(Msg.Msg,@BtnRect,true);
  end;
end;

procedure OnLButtonUp(var Msg: TMessage);
var
  p: TPoint;
begin
  p.x := Msg.LParamLo;
  p.y := Msg.LParamHi;
  if PtInRect(BtnRect,p) then begin
    Edge := EDGE_RAISED;
    InvalidateRect(Msg.Msg,@BtnRect,true);
  end;
end;

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

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_PAINT  ------------------------------------

     WM_PAINT: OnPaint(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_LBUTTONDOWN  ------------------------------

     WM_LBUTTONDOWN: OnLButtonDown(AMsg);

//-------------  WM_LBUTTONUP  --------------------------------

     WM_LBUTTONUP: OnLButtonUp(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifDrawButton.zip(11.678kB)

DrawButton.gif実行して Test! メニューを選択した時の様子を右図に示す。 次に、右側の SpeedBtn と書かれたボタンをマウスで押してみよう。ボタンの輪郭がマウスボタンに同期してアニメーションするのが分かる。 ヘルパ関数 DrawBtn( ) のコードを見ればわかるように、DrawEdge( ) ＡＰＩによってボタンの外観を描画している。

  function DrawEdge(hdc: HDC; 
                var qrc: TRect; 
                   edge: UINT; 
               grfFlags: UINT): BOOL; stdcall;

第三パラメータの edge には、

const
  { 3D border styles }
  BDR_RAISEDOUTER = 1;
  BDR_SUNKENOUTER = 2;

  BDR_RAISEDINNER = 4;
  BDR_SUNKENINNER = 8;

  EDGE_RAISED = (BDR_RAISEDOUTER or BDR_RAISEDINNER);
  EDGE_SUNKEN = (BDR_SUNKENOUTER or BDR_SUNKENINNER);
  EDGE_ETCHED = (BDR_SUNKENOUTER or BDR_RAISEDINNER);
  EDGE_BUMP = (BDR_RAISEDOUTER or BDR_SUNKENINNER);

のうち、外側エッジと内側エッジのフラグを一つずつ選ぶか、EDGE_XXX タイプから一つ選ぶ。 このプログラムでは試していない EDGE_ETCHED と EDGE_BUMP もコードを換えて試してみてほしい。最後のパラメータ grfFlags には、

const
  { Border flags }
  BF_LEFT = 1;
  BF_TOP = 2;
  BF_RIGHT = 4;
  BF_BOTTOM = 8;

  BF_TOPLEFT = (BF_TOP or BF_LEFT);
  BF_TOPRIGHT = (BF_TOP or BF_RIGHT);
  BF_BOTTOMLEFT = (BF_BOTTOM or BF_LEFT);
  BF_BOTTOMRIGHT = (BF_BOTTOM or BF_RIGHT);
  BF_RECT = (BF_LEFT or BF_TOP or BF_RIGHT or BF_BOTTOM);

などのほかに対角線を描くフラグも定義されている。 edge パラメータとの組み合わせによっては、 ＶＣＬの TBevel のような効果も出せる。 ここでは、ボタンの輪郭を描きたいので BF_RECT を指定する。 OnTest( ) ハンドラでは、飛び出した輪郭、へこんだ輪郭、使用不可の場合、不可視の場合の四通りの輪郭を描いているが、もちろん最後の場合は描かれない。

右側のボタンは OnPaint( ) ハンドラで描いている。 メインウィンドウのウィンドウ関数で WM_LBUTTONDOWN と WM_LBUTTONUP メッセージを処理して Edge 変数に適宜代入して、InvalidateRect( ) により再描画している。 このボタンアニメーションは、完全ではないことに気づいたはずである。 まず、キャプションの文字列が輪郭と同期して動かないために変な感じがする。 もう一つは、 マウスボタンを押したままボタンの矩形の内外に移動しても、ボタンが元に戻らない事である。 次節以降で実装する TAPISpeedBtn クラスでは、この問題点を解決する。

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

５−２ TGDIObject の実装

ボタンの外観を描く方法が分かったのでさっそく TAPISpeedBtn を実装したいところであるが、 その前に「絵を描く」機能をカプセル化した様々なクラスに共通なプロパティーやメソッドを持つ TGDIObject クラスを実装しよう。

  1. エクスプローラを使って、新しいフォルダを 0502SpeedBtn04 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 0501DrawButton フォルダの Skeleton01.dpr と UtilFunc.pas と UtilClass.pas をコピーする。
  3. コピーした Skeleton01.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton01.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで SpeedBtn04.dpr という名前で保存する。
  5. [ファイル]メニューから[新規作成]を選んで表示されるダイアログからユニットを選んでＯＫを押す。 新たに作られたユニットファイルを[ファイル]メニューから[名前を付けて保存]を選んで GDIObject.pas という名前で保存する。
  6. GDIObject.pas を以下のようになるように編集する。

GDIObject.pas の全リストを以下に示す。

unit GDIObject;

interface

uses
  windows,
  messages,
  UtilFunc,
  UtilClass;

//------------------ TGDIObject ------------------------------
type
TGDIObject = class(TSubClass)
private
  FDimension: TRect;
  FRect: TRect;
  FVisible: Boolean;
  FEnable: Boolean;
  procedure SetDimension(value:TRect);
  procedure SetVisible(value: Boolean);
  procedure SetEnable(value: Boolean);
protected
public
  constructor Create(hParent:HWND);override;
  destructor Destroy; override;
  procedure Update;
  procedure UpdateAll;
  property Dimension: TRect read FDimension write SetDimension;
  property Visible: Boolean read FVisible write SetVisible;
  property Enable: Boolean read FEnable write SetEnable;
end;

implementation

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

  FVisible := true;
  FEnable := true;
  Dimension := SetDim(0,0,0,0);
end;

destructor TGDIObject.Destroy;
begin
  UpdateAll;
  inherited Destroy;
end;

procedure TGDIObject.Update;
var
  AMsg: TMessage;
begin
  AMsg.Msg := WM_PAINT;
  Dispatch(AMsg);
end;

procedure TGDIObject.UpdateAll;
begin
  InvalidateRect(Parent,@FRect,true);
end;

procedure TGDIObject.SetDimension(value:TRect);
begin
  FDimension := value;
  UpdateAll;
  FRect := value;
  FRect.Right := FDimension.Left+FDimension.Right; // right from width
  FRect.Bottom := FDimension.Top+FDimension.Bottom; // Bottom from height
  Update;
end;

procedure TGDIObject.SetVisible(value: Boolean);
begin
  FVisible := value;
  if value then Update else UpdateAll;
end;

procedure TGDIObject.SetEnable(value: Boolean);
begin
  FEnable := value;
  Update;
end;

end.

TGDIObject は TSubClass クラスから派生しており、 Dimension、 Visible、 Enable のプロパティーと Update と UpdateAll メソッド を持っている。 Dimension プロパティーは、自分を描く境界矩形を定義する。 矩形の左上の座標と幅・高さで値を設定する。 Visible と Enable プロパティーは、前節のグローバル変数をプロパティーとしたものだ。Update メソッドは、自分自身に Dispatch メソッドを使って WM_PAINT メッセージを送る。UpdateAll メソッドは、親ウィンドウを更新して再描画する。 コンストラクタでは、Dispatcher の TrapMessage( ) をつかっていないので、このクラスではメッセージを一つも捕捉しない。 また DefaultHandler を override していないので、このクラスはメッセージに応答する事ができない。 したがって、このクラスをインスタンス化することはできるが、自分を描画することさえできないので何の役にも立たない。 このクラスは、 あらかじめ派生クラスの上位クラスとして定義したものであり、メッセージへの応答の仕方は各派生クラスで異なるため、 派生クラスで TObject の DefaultHandler を override する事にする。

ここまでのコードは、まだコンパイルして実行しても意味がない。 次節で TGDIObject から派生して TAPISpeedBtn クラスをつくってテストしよう。

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

５−３ TAPISpeedBtn の実装

いよいよ TAPISpeedBtn クラスを実装するときがきた。前節の続きで Delphi のコードエディタの GDIObject.pas にこのクラスを実装しよう。

最初に、スピードボタンのクリックイベントなどをプロパティーとして公開するために、イベントハンドラの形を決めよう。コードエディタにフォーカスがあるようにしてから、[ Ctrl ] + [ f.12 ] を押して表示されるダイアログから UtilFunc.pas を選んで OK ボタンを押し、コードエディタにこのユニットファイルを表示させる。 そして、Global Types, Constants and Variables のところの一番下に（TTestProc の宣言の下に）以下の定義を追加する。

  TNotifyMessage = procedure (var Msg:TMessage);

この定義と ＶＣＬの TButton の OnClick の型である

type 
  TNotifyEvent = procedure (Sender: TObject) of object;

とを比較してみよう。 承知のとおり、ＲＡＤ環境でのプログラミングの際には、 Form1 にコンポーネントパレットから TButton をドロップすると Button1 というインスタンスが自動的に作られる。そして、このボタンをダブルクリックすると、コードエディタに procedure TForm1.Button1Click(Sender: TObject); の枠組みが自動的につくられる。このときの TForm1 の定義は以下のようになる。

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

ここで重要なのは、 オブジェクトやイベントハンドラが自動的に作られることではなく、 このようにして作られたオブジェクトやハンドラは独立したオブジェクトやハンドラではなく、上の定義を見ると分かるように TForm1 クラスのフィールド変数とメソッドとして作られることだ。 クラスのメソッドには、明示的に示されたパラメータのほかに暗黙のうちに自分自身の参照である self も渡される。 したがって、イベントハンドラの型にもそのことが反映されている。 TNotifyEvent の定義の最後の of object が、この型のハンドラはオブジェクトのメソッドであることを示している。 我々が定義した TNotifyMessage にはこのキーワードがないので、独立した手続きとしてハンドラを実装できる。 ＶＣＬでは、ハンドラに渡すパラメータの違いによってイベントハンドラの型が異なる。 例えば、 WM_LBUTTONDOWN に対応するハンドラでは、 

type 
  TMouseEvent = procedure (Sender: TObject; Button: TMouseButton; 
                           Shift: TShiftState; X, Y: Integer) of object;

という具合だ。本稿で作るクラスのイベントハンドラには TMessage 型のメッセージを送るので、 メッセージクラッカの項で説明したように、ほとんどの情報はこのメッセージパラメータから得ることができる。 したがって、全てのイベントハンドラの型は、 上で定義した TNotifyMessage 型として実装することにする。

さていよいよ GDIObject.pas に TAPISpeedBtn を実装する。 宣言部を以下に示す。

//-------------------- TAPISpeedBtn -------------------------------------
TAPISpeedBtn = class(TGDIObject)
private
  FEdge: UINT;
  FCaption: string;
  FDown: Boolean;
  FOnClick: TNotifyMessage;
  procedure SetCaption(value:string);
public
  constructor Create(hParent:HWND); override;
  procedure DefaultHandler(var Message);override;
  property Caption: string read FCaption write SetCaption;
  property OnClick: TNotifyMessage read FOnClick write FOnClick;
end;

このクラスは、TGDIObject から派生しており、Caption プロパティーと OnClick イベントが追加されている。 private 部の FEdge は DrawEdge( ) ＡＰＩの第三パラメータを保持している。FDown は、マウスボタンがこの矩形内で押された事を記憶する。 実装部を以下に示す。

//-------------------- TAPISpeedBtn -------------------------------------
constructor TAPISpeedBtn.Create(hParent:HWND);
begin
  inherited Create(hParent);
  Dispatcher.TrapMessage(WM_PAINT,self);
  Dispatcher.TrapMessage(WM_LBUTTONDOWN,self);
  Dispatcher.TrapMessage(WM_LBUTTONUP,self);
  Dispatcher.TrapMessage(WM_MOUSEMOVE,self);

  FEdge := EDGE_RAISED;
  FCaption := '';
  FDown := false;
end;

procedure TAPISpeedBtn.DefaultHandler(var Message);
var
  AMsg:TMessage;
  DC:HDC;
  hBr: hBrush;
  dr: TRect;
  pt: TPoint;
begin
  if not FVisible then Exit;

  AMsg := TMessage(Message);

  case AMsg.Msg of

    WM_PAINT : begin
      DC := GetDC(Parent);
        hBr := CreateSolidBrush(clrBtnFace);
        FillRect(DC, FRect, hBr);
        DeleteObject(hBr);
        DrawEdge(DC, FRect, FEdge, BF_RECT);
        if Length(FCaption)>0 then begin
          if not Enable then SetTextColor(DC,clrGrayText);
          SetBkMode(DC,TRANSPARENT);
          dr := FRect;
          if FEdge = EDGE_RAISED then
            OffsetRect(dr,1,1)
          else
            OffsetRect(dr,-1,-1);
          DrawText(DC,PChar(FCaption),Length(FCaption),
                   dr,DT_CENTER or DT_SINGLELINE or DT_VCENTER);
        end;
      ReleaseDC(Parent,DC);
    end;

    WM_LBUTTONDOWN: begin
      if not FEnable then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if PtInRect(FRect,pt) then begin
        FEdge := EDGE_SUNKEN;
        FDown := true;
        UpDate;
      end;
    end;

    WM_LBUTTONUP: begin
      if not FEnable then Exit;
       if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
        AMsg.Msg := UINT(self);  // sender
        if Assigned(FOnClick) then OnClick(AMsg);
      end;
    end;

    WM_MOUSEMOVE: begin
      if not FEnable then Exit;
      if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if not PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
      end;
    end;

  end; // case
end;

procedure TAPISpeedBtn.SetCaption(value:string);
begin
  FCaption := value;
  UpDate;
end;

コンストラクタでは、Dispatcher に WM_PAINT、WM_LBUTTONDOWN、WM_LBUTTONUP、WM_MOUSEMOVE の四つのメッセージを送ってくれるよう依頼している。 DefaultHandler( ) では、これらのメッセージを処理している。 このハンドラのコードの説明は後回しにして、早速 SpeedBtn04.dpr にこのクラスのインスタンスを幾つかつくってテストしよう。 最初に、コードベースでのインスタンス作成を簡単にするために、インスタンス作成のための関数を GDIObject.pas に作成しよう。宣言部の最後に以下の宣言を追加する。

//
//--------------- Create Functions -------------------------------
//
function CreateSpeedBtn(hParent:HWND;x,y,cx,cy: integer;
           sCaption: string; sOnClick: TNotifyMessage): TAPISpeedBtn;

つぎに実装部の最後に以下のコードを追加する。

//
//--------------- Create Functions -------------------------------
//
function CreateSpeedBtn(hParent:HWND;x,y,cx,cy: integer;
           sCaption: string; sOnClick: TNotifyMessage): TAPISpeedBtn;
begin
  result := TAPISpeedBtn.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Caption := sCaption;
    OnClick := sOnClick;
  end;
end;

これで、この関数をつかって TAPISpeedBtn のインスタンスを簡単に作成できるようになった。SpeedBtn04.dpr の全リストを以下に示す。

program SpeedBtn04;

uses
  windows,
  messages,
  UtilFunc in 'UtilFunc.pas',
  GDIObject in 'GDIObject.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

  SpBtn1,SpBtn2,SpBtn3,SpBtn4,SpBtn5: TAPISpeedBtn;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure SpBtn1Click(var Msg:TMessage);
var
  Obj: TAPISpeedBtn;
  s: string;
begin
  Obj := TAPISpeedBtn(Msg.Msg);
  s := 'You clicked '+ Obj.Caption;
  MessageBox(Obj.Parent,PChar(s),'SpeedBtn Event',MB_OK);
end;

procedure SpBtn3Click(var Msg:TMessage);
begin
  Clr := RGB(Random(256),Random(256),Random(256));
  InvalidateRect(TAPISpeedBtn(Msg.Msg).Parent,nil,true);
end;

procedure SpBtn4Click(var Msg:TMessage);
begin
  SpBtn4.Free;
end;

procedure SpBtn5Click(var Msg:TMessage);
begin
  DestroyWindow(TAPISpeedBtn(Msg.Msg).Parent);
end;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  SpBtn1 := CreateSpeedBtn(hWindow,10,10,100,40,'SpeedBtn1',SPBtn1Click);
  SpBtn2 := CreateSpeedBtn(hWindow,120,10,100,40,'SpeedBtn2',SPBtn1Click);

  Randomize;
end;

procedure OnTest(hWindow: HWND);
begin
  if not Assigned(SpBtn3) then begin
    SpBtn3 := CreateSpeedBtn(hWindow,230,10,100,40,'SpeedBtn3',SPBtn3Click);
    SpBtn4 := CreateSpeedBtn(hWindow,10,60,100,40,'DeleteSelf',SPBtn4Click);
    SpBtn5 := CreateSpeedBtn(hWindow,10,130,100,40,'Quit',SPBtn5Click);
  end;
  SpBtn1.Enable := not SpBtn1.Enable;
  SpBtn2.Visible := not SpBtn2.Visible;
end;

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnPaint(var Msg: TMessage);
var
  hWindow: HWND;
  ps: TPaintStruct;
begin
  hWindow := Msg.Msg;
  BeginPaint(hWindow,ps);

  EndPaint(hWindow,ps);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

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

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_PAINT  ------------------------------------

     WM_PAINT: OnPaint(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifSpeedBtn04.zip(14.693kB)

SpeedBtn04.gifまず、コンパイルして実行してみよう。最初は、SpeedBtn1 と SpeedBtn2 とキャプションがついた二つのボタンが見える。 このとき Test! メニューをクリックすると、SpBtn1 は Enable プロパティーが false に、SpBtn2 は Visible プロパティーが false になるので見えなくなる。 さらに新たに SpBtn3 と SpBtn4（DeleteSelf) と SpBtn5（Quit が作られる。 ここで再び Test! メニューをクリックすると最初の二つのボタンが正常に戻る。このときの実行時の様子を右図に示す。 SpBtn1 と SpBtn2 をクリックするとそのことを知らせるメッセージボックスが開く。また、５−１節で指摘した問題点が解決されている事に注意する。キャプションの文字列が輪郭と同じように位置を変化させるし、マウスボタンを押したままボタンの外へ移動するとボタンが元に戻り、クリックイベントが発生しない。 SpBtn3 をクリックするとクライアント領域の色がランダムに変化する。DeleteSelf のボタンを押すと、そのボタンが削除される。Quit ボタンを押すとプログラムが終了する。

コードを見ていこう。 TAPISpeedBtn 型のグローバル変数として

  SpBtn1,SpBtn2,SpBtn3,SpBtn4,SpBtn5: TAPISpeedBtn;

を宣言し、 OnCreate( ) ハンドラで

procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  SpBtn1 := CreateSpeedBtn(hWindow,10,10,100,40,'SpeedBtn1',SPBtn1Click);
  SpBtn2 := CreateSpeedBtn(hWindow,120,10,100,40,'SpeedBtn2',SPBtn1Click);

  Randomize;
end;

として、二つのボタンを作る。 ふたつとも OnClick に共通のイベントハンドラ SPBtn1Click を指定している。

procedure SpBtn1Click(var Msg:TMessage);
var
  Obj: TAPISpeedBtn;
  s: string;
begin
  Obj := TAPISpeedBtn(Msg.Msg);
  s := 'You clicked '+ Obj.Caption;
  MessageBox(Obj.Parent,PChar(s),'SpeedBtn Event',MB_OK);
end;

このハンドラでは、 TAPISpeedBtn 型のローカル変数 Obj にオブジェクト参照を代入し、そのあと Caption プロパティーを参照することで、どちらのボタンが押されたか判断できる。 ローカル変数を使わずに

  s := 'You clicked '+ TAPISpeedBtn(Msg.Msg).Caption;

としても参照できる。 また、TSubClass のプロパティーである Data に予め数値をセットしておくと、これを参照してボタンを区別することができる。 OnTest( ) ハンドラでは、 

procedure OnTest(hWindow: HWND);
begin
  if not Assigned(SpBtn3) then begin
    SpBtn3 := CreateSpeedBtn(hWindow,230,10,100,40,'SpeedBtn3',SPBtn3Click);
    SpBtn4 := CreateSpeedBtn(hWindow,10,60,100,40,'DeleteSelf',SPBtn4Click);
    SpBtn5 := CreateSpeedBtn(hWindow,10,130,100,40,'Quit',SPBtn5Click);
  end;
  SpBtn1.Enable := not SpBtn1.Enable;
  SpBtn2.Visible := not SpBtn2.Visible;
end;

として、三つのボタンをつくり SpBtn1.Enable と SpBtn2.Visible を反転している。 最初の if 文は、このメニューを何度選択しても最初の一回だけ三つのボタンを作るために必要である。 SpBtn3Click ハンドラでは、

procedure SpBtn3Click(var Msg:TMessage);
begin
  Clr := RGB(Random(256),Random(256),Random(256));
  InvalidateRect(TAPISpeedBtn(Msg.Msg).Parent,nil,true);
end;

として、クライアント領域の色を変えている。 最後の文は、 親のウィンドウ関数に WM_PAINT メッセージを送って 自分自身を含む TGDIObject （の派生オブジェクト）を再描画している。残りの二つのハンドラは、

procedure SpBtn4Click(var Msg:TMessage);
begin
  SpBtn4.Free;
end;

procedure SpBtn5Click(var Msg:TMessage);
begin
  DestroyWindow(TAPISpeedBtn(Msg.Msg).Parent);
end;

となっている。 SpBtn4Click( ) は、オブジェクトのイベントハンドラで自分自身を解放している。 SpBtn5Click( ) は、オブジェクトのハンドラからプログラムを終了している。 この二つのハンドラが期待通りに動作することは、 サブクラス化の解除を初めとする終端処理がうまくいっていることを示している。

最後に、残っていた TAPISpeedBtn クラスの DefaultHandler( ) のコードを調べよう。 WM_PAINT メッセージの処理部分を以下に示す。

    WM_PAINT : begin
      DC := GetDC(Parent);
        hBr := CreateSolidBrush(clrBtnFace);
        FillRect(DC, FRect, hBr);
        DeleteObject(hBr);
        DrawEdge(DC, FRect, FEdge, BF_RECT);
        if Length(FCaption)>0 then begin
          if not Enable then SetTextColor(DC,clrGrayText);
          SetBkMode(DC,TRANSPARENT);
          dr := FRect;
          if FEdge = EDGE_RAISED then
            OffsetRect(dr,1,1)
          else
            OffsetRect(dr,-1,-1);
          DrawText(DC,PChar(FCaption),Length(FCaption),
                   dr,DT_CENTER or DT_SINGLELINE or DT_VCENTER);
        end;
      ReleaseDC(Parent,DC);
    end;

ここでは、OffsetRect( ) ＡＰＩを含む If 文に注目してほしい。 

  function OffsetRect(var lprc: TRect; 
                        dx, dy: Integer): BOOL; stdcall;

この関数は、lprc パラメータで渡した TRect 型変数をＸ方向に dx、Ｙ方向に dy だけずらした値を返してくれる。 FEdge が EDGE_RAISED のとき、つまりボタンが通常状態で描かれるときは DrawText( ) に設定する書式矩形を右下に一ピクセルずつずらしている。 逆に、押された状態を描くときは、左上にずらしている。 このようにしてキャプションを描くと、クリック動作に伴う輪郭のアニメーションと違和感がなくなる。 次に WM_MOUSEMOVE メッセージの処理部を見てみよう。

    WM_MOUSEMOVE: begin
      if not FEnable then Exit;
      if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if not PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
      end;
    end;

このメッセージは、マウスボタンが押されたまま(FDown=True)ボタンの矩形から移動するのを監視するために必要だ。 そのようなときは、FDown をリセットし、ボタンを元の凸状態に戻す。 こうすることでクリックイベントが発生しないようにしている。 WM_LBUTTONUP メッセージの処理部では、クリックイベントを呼び出している。

    WM_LBUTTONUP: begin
      if not FEnable then Exit;

       if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
        AMsg.Msg := UINT(self);  // sender
        if Assigned(FOnClick) then OnClick(AMsg);
      end;
    end;

このメッセージが発生したときに、FDown が true で、かつマウスポインタがボタン内にある時クリックイベントが発生する。 このときハンドラに渡す TMessage 型のパラメータの Msg フィールドには、自分のインスタンス参照 self を設定し、ＶＣＬの Sender パラメータに対応させている。

以上で、TAPISpeedBtn をつくってテストするプログラム SpeedBtn04.dpr のコードを調べることは、おしまいである。 ここで再度強調しておきたいことは、プロジェクトファイルのコードを見れば分かるように、このクラスはインスタンスを作成すれば、自前でメッセージを捕捉し、自分を描き、イベントを発生させることができることである。これは、当たり前のように思えるが、前章から説明してきたとおりかなり大変なことである。しかし、一度 TSubClass をつくってしまえば、その派生クラスは自動的にメッセージを自前で処理できるようになる。

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

５−４ メッセージの取得 ： ＲＡＤ環境での確認

RADSpeedBtn.gifTAPISpeedBtn が自前でメッセージを取得できるのであれば、ＲＡＤ環境で Form1 や Panel1 のウィンドウ関数を自動的にサブクラス化して完全なオブジェクトとしての振る舞いを見せるだろうか。 とくに、いままでのＡＰＩプログラム環境ではテストすることができなかった複数の親がある場合にどうなるか興味がある。 早速試してみよう。

  1. エクスプローラで 0503RADSpeedBtn という名前のフォルダをつくる。
  2. Delphi をランチャから立ち上げ、デフォルトの Form1 が表示された状態で [ファイル]メニューから[すべて保存]を選んで、0503RADSpeedBtn フォルダに Unit1.pas は Main.pas という名前で、 プロジェクトファイルは RADSpeedBtn.dpr という名前で保存する。
  3. 0502SpeedBtn04 フォルダから GDIObject.pas と UtilFunc.pas と UtilClass.pas を 0503RADSpeedBtn フォルダにコピーする。
  4. [ファイル]メニューから[プロジェクトに追加]を選んで GDIObject.pas と UtilFunc.pas と UtilClass.pas を追加する。
  5. コンポーネントパレットから TPanel を一つフォームにドロップする。
  6. Main.pas を以下のようになるように編集する。
  7. ｆ・９を押して、コンパイルして実行する。

Main.pas の全リストを以下に示す。

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls,
  GDIObject;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  SpBtn1,SpBtn2,SpBtn3: TAPISpeedBtn;

procedure SpBtn1Click(var Msg:TMessage);
begin
  Form1.Panel1.Visible := not Form1.Panel1.Visible;
end;

procedure SpBtn2Click(var Msg:TMessage);
begin
  Form1.Panel1.Color := RGB(Random(256),Random(256),Random(256));
end;

procedure SpBtn3Click(var Msg:TMessage);
begin
  Form1.Close;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SpBtn1 := CreateSpeedBtn(Handle,10,10,100,40,'SpeedBtn1',SPBtn1Click);
  SpBtn2 := CreateSpeedBtn(Panel1.Handle,10,10,100,40,'SpeedBtn2',SPBtn2Click);
  SpBtn3 := CreateSpeedBtn(Handle,10,90,100,40,'Quit',SPBtn3Click);

  Randomize;
end;

end.
DownloadExe.gifRADSpeedBtn.zip(162.364kB)

実行の様子を上図に示す。 上のコードから分かるように、TAPISpeedBtn 型のグローバル変数を三つ宣言しておき、TForm1.FormCreate( ) ハンドラで TAPISpeedBtn の三つのインスタンスを生成している。 その際、SpBtn1 と SpBtn3 の親は Form1 、SpBtn2 の親は Panel1 を指定しているので、 同じ Dimension プロパティーでも重なることはない。このように生成したインスタンスでも、FormDestroy( ) ハンドラで解放する必要がないことに注目してほしい。 親の WM_DESTROY を受け取って Dispatcher が破棄するからである。

SpBtn1 のクリックハンドラでは Panel1 の Visible プロパティーの値を反転している。 Panel1.Visible の値が false になると Panel1 が消失するだけでなく SpBtn2 も見えなくなってしまう。 この動作自体は、「コンポーネント」としては正常であり、歓迎すべきことであるが、読者はすでに SpBtn2 がＶＣＬの一員ではなく、ＲＡＤ環境では全く異質のエイリアンであることを知っている。 にもかかわらず、 Panel1 の Visible プロパティーと同期するのは驚くべき事である。 Visible プロパティーだけでなく Enabled プロパティーの値にも「正常」に動作することも試してほしい。Panel1 の Enabled が false のとき SpBtn2 はクリックイベントを生成しないのだ。この事実が意味していることを考えよう。 SpBtn2 は Panel1 のウィンドウ関数をサブクラス化して WM_PAINT や WM_LBUTTONUP などのメッセージを受け取っている。Panel1.Visible が false のときでもこのことは変わらない。したがって、SpBtn2 が WM_PAINT を受け取って Panel1 のＨＤＣをつかって自分自身を描画していても、Panel1 自身が消失しているので見えないのだと考えることができる。つまり、Panel1 のウィンドウ関数は WM_PAINT を受け取ってから自分の Visible プロパティーの値を参照して、処理を決定していると考えられる。しかし、この考え方では Enable プロパティーが false のときの動作が説明できない。 このときでも、もし Panel1 のウィンドウ関数に WM_LBUTTONUP などのマウスメッセージが届いているなら SpBtn2 は OnClick イベントを生成できるはずだ。 これができないのは、そもそもマウスメッセージが Panel1 のウィンドウ関数に送られてきていないから、と考えるのが妥当だろう。そう考えると、Visible が false のときも WM_PAINT メッセージがはじめから送られてきていないと考えられる。 これは、Win32 の仕様なのだ。

ともあれ、自前でメッセージを取得できるようになった TGDIObject の派生クラスは、ＲＡＤ環境でも「予期した以上」の動作をする事が分かった。

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

５−５ Skeleton02 プログラム

ここまでで UtilFunc.pas に加えて UtilClass.pas と GDIObject.pas を作成してきた。 これらをいつもプロジェクトに加えるのはめんどうであるし、第２章でつくった Skeleton01.dpr を骨格とするのは少々不便なので、新しい骨格プログラム Skeleton02.dpr を作ろう。といっても、Skeleton01.dpr との違いは僅かだ。

  1. エクスプローラを使って、新しいフォルダを 0504Skeleton02 という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 0502SpeedBtn04 フォルダの Skeleton01.dpr と UtilFunc.pas と UtilClass.pas と GDIObject.pas をコピーする。
  3. コピーした Skeleton01.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton01.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで Skeleton02.dpr という名前で保存する。
  5. [プロジェクト]メニューから[プロジェクトに追加]を選んで GDIObject.pas と UtilClass.pas を追加する。
  6. コードエディタで以下のように編集する。
  7. コンパイルして実行する。

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

program Skeleton02;

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

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

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

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

end;

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

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

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

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifSkeleton02.zip(11.106kB)

Skeleton01.dpr からの変更点は次のとおり。

  1. OnPaint( ) ハンドラの削除。これに伴い MainWndProc からも WM_PAINT メッセージの処理コードを削除する。
  2. コメント行 //--Object Event Handlers を追加した。
  3. uses 節に UtilClass in 'UtilClass.pas' と GDIObject in 'GDIObject.pas' を追加した。
  4. メインウィンドウのデフォルトの背景色を clrBtnFace にした。

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

５−６ カラーボタン

ボタンの背景色を変えてアプリケーションをカラフルにしたい、というユーザーの要望は無視できないくらい多いらしく、Delphi のカスタムコンポーネント関連のホームページでは、常連のコンポーネントとなっている。 その実装方法は様々であるが、ここでは TAPISpeedBtn を継承して TAPIColorBtn を作ろう。TAPISpeedBtn では背景色には clrBtnface のシステムカラーを使っていた。 TAPIColorBtn では、Color プロパティーを設けて背景色を設定し、さらにキャプション文字列の描画のための色の定義を TextColor として付け加えるだけだ。TAPIColorBtn を実装し、それをテストするプログラムを作ろう。

  1. エクスプローラを使って、新しいフォルダを 0505ColorBtn という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 0504Skeleton02 フォルダの Skeleton02.dpr と UtilFunc.pas と UtilClass.pas と GDIObject.pas をコピーする。
  3. コピーした Skeleton02.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton02.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで ColorBtn.dpr という名前で保存する。
  5. コードエディタにフォーカスがあるようにしてから、[ Ctrl ] + [ f.12 ] を押して表示されるダイアログから GDIObject.pas を選んで OK ボタンを押し、コードエディタにこのユニットファイルを表示させる。
  6. コードエディタで以下のように編集する。
  7. コンパイルして実行する。

まず最初に TAPIColorBtn.dpr を GDIObject.pas に実装する。 Interface 部の TAPISpeedBtn の下に以下の宣言を挿入する。

//-------------  TAPIColorBtn ---------------------------------------------
TAPIColorBtn = class(TAPISpeedBtn)
private
  FColor: COLORREF;
  FTextColor: COLORREF;
  procedure SetColor(value:COLORREF);
  procedure SetTextColor(value:COLORREF);
public
  constructor Create(hParent:HWND); override;
  procedure DefaultHandler(var Message);override;
  property Color: COLORREF read FColor write SetColor;
  property TextColor: COLORREF read FTextColor write SetTextColor;
end;

Color と TextColor プロパティーを追加し、DefaultHandler をオーバーライドしている。 実装部を以下に示す。

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

  FColor := clrBtnFace;
  FTextColor := clrBlack;
end;

procedure TAPIColorBtn.DefaultHandler(var Message);
var
  DC:HDC;
  AMsg: TMessage;
  hBr: hBrush;
  dr: TRect;
  pt: TPoint;
begin
  if not FVisible then Exit;

  AMsg := TMessage(Message);

  case AMsg.Msg of

    WM_PAINT : begin
      DC := GetDC(Parent);
        if FEnable then
          hBr := CreateSolidBrush(FColor)
        else
          hBr := CreateSolidBrush(clrBtnFace);
        FillRect(DC, FRect, hBr);
        DeleteObject(hBr);
        DrawEdge(DC, FRect, FEdge, BF_RECT);
        if Length(FCaption)>0 then begin
          SetBkMode(DC,TRANSPARENT);
          if not Enable then
            Windows.SetTextColor(DC,clrGrayText)
          else
            Windows.SetTextColor(DC,FTextColor);
          dr := FRect;
          if FEdge = EDGE_RAISED then
            OffsetRect(dr,1,1)
          else
            OffsetRect(dr,-1,-1);
          DrawText(DC,PChar(FCaption),Length(FCaption),
                   dr,DT_CENTER or DT_SINGLELINE or DT_VCENTER);
        end;
      ReleaseDC(Parent,DC);
    end;

    WM_LBUTTONDOWN: begin
      if not FEnable then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if PtInRect(FRect,pt) then begin
        FEdge := EDGE_SUNKEN;
        FDown := true;
        UpDate;
      end;
    end;

    WM_LBUTTONUP: begin
      if not FEnable then Exit;
       if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
        AMsg.Msg := UINT(self);  // sender
        if Assigned(FOnClick) then OnClick(AMsg);
      end;
    end;

    WM_MOUSEMOVE: begin
      if not FEnable then Exit;
      if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if not PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
      end;
    end;

  end; // case
end;

procedure TAPIColorBtn.SetColor(value:COLORREF);
begin
  FColor := value;
  Update;
end;

procedure TAPIColorBtn.SetTextColor(value:COLORREF);
begin
  FTextColor := value;
  Update;
end;

前にも述べたように、DefaultHandler はオーバーライドしても継承メソッドを呼び出さずに全ての処理を行うことにしているので、ほとんどのコードは TAPISpeedBtn と同じである。 ただ、WM_PAINT メッセージの処理では、背景色を FColor で、テキストの色を FTextColor を使って設定しているだけが相違点だ。 インスタンスを簡単につくれるように関数をつくろう。 CreateSpeedBtn( ) の下に以下の宣言を追加する。

function CreateColorBtn(hParent:HWND;x,y,cx,cy: integer;
            sCaption: string; sOnClick: TNotifyMessage): TAPIColorBtn;

この関数の実装部を以下に示す。

function CreateColorBtn(hParent:HWND;x,y,cx,cy: integer;
            sCaption: string; sOnClick: TNotifyMessage): TAPIColorBtn;
begin
  result := TAPIColorBtn.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Caption := sCaption;
    OnClick := sOnClick;
  end;
end;

このクラスのインスタンスをつくってテストする ColorBtn.dpr の全リストを以下に示す。

program ColorBtn;

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

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

  ColorBtn1,ColorBtn2,ColorBtn3: TAPIColorBtn;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure ColorBtn1Click(var Msg:TMessage);
begin
  ColorBtn1.Color := RGB(Random(255),Random(255),Random(255));
end;

procedure ColorBtn2Click(var Msg:TMessage);
begin
  ColorBtn2.Caption := 'You Pushed me';
end;

procedure ColorBtn3Click(var Msg:TMessage);
begin
  DestroyWindow(TAPIColorBtn(Msg.Msg).Parent);
end;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  ColorBtn1 := CreateColorBtn(hWindow,20,20,120,40,'ColorBtn1',
                              ColorBtn1Click);
  with ColorBtn1 do begin
    Color := clrGreen;
    TextColor := clrWhite;
  end;

  ColorBtn2 := CreateColorBtn(hWindow,20,70,120,40,'Push me!!',
                              ColorBtn2Click);
  with ColorBtn2 do begin
    Color := clrPurple;
    TextColor := clrLime;
  end;

  ColorBtn3 := CreateColorBtn(hWindow,20,150,120,40,'Quit',
                              ColorBtn3Click);
  with ColorBtn3 do begin
    Color := clrRed;
    TextColor := clrWhite;
  end;

  Randomize;
end;

procedure OnTest(hWindow: HWND);
begin
  ColorBtn1.Enable := not ColorBtn1.Enable;
  ColorBtn2.Visible := not ColorBtn2.Visible;
end;

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

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

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifColorBtn.zip(14.620kB)

ColorBtn.gif実行したときの様子を右図に示す。 OnCreate( ) ハンドラで TAPIColorBtn のインスタンスを三つつくっている。 一番上のボタンを押すと、そのボタンの背景色がランダムに変更される。真ん中のボタンを押すとキャプションが変更される。 下の赤いボタンを押すとプログラムが終了する。 Test! メニューを選択すると上の二つのボタンの Enable と Visible プロパティーが反転する。

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

５−７ ラベル

第３章でつくった TSpeedBtn の最初の実装は、ウィンドウのクライアント領域の特定の矩形領域を指定された色で塗りつぶす、というものだった。 つまり、FillRect( ) ＡＰＩの機能をカプセル化したものだ。ＶＣＬの TLabel クラスは、この言い方によれば、「ウィンドウの特定の矩形領域に対して、相対的に書式化した文字列を出力する機能をカプセル化したもの」と言えよう。 実装コードの面から言えば、FillRect( ) ＡＰＩと DrawText( ) ＡＰＩの機能をカプセル化したものといえる。 DrawText( ) については、すでに３−１節で説明している。 ここでは、TGDIObject を継承して TAPILabel を作ってテストするプログラムを作ろう。

  1. エクスプローラを使って、新しいフォルダを 0506TestLabel という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 0505ColorBtn フォルダの Skeleton02.dpr と UtilFunc.pas と UtilClass.pas と GDIObject.pas をコピーする。
  3. コピーした Skeleton02.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton02.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで TestLabel.dpr という名前で保存する。
  5. コードエディタにフォーカスがあるようにしてから、[ Ctrl ] + [ f.12 ] を押して表示されるダイアログから GDIObject.pas を選んで OK ボタンを押し、コードエディタにこの二つのユニットファイルを表示させる。
  6. コードエディタで以下のように編集する。
  7. コンパイルして実行する。

GDIObject.pas に TAPILabel を実装しよう。 Interface 部の TAPIColorBtn の宣言の下に以下の宣言を書く。

//-------------  TAPILabel ---------------------------------------------
TAPILabel = class(TGDIObject)
private
  FColor: COLORREF;
  FText: string;
  FTextAlign: UINT;
  FTextColor: COLORREF;
  FMargin: integer;
  FBkMode: integer;
  FDrawFrame: Boolean;
  FFrameColor: COLORREF;
  procedure SetColor(value: COLORREF);
  procedure SetText(value:string);
  procedure SetTextAlign(value:UINT);
  procedure SetTextColor(value:COLORREF);
  procedure SetMargin(value:integer);
  procedure SetBkMode(value:integer);
  procedure SetDrawFrame(value:Boolean);
  procedure SetFrameColor(value:COLORREF);
public
  constructor Create(hParent:HWND); override;
  procedure DefaultHandler(var Message);override;
  property Color: COLORREF read FColor write SetColor;
  property Text: string read FText write SetText;
  property TextAlign: UINT read FTextAlign write SetTextAlign;
  property TextColor: COLORREF read FTextColor write SetTextColor;
  property Margin: integer read FMargin write SetMargin;
  property BkMode: integer read FBkMode write SetBkMode;
  property DrawFrame: Boolean read FDrawFrame write SetDrawFrame;
  property FrameColor: COLORREF read FFrameColor write SetFrameCOlor;
end;

つぎに、実装部の末尾に以下のコードを書く。

//-------------  TAPILabel ---------------------------------------------
constructor TAPILabel.Create(hParent:HWND);
begin
  inherited Create(hParent);
  Dispatcher.TrapMessage(WM_PAINT,self);

  FColor := clrWhite;
  FTextColor := clrBlack;
  FTextAlign := DT_LEFT;
  FText := ClassName;
  FMargin := 4;
  FBkMode := OPAQUE;
  FDrawFrame := false;
  FFrameColor := clrBlack;
  Update;
end;

procedure TAPILabel.DefaultHandler(var Message);
var
  DC:HDC;
  AMsg: TMessage;
  hBr: hBrush;
  iR: TRect;
  uFlags: UINT;
begin
  if not FVisible then Exit;
  AMsg := TMessage(Message);
  if AMsg.Msg = WM_PAINT then begin
   DC := GetDC(Parent);
    if FBkMode = OPAQUE then begin
      hBr := CreateSolidBrush(FColor);
      FillRect(DC,FRect,hBr);
      DeleteObject(hBr);
    end;
    if FDrawFrame then begin
      hBr := CreateSolidBrush(FFrameColor);
      FrameRect(DC,FRect,hBr);
      DeleteObject(hBr);
    end;
    Windows.SetBkMode(DC,TRANSPARENT);
    Windows.SetTextColor(DC,FTextColor);
    iR := FRect;
    InflateRect(iR,-FMargin,-FMargin);
    uFlags := DT_WORDBREAK or DT_EXTERNALLEADING or
                DT_EXPANDTABS or FTextAlign;
    DrawText(DC,PChar(FText),Length(FText),iR,uFlags);
   ReleaseDC(Parent,DC);
  end;
end;

procedure TAPILabel.SetColor(value: COLORREF);
begin
  FColor := value;
  Update;
end;

procedure TAPILabel.SetText(value:string);
begin
  FText := value;
  Update;
end;

procedure TAPILabel.SetTextAlign(value:UINT);
begin
  FTextAlign := value;
  Update;
end;

procedure TAPILabel.SetTextColor(value:COLORREF);
begin
  FTextColor := value;
  Update;
end;

procedure TAPILabel.SetMargin(value:integer);
begin
  FMargin := value;
  Update;
end;

procedure TAPILabel.SetBkMode(value:integer);
begin
  FBkMode := value;
  Update;
end;

procedure TAPILabel.SetDrawFrame(value:Boolean);
begin
  FDrawFrame := value;
  Update;
end;

procedure TAPILabel.SetFrameColor(value:COLORREF);
begin
  FFrameColor := value;
  Update;
end;

宣言部を見るとわかるように、多くのプロパティーが追加されているがその意味はほとんど自明だろう。 TextAlign プロパティーは、DrawText( ) ＡＰＩの第五パラメータに相当する値を指定する。 指定できるのは、 デフォルトで指定しているもの以外の windows.pas で定義されている以下のものだ。

const
  { DrawText() Format Flags }
  DT_TOP = 0;              // 上寄せ。デフォルト。
  DT_LEFT = 0;             // 左寄せ。デフォルト。
  DT_CENTER = 1;           // 水平方向に中央配置。
  DT_RIGHT = 2;            // 右寄せ。
  DT_VCENTER = 4;          // 垂直方向に中央は位置。
  DT_BOTTOM = 8;           // 下寄せ。DT_SINGLELINEが必要。
  DT_SINGLELINE = $20;     // 一行表示
  DT_EXPANDTABS = $40;     // タブを展開する（幅はデフォルトで８文字）
  DT_NOCLIP = $100;        // クリッピングを行わない

複数指定するときは、or 演算子で組み合わせる。 Margin プロパティーは Dimension で指定される矩形の内側の上下左右の余白をピクセル単位で指定する。余白の分だけ小さな矩形を DrawText( ) の書式矩形とする。デフォルトの値は４である。 BkMode プロパティーは OPAQUE か TRANSPARENT を指定する。 Color プロパティーで指定した色を背景にするときは OPAQUE にし、親ウィンドウの背景色にするときは TRANSPARENT を指定する。デフォルトは OPAQUE である。 実装部は、プロパティーのアクセスメソッドを除けば、コンストラクタと DefaultHandler だけだ。 コンストラクタでは、Dispatcher に WM_PAINT メッセージだけを送ってくれるように依頼している。したがって DefaultHandler で処理するのは、WM_PAINT メッセージだけだ。コードを読むとプロパティーの意味が理解できるだろう。新しいＡＰＩは InflateRect( ) だけだ。

  function InflateRect(var lprc: TRect; 
                         dx, dy: Integer): BOOL; stdcall;

この関数は、 lprc で指定した TRect 型変数を dx,dy の分だけ幅と高さを増減する。 減らすときは負の値を指定する。 ここでは、Margin プロパティーの分だけ書式矩形を小さくするために使っている。

例によって、このクラスのインスタンスをつくる関数をつくろう。宣言部の CreateColorBtn( ) の下に以下の宣言を追加する。

function CreateLabel(hParent:HWND;x,y,cx,cy: integer;
                                        sText: string): TAPILabel;

実装部の最後に以下のコードを追加する。

function CreateLabel(hParent:HWND;x,y,cx,cy: integer;
                                        sText: string): TAPILabel;
begin
  result := TAPILabel.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Text := sText;
  end;
end;

TAPILabelを実装したので、これをテストするプログラムを TestLabel.dpr に作ろう。 以下に全リストを示す。

program TestLabel;

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

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

  L1,L2,L3: TAPILabel;
  SpBtn1: TAPISpeedBtn;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure SpBtn1Click(var Msg:TMessage);
begin
  with L1 do begin
    BkMode := OPAQUE;
    TextColor := clrWhite;
    TextAlign := DT_RIGHT;
  end;
  L2.Text := 'ボタンを押したね！';
end;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  L1 := CreateLabel(hWindow,30,60,200,30,'Label Test');
  with L1 do begin
    BkMode := TRANSPARENT;
    Color := clrNavy;
    DrawFrame := true;
    Margin := 6;
    FrameColor := clrWhite;
  end;

  L2 := CreateLabel(hWindow,30,100,200,80,'');
  with L2 do begin
    Color := clrGreen;
    TextAlign := DT_CENTER;
    TextColor := clrWhite;
    FrameColor := clrFuchsia;
    DrawFrame := true;
    Margin := 7;
    Text := 'This is a Test Display'#13+ 'for APILabel'#13+
            'by Object Pascal';
  end;

  L3 := CreateLabel(hWindow,30,20,300,27,'');

  SpBtn1 := CreateSpeedBtn(hWindow,30,200,120,40,'TEST',SpBtn1Click);
end;

procedure OnTest(hWindow: HWND);
begin
  with L2 do begin
    Color := clrYellow;
    TextColor := clrBlack;
    Dimension := SetDim(130,100,200,80);
  end;
end;

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

procedure OnMouseMove(var Msg: TMessage);
begin
  L3.Text := 'Mouse Position : X = '+ AIntToStr(Msg.LParamLo)+#9+
             'Y ='+ AIntToStr(Msg.LParamHi);
end;

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

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//---------------  WM_MUSEMOVE  -------------------------------

    WM_MOUSEMOVE:OnMouseMove(AMsg);

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifTestLabel.zip(15.096kB)

TestLabel.gif以上で完成である。 実行時の様子を右図に示す。 L3 の TextAlign プロパティーに DT_EXPANDTABS を指定しているので、マウスのＸ座標が一桁から二桁、三桁に変わっても、'Y ='の位置が変化しないことに注意してほしい。タブは #9 、改行は #13 である。 L2 では TextAlign に DT_CENTER を指定している。 各行ごとに左右方向にセンタリングされているのが分かるだろう。

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

５−８ タイマ ： ＡＰＩレベルでの使用

Windows のタイマは、指定された時間間隔で周期的にプログラムに WM_TIMER メッセージを送る入力デバイスである。ハードウェアとしてのタイマ割り込みをＯＳレベルで抽象化したもので、その分解能は約５０ミリ秒である。 タイマは、 キーボードやマウスなどと同じ共通リソースであるので、アプリケーションでの使用には十分な注意が必要である。 しかし、その使い方は非常に易しい。SetTimer( ) と KillTimer( ) の二つのＡＰＩを使うだけだ。 このＡＰＩのペアを使うには、以下に示すの二つの方法がある。

まず、 この二つのＡＰＩの Windows.pas での宣言を見てみよう。タイマをインストールするには、

  function SetTimer(hWnd: HWND; 
                nIDEvent, 
                 uElapse: UINT;
             lpTimerFunc: TFNTimerProc): UINT; stdcall;

をつかう。第一パラメータは、このタイマを関連づけるウィンドウのハンドルを指定する。この値をゼロにすることもできる。 このときタイマはウィンドウとは独立にインストールされる。第二パラメータ nIDEvent には、タイマを識別する任意の整数を指定する。第一パラメータがゼロのときは、このパラメータは無視される。第三パラメータ uElapse は時間間隔をミリ秒単位で指定する整数値を指定する。最後のパラメータ lpTimerFunc は周期的に送られる WM_TIMER メッセージの宛先を指定するコールバック関数のアドレスを指定する。 このパラメータをゼロにすると、第一パラメータ hWnd が指定するウィンドウのウィンドウ関数に送られる。 この関数の戻り値は、 成功するとインストールされたタイマを識別する整数が返される。 失敗するとゼロが返される。 タイマのアンインストールは

  function KillTimer(hWnd: HWND; 
                 uIDEvent: UINT): BOOL; stdcall;

で行う。 第一パラメータ hWnd は、SetTimer( ) の第一パラメータと同じもの（ゼロを含む）を指定する。第二パラメータも、SetTimer( ) の第二パラメータと同じものを指定する。ただし、hWnd がゼロである場合は、SetTimer( ) の戻り値の整数を指定する。

以上の説明で大体の使い方は想像できるだろう。 二つの使い方のうちの第一の方法は、WM_TIMER メッセージをウィンドウ関数で受け取る場合である。インストールは、たとえば

  SetTimer(hWindow,1234,1000,nil);

として一秒毎にウィンドウ関数に WM_TIMER メッセージを送らせる。 このとき WParam には nIDEvent （上の例では 1234）の値が入っている。アンイストールは

  KillTimer(hWindow,1234);

とすればよい。

第二の方法は、 特定のコールバック関数に WM_TIMER メッセージを送らせる場合であり、

  TimerID := SetTimer(hWindow,1234,1000,@TimerProc);

としてインストールする。 hWindow はゼロでもいいが、そのときはこの関数の戻り値をグローバル変数などに保存しておく。 コールバック関数とは、プログラムのコードから呼ばれるのではなく、特別なＡＰＩを呼び出したあとで、ＯＳシステムから呼ばれる関数である。 ウィンドウ関数もコールバック関数の一つである。 タイマーのインストールによるコールバック関数の形は、

  procedure TimerProc(hWindow: HWND; 
                          Msg: UINT; 
                           ID: UINT;  
                       dwTime: DWORD); stdcall;

となっていて、第一パラメータはこのタイマをインストールした SetTimer( ) の第一パラメータが、Msg には WM_TIMER が、ID には SetTimer( ) の第二パラメータが、dwTime にはシステム時刻がセットされている。 アンインストールは、

  KillTimer(hWindow,1234);

か、ウィンドウハンドルにゼロを指定したときは

  KillTimer(0,TimerID);

とする。

それでは、この二つの方法をつかってタイマをテストするプログラムを作ろう。

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

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

program TimerAPI;

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

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
const
  Timer1ID = 1234;
  Timer2ID = 1235;
  
var
  Clr: COLORREF;


  L1, L2: TAPILabel;
  Btn1, Btn2: TAPISpeedBtn;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure TimerProc(hWindow:HWND;Msg:UINT;ID:UINT;dwTime:DWORD);stdcall;
begin
  if ID = Timer2ID then
    L2.Color := RGB(Random(255),Random(255),Random(255));
end;

procedure Btn1Click(var Msg:TMessage);
var
  hWindow:HWND;
begin
  hWindow := TAPISpeedBtn(Msg.Msg).Parent;
  SetTimer(hWindow,Timer1ID,500,nil);
  SetTimer(hWindow,Timer2ID,1000,@TimerProc);
  Btn1.Enable := false;
  Btn2.Enable := true;
end;

procedure Btn2Click(var Msg:TMessage);
var
  hWindow:HWND;
begin
  hWindow := TAPISpeedBtn(Msg.Msg).Parent;
  KillTimer(hWindow,Timer1ID);
  KillTimer(hWindow,Timer2ID);
  Btn1.Enable := true;
  Btn2.Enable := false;
end;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  L1 := CreateLabel(hWindow,20,20,160,160,'');
  with L1 do begin
    Color := clrRed;
    DrawFrame := true;
  end;

  L2 := CreateLabel(hWindow,200,20,160,160,'');
  with L2 do begin
    Color := clrRed;
    DrawFrame := true;
  end;

  Btn1 := CreateSpeedBtn(hWindow,50,190,100,40,'SetTimer',Btn1Click);

  Btn2 := CreateSpeedBtn(hWindow,230,190,100,40,'KillTimer',Btn2Click);
  Btn2.Enable := false;

  Randomize;
end;

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

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

procedure OnTimer(var Msg: TMessage);
begin
  if Msg.WParam = Timer1ID then

    L1.Color := RGB(Random(255),Random(255),Random(255));
end;

procedure OnDestroy(var Msg: TMessage);
var
  hWindow:HWND;
begin
  hWindow := Msg.Msg;
  KillTimer(hWindow,Timer1ID);
  KillTimer(hWindow,Timer2ID);
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//---------------  WM_TIMER   ---------------------------------

     WM_TIMER: OnTimer(AMsg);

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifTimerAPI.zip(14.909kB)

TimerAPI.gif以上で完成である。実行時の様子を右図に示す。Btn1 をクリックすると上記の二つの方法でタイマが二つインストールされる。Timer1ID のタイマは、MainWndProc に WM_TIMER メッセージを５００ミリ秒ごとに送る。ウィンドウ関数では、OnTimer( ) ハンドラで L1 のラベルの色をランダムに変化させる。 一方、 Timer2ID のタイマは WM_TIMER メッセージを独自のコールバック関数 TimerProc に １０００ミリ秒毎に送る。そこで、L2 ラベルの色をランダムに変化させる。 Btn2Click では、このふたつのタイマをアンインストールしている。

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

５−９ TAPITimer クラス

前節で、SetTimer( ) と KillTimer( ) ＡＰＩを利用したタイマの二通りの使い方を説明した。 これらのＡＰＩの機能をカプセル化して TAPITimer クラスを作ることにしよう。このクラスの実装には、どちらの方法が適しているだろうか。 第二の方法は、 独自のコールバック関数にメッセージを送るので、独立したクラスを設計するのに適している。 この方法を使って TObject から派生して TAPITimer をつくることを考えよう。 SetTimer( ) の第一パラメータには、適当なウィンドウハンドルを指定すればよい。第二パラメータは、オブジェクトインスタンスの参照 self を指定すれば便利だ。 このとき、コールバック関数では第二パラメータ ID としてこの参照が返ってくるので、処理は次のようにすればよい。

  if Assigned(TAPITimer(ID)) then TAPITimer(ID).Dispatch(AMsg);

このようにすれば、複数のオブジェクトがあっても、このメッセージを生成したタイマをインストールしたオブジェクトに必ずメッセージが届くことになる。 クラスの DefaultHandler では、このメッセージに応答して、OnTimer イベントを生成する。というシナリオになるだろう。 この実装方法の欠点は、 WM_TIMER 以外のメッセージを受け取れないので、このクラスのオブジェクトを廃棄するときは、コードで明示的に廃棄しなければならないことだ。これを克服するためには、TSubClass から派生すればよい。この場合、WM_TIMER メッセージはコールバック関数から、それ以外のメッセージは Dispatcher から転送されてくることになる。

一方、第一の方法では指定されたウィンドウ関数に WM_TIMER メッセージが届けられる。 したがって、このウィンドウ関数をサブクラス化している TSubClass の派生クラスとして TAPITimer クラスを実装することを考えよう。SetTimer( ) の第一パラメータには、親ウィンドウのハンドルを指定する。そして、第二パラメータには、ここでも self を指定する。このようにすると、WM_TIMER メッセージの WParam にはこの値が届けられるので、TAPITimer にキャストすれば、上記の第二の方法と同じようにオブジェクトにメッセージを転送できるだろう。 この場合は、 すべてのメッセージは Dispatcher から転送されてくる。 Dispatcher は、親ウィンドウの WM_DESTROY メッセージを受け取って自動的にこのオブジェクトを廃棄してくれる。ここでは、この実装方法を採用しよう。

TAPITimer クラスをつくり、これをテストするプログラムをつくる。

  1. エクスプローラを使って、新しいフォルダを 0508TestTimer という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 0507TimerAPI フォルダの Skeleton02.dpr と UtilFunc.pas と UtilClass.pas と GDIObject.pas をコピーする。
  3. コピーした Skeleton02.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton02.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで TestTimer.dpr という名前で保存する。
  5. コードエディタにフォーカスがあるようにしてから、[ Ctrl ] + [ f.12 ] を押して表示されるダイアログから UtilClass.pas を選んで OK ボタンを押し、コードエディタにこのユニットファイルを表示させる。
  6. コードエディタで以下のように編集する。
  7. コンパイルして実行する。

UtilClass.pas に TAPITimer を実装する。まず最初にこのユニットの implementation 予約語 のすぐしたにある uses 節を削除し、Interface 部 の uses 節に UtilFunc を追加する。 つぎに、宣言部の TSubClass の定義のしたに以下の定義を入れる。

//-----------------  TAPITimer -------------------------------------------
TAPITimer = class(TSubClass)
private
  FInterval : integer;
  FOnTimer: TNotifyMessage;
  FIsOn : Boolean;
public
  constructor Create(hParent: HWND); override;
  destructor Destroy; override;
  procedure DefaultHandler(var AMessage); override;
  procedure On;
  procedure Off;
  property IsOn: Boolean read FIsOn;
  property Interval: integer read FInterval write FInterval;
  property OnTimer: TNotifyMessage read FOnTimer write FOnTimer;
end;

実装部の末尾に以下のコードを書く。

//-----------------  TAPITimer -------------------------------------------
constructor TAPITimer.Create(hParent: HWND);
begin
  inherited Create(hParent);
  Dispatcher.TrapMessage(WM_TIMER,self);

  FInterval := 1000;
  FIsOn := false;
end;

destructor TAPITimer.Destroy;
begin
  Off;
  inherited Destroy;
end;

procedure TAPITimer.On;
begin
  if FIsOn = true then exit;
  FIsOn := true;
   // TimerID に 自分のオブジェクト参照を渡す！！
  SetTimer(Parent,integer(self),FInterval,nil);
end;

procedure TAPITimer.Off;
begin
  if FIsOn = false then exit;
  FIsOn := false;
  KillTimer(Parent,integer(self));
end;

procedure TAPITimer.DefaultHandler(var AMessage);
var
  AMsg: TMessage;
begin
  AMsg := TMessage(AMessage);
  if AMsg.Msg = WM_TIMER then
    if AMsg.WParam = integer(self) then begin
      AMsg.Msg := UINT(self);  // sender
      if Assigned(FOnTimer) then OnTimer(AMsg);
    end;
end;

これで、TAPITimer クラスの実装は終わりだ。コンストラクタでは Dispatcher に WM_TIMER メッセージを届けてくれるよう依頼している。 On メソッドで SetTimer( ) を呼び出してインストールするときに、第二パラメータとして自分のインスタンス参照を設定している。 そして、DefaultHandler の WM_TIMER の処理ではこのメッセージの WParam を参照して、このメッセージが自分がインストールしたタイマからのものであることを確認している。いる。 Off メソッドでは KillTimer( ) を呼び出している。 KillTimer( ) が呼び出されるまえにアプリケーションが終了する場合も考えて、Destroy デストラクタでも Off メソッドを実行している。 コードでは、FIsOn フィールドでタイマがインストール中であるか（true）、インストールされていないか（false) 判断しているので、二重にインストールされることを防いでいる。

次に、 このクラスのインスタンスをつくる関数を作成しよう。このクラスの宣言部のしたに以下の宣言を追加する。

//------------------------------------------------------------
//        Create Functions
//------------------------------------------------------------
function CreateTimer(hParent:HWND; Intrvl: integer;
                     OnTimerFunc: TNotifyMessage):TAPITimer;

そして実装部の最後にこの関数を実装する。

//------------------------------------------------------------
//        Create Functions
//------------------------------------------------------------
function CreateTimer(hParent:HWND; Intrvl: integer;
                     OnTimerFunc: TNotifyMessage):TAPITimer;
begin
  result := TAPITimer.Create(hParent);
  with result do begin
    Interval := Intrvl;
    OnTimer := OnTimerFunc;
  end;
end;

前節の TestTimerAPI と同じことをする TAPITimer をテストするプログラムを TestTimer.dpr に書こう。以下に全リストを示す。

program TestTimer;

uses

  windows,
  messages,
  UtilFunc in 'UtilFunc.pas',
  UtilClass in 'UtilClass.pas',
  GDIObject in 'GDIObject.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

  T1,T2: TAPITimer;
  L1, L2: TAPILabel;
  Btn1, Btn2: TAPISpeedBtn;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure T1OnTimer(var Msg:TMessage);
begin
  L1.Color := RGB(Random(255),Random(255),Random(255));
end;

procedure T2OnTimer(var Msg:TMessage);
begin
  L2.Color := RGB(Random(255),Random(255),Random(255));
end;

procedure BtnClick(var Msg:TMessage);
begin
  if T1.IsOn then T1.Off else T1.On;
  if T2.IsOn then T2.Off else T2.On;
  Btn1.Enable := not Btn1.Enable;
  Btn2.Enable := not Btn2.Enable;
end;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  T1 := CreateTimer(hWindow, 500,T1OnTimer);
  T2 := CreateTimer(hWindow,1000,T2OnTimer);

  L1 := CreateLabel(hWindow,20,20,160,160,'');
  with L1 do begin
    Color := clrRed;
    DrawFrame := true;
  end;

  L2 := CreateLabel(hWindow,200,20,160,160,'');
  with L2 do begin
    Color := clrRed;
    DrawFrame := true;
  end;

  Btn1 := CreateSpeedBtn(hWindow,50,190,100,40,'SetTimer',BtnClick);

  Btn2 := CreateSpeedBtn(hWindow,230,190,100,40,'KillTimer',BtnClick);
  Btn2.Enable := false;
  
  Randomize;
end;

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

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

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

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifTestTimer.zip(15.091kB)

以上で完成だ。実行すると前節の TimerAPI.dpr と同じ動作をするのが分かるだろう。もちろんこのクラスはＲＡＤ環境でも動作する。試してほしい。

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

５−１０ カスタムボタンと ColorMind ゲーム

この節は、 本稿のここまでに作ってきたクラスについての「まとめ」を書きたい。 第１章と２章では、 Win32 のＡＰＩレベルのコードをつかったメインウィンドウの作り方、メッセージ伝達機構、メニューの実装について調べ、 実際にプログラムを書いた。 そこでは、Delphi の Object Pascal というプログラミング言語のうちの Object を除いた部分、つまり Pascal の部分だけを利用していた。第３章では、ＧＤＩ関数を用いてメインウィンドウのクライアント領域に「絵」を描く練習をしてから、「任意の矩形領域を指定された色で塗りつぶす」という機能をカプセル化して TSpeedBtn というクラスを作った。 ここで、Object Pascal を本当に利用したことになる。

巷間には多くの Win32 ＡＰＩの解説書が出版されているが、その多くは Win32 の実装言語であるＣ言語を使ったものだ。ＡＰＩ関数を利用する程度のプログラムコードでは、Ｃと Pascal の言語仕様上の差異は驚くほど小さいものなので、Ｃで書かれたコードを Pascal に翻訳することはほとんど機械的にできる。したがって、Pascal 言語によって Win32 ＡＰＩを解説することは読者には多少の便宜を提供することにはなるが、あまり有意義な作業ではない。 Delphi のユーザーはＶＣＬという精緻な「クラスライブラリ」を利用してきているので、クラスを作ってコードの保守を堅牢にしたり、再利用率を高めたりすることにはほとんど無条件で同意できるだろう。ところが、Ｃを使って Win32 ＡＰＩの解説をすることから、Ｃ++ を使ってクラスをつかう決心をした途端に、その解説はＡＰＩを説明することからＭＦＣやＯＷＬなどのクラスライブラリを使ったプログラミングテクニックの紹介に重点が移行する。 クラスをつくることは、そのクラスをプログラム中で使用することが前提になるので、いきおい解説の記述はクラスそのものの説明に重点が移ってしまうわけだ。 本稿は、ＶＣＬの構造や使用法を紹介するためのものではなく、Win32 ＡＰＩを Delphi の Object Pascal で利用する方法を紹介するのが目的である。 Win32 ＡＰＩの特定の機能をカプセル化してクラスをつくることは避けられないにしても、カプセルの皮はできるだけ薄いことが望ましい。なにしろ、完璧なカプセル化の一例はＶＣＬで実現されているのだから。

本稿でここまでに作ってきたクラスのうち最も階層が深いクラスは TAPIColorBtn である。 TObject - TSubClass - TGDIObject - TAPISpeedBtn - TAPIColorBtn という階層だ。 ちなみに、ＶＣＬの TSpeedButton の場合は、 TObject - TPersistent - TComponent - TControl - TGraphicControl - TSpeedButton という具合だ。 TAPIColorBtn は TSpeedButton より階層の数が一段階浅いだけだが、実装コードの量は多分１０分の１以下だろう。 また、メッセージの処理をする DefaultHandler は継承メソッドを呼び出さずに全ての処理をそのクラスで実装することにしているので、ナマのＡＰＩ関数の機能をカプセル化する様子が理解しやすいだろう。ここまでで作ってきたクラスは TAPITimer と TMessageDispatcher を除けば、すべてＡＰＩでクライアント領域に「絵」を描く機能をコードで包みこんだものだ。どのテストアプリケーションでも、ＯＳが認識するウィンドウはメインウィンドウが唯一のものだった。 ボタンもラベルもＯＳから見ればただの「絵」である。 TGDIObject の派生クラスとしては、ＶＣＬの TCanvas や TImage、TPaintBox、TBevel、TBitmap、TShape などに相当するクラスが考えられる。 これらのうちの幾つかは、後の章でつくることにするが、「絵」をカプセル化したクラスについてはここで一段落としよう。次章からは、 Win32 の定義済み子ウィンドウであるプッシュボタンやリストボックス、エディット、コンボボックス、スクロールバーなどについて紹介してゆく。これらは、ウィンドウハンドルを持つ本物のウィンドウである。

ColorMind.gif「絵」を描く機能のクラスのここまでのまとめとして、右図のような ColorMind というゲームを作ろう。 クラスがナマのＡＰＩの機能のごく薄い皮のカプセルであることと、その実装コードをすべて把握していることの最大のメリットの一つは、 特定のアプリケーションのためのカスタムクラスを簡単に設計できることだ。 ここでは、ColorMind のために TClrMindBtn という小さなクラスをつくる。それではさっそく ColorMind を作ろう。

  1. エクスプローラを使って、新しいフォルダを 0509ColorMind という名前でつくる。
  2. 作ったフォルダに、エクスプローラを使って 0508TestTimer フォルダの Skeleton02.dpr と UtilFunc.pas と UtilClass.pas と GDIObject.pas をコピーする。
  3. コピーした Skeleton02.dpr をダブルクリックして Delphi を立ち上げる。
  4. コードエディタに Skeleton02.dpr のコードがあることを確認してから、[ファイル]メニューから[プロジェクトに名前を付けて保存]を選んで ColoMind.dpr という名前で保存する。
  5. コードエディタにフォーカスがあるようにしてから、[ Ctrl ] + [ f.12 ] を押して表示されるダイアログから GDIObject.pas を選んで OK ボタンを押し、コードエディタにこのユニットファイルを表示させる。
  6. コードエディタで以下のように編集する。
  7. コンパイルして実行する。

まず、TAPISpeedBtn を継承して TClrMindBtn クラスを GDIObject.pas につくろう。 Interface 部の TAPILabel の下に以下の定義を書く。

//-------------  TClrMindBtn ----------------------------------------------
TColorKind = (crkWhite,crkRed,crkGreen,crkBlue,crkYellow);

TClrMindBtn = class(TAPISpeedBtn)
private
  FColorKind : TColorKind;
  procedure SetColorKind(value:TColorKind);
public
  constructor Create(hParent:HWND); override;
  procedure DefaultHandler(var Message);override;
  property Edge: UINT read FEdge;
  property ColorKind: TColorKind read FColorKind write SetColorKind;
end;

そして、実装部の末尾に以下のコードを書く。

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

  ColorKind := crkRed;
end;

procedure TClrMindBtn.DefaultHandler(var Message);
var
  DC:HDC;
  hBr: hBrush;
  dr: TRect;
  AMsg:TMessage;
  clr: COLORREF;
  pt: TPoint;
begin
  if not FVisible then Exit;

  AMsg := TMessage(Message);

  case AMsg.Msg of

    WM_PAINT : begin
      DC := GetDC(Parent);
        if FEnable then
          hBr := CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
        else
          hBr := CreateSolidBrush(clrDkGray);
        FillRect(DC, FRect, hBr);
        DeleteObject(hBr);
        DrawEdge(DC, FRect, FEdge, BF_RECT);
        dr := FRect;
        InflateRect(dr,-8,-8);
        clr:= clrWhite;
        if FEdge = EDGE_RAISED then begin
          OffsetRect(dr,-1,-1);
          case FColorKind of
            crkWhite: clr := clrDkGray;
            crkRed   : clr := clrMaroon;
            crkGreen : clr := clrGreen;
            crkBlue  : clr := clrBlue;
            crkYellow: clr := clrOlive;
          end;
        end else begin
          OffsetRect(dr,1,1);
          case FColorKind of
            crkWhite: clr := clrWhite;
            crkRed   : clr := RGB(255,50,50);
            crkGreen : clr := clrLime;
            crkBlue  : clr := clrAqua;
            crkYellow: clr := clrYellow;
          end;
        end;
        DrawEdge(DC,dr,EDGE_ETCHED,BF_RECT);
        InflateRect(dr,-4,-4);
        hBr := CreateSolidBrush(clr);
        FillRect(DC, dr, hBr);
        DeleteObject(hBr);
      ReleaseDC(Parent,DC);
    end;

    WM_LBUTTONDOWN: begin
      if not FEnable then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if PtInRect(FRect,pt) then begin
        FEdge := EDGE_SUNKEN;
        MessageBeep($FFFFFFFF);
        FDown := true;
        UpDate;
      end;
    end;

    WM_LBUTTONUP: begin
      if not FEnable then Exit;
       if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
        AMsg.Msg := UINT(self);  // sender
        if Assigned(FOnClick) then OnClick(AMsg);
      end;
    end;

    WM_MOUSEMOVE: begin
      if not FEnable then Exit;
      if not FDown then Exit;
      pt.x := AMsg.LParamLo;
      pt.y := AMsg.LParamHi;
      if not PtInRect(FRect,pt) then begin
        FEdge := EDGE_RAISED;
        FDown := false;
        UpDate;
      end;
    end;

    WM_USER: begin
      FEdge := EDGE_RAISED;
      Update;
    end;

    WM_USER+1: begin
      FEdge := EDGE_SUNKEN;
      Update;
    end;

  end; // case
end;

procedure TClrMindBtn.SetColorKind(value:TColorKind);
begin
  FColorKind := value;
  Update;
end;

実装コードを見ればわかるように、TClrMindBtn はボタンの矩形の内側に窪んだ矩形の枠を DrawEdge( ）の第三パラメータを EDGE_ETCHED に設定して描画し、さらにその内側に ColorKind プロパティーで指定する色で塗りつぶされた矩形領域を描画する。ボタンを押すと、矩形領域の色が対応する明度の高い色に変化する。 このクラスは WM_USER と WM_USER+1 のメッセージを受け取り、それぞれボタンを押さないときと押したときの描画をシミュレートする。これは、コードでボタンを押すアニメーションを実現するためのものだ。 このクラスをつかって ColorMind.dpr にゲームを実装する。ColorMind.dpr の全リストを以下に示す。

program ColorMind;

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

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
const
 CRK: array[0..4] of TColorKind =
                     (crkWhite,crkRed,crkGreen,crkBlue,crkYellow);
  
var
  Clr: COLORREF;

  Label1: TAPILabel;
  Timer1: TAPITimer;

  Btn: array[0..4] of TClrMindBtn;
  StartBtn: TAPIColorBtn;
  SQ: array[1..30] of Integer;
  FlagUser: Boolean;
  MaxPush, IPush: Integer;

//------------------------------------------------------------
//             Object Event Handlers
//------------------------------------------------------------
procedure Timer1Timer(var Msg:TMessage);
var
  AMsg: TMessage;
begin
  MessageBeep($FFFFFFFF);
  if Btn[SQ[IPush]].Edge = EDGE_RAISED then begin
    AMsg.Msg := WM_USER+1;
    Btn[SQ[IPush]].Dispatch(AMsg);
  end else begin
    AMsg.Msg := WM_USER;
    Btn[SQ[IPush]].Dispatch(AMsg);
    if IPush < MaxPush then
      Inc(IPush)
    else begin
      Timer1.Off;
      IPush := 1;
      FlagUser := true;
      Label1.Text := 'あなたの番です'#13+
                     '押す回数 : '+AIntToStr(MaxPush);
    end;
  end;
end;

procedure BtnClick(var Msg:TMessage);
begin
  if not FlagUser then Exit;
  if Msg.Msg = DWORD(Btn[SQ[IPush]]) then begin
    Label1.Text := '正 解!'#13+'残り回数 : '+AINtToStr(MaxPush-IPush);
    Inc(IPush);
    if IPush = MaxPush+1 then begin
      Inc(MaxPush);
      If MaxPush = 31 then begin
        FlagUser := false;
        Label1.Text := '素晴らしい!! これが最高点'#13+
                       '得点 : 30';
        StartBtn.Enable := true;
      end else begin
        IPush := 1;
        FlagUser := false;
        Timer1.On;
        Label1.Text := 'コンピュータが押します'#13+
                       '押す回数 : '+AIntToStr(MaxPush);
      end;
    end;
  end else begin
    MessageBeep(MB_OK);
    Label1.Text := 'はずれ!'#13#13+'ゲーム終了'#13+'得点 : '+
                                            AIntToStr(MaxPush-1);
    FlagUser := false;
    StartBtn.Enable := true;
  end;
end;

procedure StartBtnClick(var Msg:TMessage);
var
  i:integer;
begin
  for i := 1 to 30 do
    SQ[i] := Random(5);
  MaxPush := 1;
  IPush := 1;
  FlagUser := false;
  Timer1.On;
  Label1.Text := 'コンピュータが押します';
  StartBtn.Enable := false;
end;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
  i: integer;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  ChangeWindowSize(hWindow,280,270);
  CenterWindow(hWindow);

  for i := 0 to 4 do begin
    Btn[i] := TClrMindBtn.Create(hWindow);
    with Btn[i] do begin
      Dimension := SetDim(10+50*i,10,40,40);
      ColorKind := CRK[i];
      OnClick := BtnClick;
    end;
  end;

  Timer1 := CreateTimer(hWindow,500,Timer1Timer);

  Label1 := CreateLabel(hWindow,10,60,240,120,'');
  with Label1 do begin
    TextAlign := DT_CENTER;
    Margin := 5;
    Text := 'ColorMind Game'#13+'コンピュータの押したとおりに'#13+
            'ボタンを押してください'#13#13+
            'スタートボタンを押す';
  end;

  StartBtn := CreateColorBtn(hWindow,60,190,150,32,'Start',StartBtnClick);
  with StartBtn do begin
    Color := clrGreen;
    TextColor := clrWhite;
  end;

  FlagUser := false;

  Randomize;
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

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

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

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

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

DownloadExe.gifColorMind.zip(16.353kB)

ここでは、メニューを実装していない。したがって、OnTest( ) と OnCommand( ) ハンドラを削除している。さらに、MainWndProc の WM_COMMAND メッセージをトラップしているコードも削除している。 以上で完成である。 実行して遊んでみよう。実行時の様子を上図に示す。 ゲームのロジックの説明は、本稿の目的と異なるのでしない。 私の現時点までの最高点は１４点である。６年前に買った Windows3.1 用のシェアウェアやフリーウェアを集めた CD-ROM に似たようなゲームがあった。そのゲームでは、最初３個の色ボタンがあって、６回押しまで正解すると次の段階に進み、４個の色ボタンで８回押しまで成功すると次の段階に進み..というふうにゲームが進行してゆく。 ボタンの配置も個数によってサイコロの目の配置のように変えていくと楽しいだろう。今回の実装では、５個のボタンで３０回押しまでの得点を競うものである。読者の方々には見栄えの良いボタンを設計して、このゲームを拡張してより楽しいものにしてほしい。

コンパイルしてできた ColorMind.exe のサイズは、筆者の現在の環境では 27.136 キロバイトである。このように小さくて（多分）速い実行可能ファイルをつくることは、プログラマにとっては気持ちの良いことにちがいない。また、メインウィンドウ以外の全ての「部品」は、ＡＰＩの機能を Delphi の Object Pascal のコードで包み込んだクラスを使用している。 そして、それらは TAPITimer クラス以外は、すべてメインウィンドウに描かれた「絵」であるにすぎないと言うことをここで強調しておきたい。

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

５−１１ まとめ

前章で作成した TSubClass クラスから派生して、本章では「絵を描く機能をカプセル化したクラス」の上位クラスとなる TGDIObject を作成した。 さらに、TGDIObject から派生して TAPISpeedButton、TAPIColorBtn、TAPILabel クラスを作成しテストした。 メッセージを親ウィンドウのウィンドウ関数に依存しないで、サブクラス化により独自に取得できることを、ＲＡＤ環境でも確かめた。 TSubClass から派生し、コンストラクタの継承メソッドを使って Dispatcher オブジェクトを作成し、その TrapMessage メソッドを使って特定のメッセージを配送するように依頼すると、サブクラス化したウィンドウ関数から得たメッセージを Dispatcher オブジェクトが送ってくれる。 受け取ったオブジェクトは、DefaultHandler でこのメッセージを処理し、イベントハンドラを呼び出す。 上記のクラスは、どれも WM_PAINT メッセージをを処理し、ウィンドウのクライアント領域に自分を描画する能力を持っている。 WM_TIMER メッセージを処理する TAPITimer クラスを TSubClass から直接派生して作成した。 非可視のクラスでメッセージを処理するには、このように TSubClass から直接派生すればよい。 TSubClass の派生クラスのインスタンスは、Dispatcher が親の WM_DESTROY メッセージを受け取ったときに自動的に解放される。 最後に、カスタムクラスの作成例として ColorMind というゲームのために TClrMindBtn クラスを TAPISpeedBtn から派生してつくり、これをつかって簡単なゲームをつくった。

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


  1. Skeleton02.dpr (3 kB)
  2. UtilFunc.pas (8 kB)
  3. UtilClass.pas (13 kB)
  4. GDIObject.pas (16 kB)


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