コンポーネント

StatusBarの矩形領域を取得する
マウスが近づくと自動的にドロップダウンするコンボボックス
URLのリストを表示するコンボボックス
Delphi5のCompanion CD-ROMに入っているコンポーネント
ApplicationEventsコンポーネント
NetScape NavigaterのStatusBar
メニューのオーナードロー
右クリックでも押せるボタン（ボタンのサブクラス化）
ドラッグ＆ドロップを受け入れるTMemoとTImage
Memoコンポーネントのキャレットを消す

StatusBarの矩形領域を取得する

タイトルのことを実現するには，StatusBarにSB_GETRECTメッセージを送り， WParamに矩形領域を取得したいパネルのインデックスを，LParamにTRect型変数のアドレスをそれぞれ設定する．このメッセージはCommCtrlユニットで宣言されているが，Statusbarをフォームに追加しただけではこのユニットはuses節に追加されないので，手動で追加する必要がある．

procedure TForm1.Button1Click(Sender: TObject);
var
  Rect: TRect;
begin
   StatusBar1.Perform( SB_GETRECT, 1, LParam( @Rect ) );
   ShowMessage( Format( 'L: %d, T: %d, R: %d, B: %d',
     [ Rect.Left, Rect.Top, Rect.Right, Rect.Bottom ] ) );
end;

マウスが近づくと自動的にドロップダウンするコンボボックス

通常のコンボボックスは左端の矢印がクリックされたときにリストボックスがドロップダウンするが，以下のコードはマウスポインタがコンボボックス内に入っただけで自動的にドロップダウンするコンボボックスを実現する．

CM_MOUSEENTERメッセージが来たときに WM_LBUTTONDOWNおよびWM_LBUTTONUPの二つのメッセージを続けて送る．これらのメッセージのLParamには，左端矢印のxおよびy座標をMakeLongした値を設定する．そのため，GetWindowRectを使って編集領域(左端矢印を除いた部分)の幅を取得し，矢印の中心部分の座標を求めている． EditHandleプロパティは編集領域のウィンドウハンドルである．

procedure TAutoDropComboBox.CMMouseEnter( var Mes: TMessage );
var
  Rect: TRect;
  EditWidth: Integer;
  X, Y: Word;
begin
   inherited;
   if not DroppedDown then
   begin
      GetWindowRect( EditHandle, Rect );
      EditWidth := Rect.Right - Rect.Left;
      X := EditWidth + ( Width - EditWidth ) div 2;
      Y := Height div 2;
      Perform( WM_LBUTTONDOWN, MK_LBUTTON, MakeLong( X, Y ) );
      Perform( WM_LBUTTONUP, MK_LBUTTON, MakeLong( X, Y ) );
   end;
end;

2000/8/2修正
上のようなコードを書かなくても，単に，

procedure TAutoDropComboBox.CMMouseEnter( var Mes: TMessage );
begin
   inherited;
   if not DroppedDown then DroppedDown := True;
end;

で良いようである．

2000/8/3追加
マウスがコンボボックスから出たら自動的にリストボックスを閉じるようにするには， CM_MOUSELEAVEメッセージが来たときに，

procedure TAutoDropComboBox.CMMouseLeave( var Mes: TMessage );
begin
   inherited;
   if DroppedDown then DroppedDown := False;
end;

とすれば良いように思われるが，これだと編集領域から出ただけでリストボックスが閉じてしまい，項目を選択することさえできない．このことを実現するにはApplicationオブジェクトのOnIdleイベントを使う方法とフックを使う方法の二通りある．

ApplicationオブジェクトのOnIdleイベントを使う
コンボボックスからドロップダウンするリストボックスの大きさを取得するには，コンボボックスに CB_GETDROPPEDCONTROLRECTメッセージを送り，LPARAMにTRect型変数のアドレスを設定する．このメッセージは少なくとも1回はドロップダウンした後でないと正しい値を返さないようである．まだ1回もドロップダウンしていないときはコンボボックスの編集領域の大きさが返ってくる．
リストボックスの大きさが取得できたら，MouseオブジェクトのCurrentPosプロパティか GetCurrentPos関数により現在のマウス位置を取得し，PtInRect関数を使ってリストボックス上にあるか否かを判定する．もしリストボックス上にないならばDroppedDownプロパティにFalseを代入する．
```
procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnIdle := FormIdle;
end;

procedure TForm1.FormIdle( Sender: TObject; var Done: Boolean );
var
  ListRect: TRect;
begin
   if AutoDropComboBox1.DroppedDown then
   begin
      AutoDropComboBox1.Perform( CB_GETDROPPEDCONTROLRECT,
                 0, LParam( @ListRect ) );
      if not PtInRect( ListRect, Mouse.CursorPos ) then
          AutoDropComboBox1.DroppedDown := False;
   end;
end;
```
フックを使う
フォームに送られてくるマウスメッセージをフックすることでも同様のことを実現できる．仕掛けるフックの種類はWH_MOUSEである．このフックのフックプロシージャは次のように定義する．
```
function MouseProc( nCode: Integer; wParam: Longint;
          var Mes: TMouseHookStruct ): LRESULT; stdcall;
var
  ListRect: TRect;
begin
   Result := CallNextHookEx( HHook, nCode, wParam, Longint( @Mes ) );
   if Form1.AutoDropComboBox1.DroppedDown then
   begin
      Form1.AutoDropComboBox1.Perform( CB_GETDROPPEDCONTROLRECT,
                 0, LParam( @ListRect ) );
      if not PtInRect( ListRect, Mes.pt ) then
          Form1.AutoDropComboBox1.DroppedDown := False;
   end;
end;
```
3番目の引数としてTMouseHookStruct型変数へのアドレスが送られてくるが，フックプロシージャではこれをvar付きの変数パラメータとして受け取る．この変数のptメンバーにマウスの位置が設定されている．
フックをインストールするには，フォームのOnCreateイベントに以下のように書く．
```
var
  HHook: THandle;

procedure TForm1.FormCreate(Sender: TObject);
begin
  HHook := SetWindowsHookEx( WH_MOUSE, @MouseProc, 0, GetCurrentThreadID );
end;
```
また，フォームを閉じるときには必ずフックをアンインストールしなければならない．
```
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  UnhookWindowsHookEx( HHook );
end;
```

URLのリストを表示するコンボボックス

右図のようなWebサイトの一覧を表示するコンボボックスを作成する． Webサイトをクリックするとブラウザが起動し，そのサイトが表示される．

まずフォームのOnCreateイベントでコンボボックスに表示するサイト名とそのURLを設定する． AddObjectメソッドを用い，2番目の引数はString型変数をTObjectにキャストする．

procedure TForm1.FormCreate(Sender: TObject);
var
  URL: String;
begin
   URL := 'http://www.kyushu-u.ac.jp';
   ComboBox.Items.AddObject( '九州大学', TObject( URL ) );
   
   ...... 略 ......
   
   URL := 'http://www.watch.impress.co.jp/akiba/';
   ComboBox.Items.AddObject( 'Akiba PC Hotline!', TObject( URL ) );
   ComboBox.ItemIndex := 0;
end;

次に，コンボボックスのOnClickメソッドに以下のように書く． Objectsプロパティの中身をStringにキャストし，String型変数に代入する．ブラウザを起動するにはShellExecute関数を用いる．この関数はSellAPIユニットで宣言されているので，このユニットをuses節に追加する．

procedure TForm1.ComboBoxClick(Sender: TObject);
var
  URL: String;
  SelIndex: Integer;
begin
   SelIndex := ComboBox.ItemIndex; // 選択項目のインデックスを取得
   URL := String( ComboBox.Items.Objects[ SelIndex ] ); // URLを取得
   ShellExecute( 0, 'open', PChar( URL ), nil, nil, SW_SHOW ); //ブラウザを起動
end;

なお，右図のプログラムではコンボボックスのStyleプロパティをcsOwnerDrawFixedにし， OnDrawItemイベントに以下のように書いている． ImageListにはリストの左端に表示するビットマップを設定してある．

procedure TForm1.ComboBoxDrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  S: String;
begin
   if ComboBox.Cursor = crDefault then
      ComboBox.Cursor := crHandPoint;
   S := ComboBox.Items[ Index ];
   with ComboBox do
   begin
      if odSelected in State then
      begin
         Canvas.Brush.Color := clHighLight;
         Canvas.Font.Color := clHighLightText;
         Canvas.Font.Style := Canvas.Font.Style + [ fsBold ];
      end
      else begin
         Canvas.Brush.Color := Color;
         Canvas.Font.Color := clWindowText;
         Canvas.Font.Style := Canvas.Font.Style - [ fsBold ];
      end;
      Canvas.FillRect( Rect );
      ImageList.Draw( Canvas, Rect.Left, Rect.Top, 0, True );
      SetBkMode( Canvas.Handle, TRANSPARENT );
      Rect.Left := Rect.Left + ImageList.Width + 2;
      DrawText( Canvas.Handle, PChar( S ), -1, Rect,
        DT_LEFT or DT_SINGLELINE or DT_VCENTER );
   end;
end;

Delphi5のCompanion CD-ROMに入っているコンポーネント

Delphi5のCompanion CD-ROMにはいろいろと面白いコンポーネントが入っている．その中で，米国Developer Expressのフリーコンポーネントを使ってみた． CD-ROMにはソースコードが同梱されていないが，ここからダウンロードできる．ただし，ダウンロードしたアーカイブを解凍するには，ユーザー登録した後にメールで送られて来るパスワードが必要．ユーザー登録は無料である．

dfxProgressBar
通常のProgressBarにインジケータのグラデーション表示や立体表示の機能を追加したものである．
dfxLabel
影付き文字や縁取り文字，くぼんだ文字を表示できるLabel．
dfxCheckBox
チェックマークにビットマップを指定できるCheckBox．
dfxColorBotton
色付きの丸ボタンである．プロパティエディタで複数行のCaptionが指定できる．
dfxClock
アナログとデジタルの両方表示可能な時計である．図のように電光掲示板のような表示もできる．拙作のClockコンポーネントよりもはるかに完成度は高い．

他にも，フォームの背景をグラデーションにするdfxBackgroundや任意のビットマップをフォームに割り当てることができるdfxShapedFormなどがある．会社宣伝のためとは言え，このようなすばらしいコンポーネントをソースまでもフリーで公開しているのには頭が下がる．

ApplicationEventsコンポーネント

Delphi 5から加わったApplicationEventsコンポーネントを使うと，Applicaionオブジェクトのイベントハンドラを通常のコンポーネントと同じように書くことができる．例えば，上の例の場合だと，フォームにApplicationEventsコンポーネントを追加し，そのOnIdleイベントに同じコードを書けばよい．

NetScape NavigaterのStatusBar

ここにあるShockPanelコンポーネントは面白い．アニメーション動作をするグラデーション領域を提供するものである．これを使えば，ちょうどNetScapeのStatusBarのようなコンポーネントを実現できる．

以下のコードは，StatusBarの最初のパネル上にShockPanelを作成するものである．

procedure TForm1.Button2Click(Sender: TObject);
var
  Rect: TRect;
begin
   StatusBar.Perform( SB_GETRECT, 0, LParam( @Rect ) );
   InflateRect( Rect, -1, -1 );
   FShockPanel := TShockPanel.Create( Self );
   with FShockPanel do
   begin
      Parent := StatusBar;
      SetBounds( Rect.Left, Rect.Top, Rect.Right - Rect.Left,
                 Rect.Bottom - Rect.Top );
      Style := skReflection;
      ForeColor := clNavy;
   end;
end;

このコンポーネントの作者はかなりの達人のようで，ホームページには凝ったコンポーネントがいろいろと置いてある．

メニューのオーナードロー

MainMenuやPopupMenuのOwnerDrawプロパティをTrueにしておくと，各MenuItemの描画時にOnDrawItemイベントが発生するようになり，このイベントハンドラの中で自在にメニュー項目を描画できる．

上に示した例では，各MenuItemをクリックするとメニュー項目に設定されたアプリケーションが起動する．アプリケーション起動のからくりは，MenuItemのHintプロパティにコマンドパスの文字列（"c:\program files\internet explorer\iexplore.exe" など）を設定しておき， MenuItemのOnClickイベントを

procedure TMainForm.BrowserStartMenuClick(Sender: TObject);
var
  Command: String;
begin
   Command := TMenuItem( Sender ).Hint;
   ShellExecute( 0, 'open', PChar( Command ), nil, nil, SW_SHOW );
end;

のように書いている．これでこのMenuItemがクリックされたときにブラウザが起動する．メニュー項目の左端に実行ファイルのアイコンを表示するためには， MenuItemのOnDrawItemイベントを以下のように書く．

procedure TMainForm.BrowserStartMenuDrawItem(Sender: TObject;
  ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
var
  FileName, S: String;
  SFI: TSHFileInfo;
  Flag: Cardinal;
begin
   if Selected then
   begin
      ACanvas.Brush.Color := clHighLight;
      ACanvas.Font.Color := clHighLightText;
   end
   else begin
      ACanvas.Brush.Color := clMenu;
      ACanvas.Font.Color := clMenuText;
   end;
   ACanvas.FillRect( ARect );
   FileName := TMenuItem( Sender ).Hint;
   S := TMenuItem( Sender ).Caption;
   Flag := SHGFI_ICON or SHGFI_SMALLICON;
   SHGetFileInfo( PChar( FileName ), 0, SFI, SizeOf( SFI ), Flag );
   DrawIconEx( ACanvas.Handle, ARect.Left + 3, ARect.Top + 2,
          SFI.hIcon, 0, 0, 0, 0, DI_NORMAL );
   DeleteObject( SFI.hIcon );
   ACanvas.TextOut( ARect.Left + 25,
      ARect.Top + ( ( ARect.Bottom - ARect.Top )
        - ACanvas.TextHeight( S ) ) div 2, S );
end;

この例では，ここに書いたSHGetFileInfo APIを使って実行ファイルのアイコンのハンドルを取得している．

ただし，単にOnDrawItemのイベントハンドラを書いただけでは，メニューの幅にアイコンとキャプションが収まりきらない場合がある．親メニューのOwnerDrawプロパティがTrueの場合は，メニュー項目の幅に合わせてMenuItemの幅が自動的に伸縮しないようだ．そのような場合は，OnDrawItemだけでなくOnMeasureItemのイベントハンドラも記述する必要がある．上の例では，

procedure TMainForm.BrowserStartMenuMeasureItem(Sender: TObject;
  ACanvas: TCanvas; var Width, Height: Integer);
var
  S: String;
begin
   S := TMenuItem( Sender ).Caption;
   Width := ACanvas.TextWidth( S ) + 25;
   Height := 20;
end;

などと書けばうまくいく．

以下はオーナードローメニューの例である．右のグラデーション処理はここに書いたgrade32.dllを使っている．

背景にビットマップを描画した例	背景をグラデーション処理した例

親メニューのOnClickの中で背景に描画するビットマップを用意しておき， MenuItemのOnDrawItemでBitBlt APIを使って背景ビットマップの一部をMenuItemにコピーする．ソースコードは以下の通り．

function  GD_FillRectV( HDC: THandle; Left, Top, Right, Bottom: Integer;
      StartColor, MidColor, EndColor: COLORREF; MidPosition: Integer ): BOOL;
       stdcall; external 'grade32.dll';

procedure TMainForm.FormCreate(Sender: TObject);
begin
   FBack := TBitmap.Create;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
   FBack.Free;
end;

procedure TMainForm.New1DrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; Selected: Boolean);
var
  Index: Integer;
  Text: String;
begin
   Index := TMenuItem( Sender ).MenuIndex;
   Text := TMenuItem( Sender ).Caption;
   BitBlt( ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left,
           ARect.Bottom - ARect.Top, FBack.Canvas.Handle,
           0, Index * ( ARect.Bottom - ARect.Top ), SRCCOPY );
   ACanvas.Font.Style := ACanvas.Font.Style + [fsBold ];
   SetBkMode( ACanvas.Handle, TRANSPARENT );
   ARect.Left := ARect.Left + 5;
   DrawText( ACanvas.Handle, PChar( Text ), -1, ARect,
         DT_SINGLELINE or DT_VCENTER );
end;

procedure TMainForm.New1MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
begin
   Width := 150;
   Height := 20;
end;

procedure TMainForm.File2Click(Sender: TObject);
begin
   FBack.LoadFromFile( 'otoha.bmp' );
end;

procedure TMainForm.Edit1Click(Sender: TObject);
begin
   FBack.Free;
   FBack := TBitmap.Create;
   FBack.Width := 200;
   FBack.Height := 20 * TMenuItem( Sender ).Count;
   GD_FillRectV( FBack.Canvas.Handle, 0, 0, FBack.Width, FBack.Height,
      clAqua, clLime, clYellow, 50 );
end;

右クリックでも押せるボタン（ボタンのサブクラス化）

ここに移動した．

ドラッグ＆ドロップを受け入れるTMemoとTImage

ここに移動した．

Memoコンポーネントのキャレットを消す

TMemoやTEditで入力位置に点滅する "|" をキャレット（caret）と呼ぶ．メッセージを表示するためだけにTMemoを使った場合，フォーカスがあるときにキャレットが表示されてしまい具合が悪い．このキャレットを消す方法を検討してみた．

ドキュメントを調べてみると，そのものズバリのHideCaretというAPIが見つかった．このAPIのプロトタイプは

function HideCaret( hWnd: HWND ): BOOL; stdcall;

となっている．キャレットを消したいウィンドウのハンドルを指定するだけである． nilが指定された場合，キャレットを持つウィンドウを検索してくれるらしい．

問題はHideCaretを呼び出すタイミングである． APIのヘルプには，HideCaretは指定されたウィンドウがキャレットを持つ場合に限り，そのキャレットを消すという意味のことが書かれている．したがって，フォームのOnCreateイベントなどで

 HideCaret( Memo1.Handle );

などとしてもダメである（実際ダメだった）．

いろいろ試してみたが，WM_PAINTメッセージを処理した直後にHideCaretを呼び出せばうまくキャレットが消せるようだ． TMemoだとWM_SETFOCUSメッセージを処理した直後でもよい（TRichEditではダメ）．これらのメッセージに対するハンドラをオーバーライドしたコンポーネントを作ってもいいが，こういう場合はここに書いたサブクラス化が手っ取り早い．例えば以下のようなウィンドウプロシージャ（WP）を定義しておく．

var
  OrgProc: Pointer;

function NewProc( hwnd: HWND; iMsg: UINT;
                  wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall;
begin
   Result := CallWindowProc( OrgProc, hwnd, iMsg, wParam, lParam );
   if iMsg = WM_PAINT then HideCaret( hwnd );
end;

OrgProcは元のWPのアドレスを保持しておく汎用ポインタである．当然，WPはstdcallにしなければならない．あとは，フォームのOnCreateイベントあたりでSetWindowLongを使ってTMemoのWPを上のNewProcにすりかえればよい．

procedure TForm1.FormCreate(Sender: TObject);
var
  Rect: TRect;
begin
   OrgProc := Pointer( SetWindowLong( Memo1.Handle, GWL_WNDPROC,
                      DWORD( @NewProc ) ) );
   Rect := Memo1.ClientRect;
   InflateRect( Rect, -10, 0 );
   Memo1.Perform( EM_SETRECT, 0 , LPARAM( @Rect ) );
end;

なお，上の例ではTMemoの描画領域を変更するEM_SETRECTメッセージを送っている．これに関してはここに解説がある．

お問い合わせはメールにて: akasaka@klc.ac.jp

戻る

SEO [PR] 爆速!無料ブログ無料ホームページ開設無料ライブ放送

SEO		[PR] 爆速!無料ブログ無料ホームページ開設無料ライブ放送