Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2014年11月17日] [更新 2014年11月19日] Delphi サンプルプログラム集
   
128_ポップアップ表示する TListBox コンポーネント
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
128_PopUpListBox.zip [562 KB] 2014年11月19日版(EXE同梱)



  • 2014年11月19日
  • テストの結果,MouseCapture は必要ないようなので,関係コードを削除
  • ポップアップ表示開始メソッドの引数を変更




TListBox をポップアップ表示するコンポーネント


TListBox をポップアップ表示する例です.TListBox の部分はコンポーネントにしています.このコードは,下記のリンクに掲載されているコードを,筆者が整備したものです.

TListBox に追加したのは,以下の ShowBeneath メソッドと OnCloseUp イベントだけです.
ポップアップ表示するには ShowBeneath メソッドを使用します.ShowBeneath の引数は表示位置を設定するために使用します.OnCloseUp は TListBox が閉じた直後に発生するイベントです.

MultiSelect の値が True の時は,クリックでは閉じません.[Enter] キー押下か TListBox 以外の場所をクリックすると閉じます.[ESC] キーで閉じると,ItemIndex の値は -1 となります.



ShowBeneath (aLeft, aTop aHeight)

引数 説明
aLeft Integer 表示開始位置の左端の X 座標値.スクリーン座標で指定する
aTop Integer 表示開始位置の上端の Y 座標値.スクリーン座標で指定する
aHeight Integer 省略可能
この値が指定されていると,画面の下端に表示する際にこの高さの分だけ上方から表示する


OnCloseUp (Sender)

引数 説明
Sender TObject 本コンポーネント


以下が,実際のテストプログラムとコンポーネントのソースコードです.コンポーネントは実行時に生成してテストしています.
テストプログラムは,TComboBox と同じような動作をするものですが,TListBox は複数の項目を選択可能にすることができます.

このコンポーネントは,設計時にフォームに配置できますが,実行時には非表示になります.プロパティやイベントの全てが有効に機能するとは限りません.各自で確認してください.
TComponent 等から派生したコンポーネントにして,プロパティやイベントを実装すれば,コンポーネントとしては使い勝手がよくなりますが,面倒なのでこの方式にしています.この方式の方が,ソースコードの改変もしやすいのではないかと思われます.

このように,コントロールをポップアップ表示するには,サンプルの [126] [04] のように,対象のコントロールをフォームに配置して,そのフォームをボップアップ表示する方法もあります.フォームにコントロールを配置する方法は,デザインの変更等のカスタマイズが容易です.



[備考]
FireMonkey であれば,TPopup コンポーネントを使用して,同様な機能を実装することができます.



図1
設計時画面
図2
実行画面
  • ボタンをクリックすると TListBox を表示

リスト1
ポップアップ表示する TListBox コンポーネントのテスト
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, plPopupListBox, Buttons;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    procedure SpeedButton1Click(Sender: TObject);
  private
    FPopupList: TplPopupListBox;
    procedure PopupListCloseup(sender: TObject);
    procedure PopupListClickEvent(Sender: TObject);
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  TplPopupListBoxコンポをポップアップ表示
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  aPos : TPoint;
begin
  if not Assigned(FPopupList) then begin
    FPopuplist := TplPopupListBox.Create( self );
    FPopupList.OnCloseUp := PopuplistCloseup;
    FPopupList.OnClick   := PopupListClickEvent;

    FPopuplist.Parent := self;
    FPopupList.Width  := 220;
    FPopupList.Height := 150;

    FPopupList.Style := lbOwnerDrawFixed;
    FPopupList.ItemHeight := 12;

    //テスト用の表示項目を作成
    FPopupList.Items.BeginUpdate;
    FPopupList.Items.Clear;
    with FPopupList.Items do begin
      Add('東京都');
      Add('埼玉県');
      Add('神奈川県');
      Add('群馬県');
      Add('栃木県');
      Add('茨城県');
      Add('千葉県');
      Add('長野県');
      Add('山梨県');
      Add('岐阜県');
      Add('新潟県');
      Add('福島県');
      Add('山形県');
      Add('岩手県');
      Add('青森県');
      Add('沖縄県');
      Add('京都府');
      Add('大阪府');
    end;
    FPopupList.Items.EndUpdate;
  end;

  //ShowBeneathメソッドで表示する
  //コントロールの左下の座標位置から表示する
  aPos := Self.ClientToScreen(Point(Edit1.Left, Edit1.Top));
  FPopuplist.ShowBeneath(aPos.X, aPos.Y + Edit1.Height, Edit1.Height);
  FPopupList.ItemIndex := 2;
end;

//=============================================================================
//  TplPopupListBoxコンポのOnClickイベント処理
//  TComboBoxのような使い方
//  TListBoxは,TComboBoxとは違い,元の値を表示したまま選択作業ができる
//  このような使い方は変則であるが,テストなので
//=============================================================================
procedure TForm1.PopupListClickEvent(Sender: TObject);
var
  AIndex : Integer;
begin
  AIndex := TplPopupListBox(Sender).ItemIndex;
  Edit1.Text := TplPopupListBox(Sender).Items[AIndex];
end;

//=============================================================================
//  TplPopupListBoxコンポのOnCloseUpイベント処理
//=============================================================================
procedure TForm1.PopupListCloseup(sender: TObject);
begin
  if FPopupList.ItemIndex >= 0 then begin
    Edit1.Text := FPopupList.Items[FPopupList.ItemIndex];
  end else begin
    //[ESC]で閉じるとここが実行される
    Edit1.Text := '';
  end;
  Edit1.SetFocus;
  Edit1.SelStart := Length(Edit1.Text);
end;

end.


リスト2
ポップアップ表示する TListBox コンポーネント
unit plPopupListBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls;

type
  TplPopupListBox = class(TCustomListBox)
  private
    FCloseupEvent : TNotifyEvent;
  protected
    procedure CloseUp;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DoEnter; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    function MouseIsOnScrollbar( const Pos: TPoint; var HittestCode:
    Integer): Boolean;
    function PerformNCMouseAction( Msg, HittestCode: Integer; const Pos:
    TPoint): Integer;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMLButtonDown(var Message: TWMLButtonDown);
    message WM_LBUTTONDOWN;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
  public
    procedure ShowBeneath(aLeft, aTop: Integer; aHeight: Integer=0);
    constructor Create(AOwner: TComponent); override;
  published
    property WheelAccumulator;
    property OnCloseUp: TNotifyEvent read FCloseupEvent write FCloseupEvent;
    property Style;
    property AutoComplete;
    property AutoCompleteDelay;
    property Color;
    property Columns;
    property DoubleBuffered;
    property Enabled;
    property ExtendedSelect;
    property Font;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    property MultiSelect;
    property ParentBiDiMode;
    property ParentColor;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ScrollWidth;
    property ShowHint;
    property Sorted;
    property TabWidth;
    property Touch;
    property OnClick;
    property OnContextPopup;
    property OnData;
    property OnDataFind;
    property OnDataObject;
    property OnDblClick;
    property OnDrawItem;
    property OnEnter;
    property OnExit;
    property OnGesture;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

uses Forms;

{ TplPopupListBox }

//-----------------------------------------------------------------------------
//  Create処理
//-----------------------------------------------------------------------------
constructor TplPopupListBox.Create(AOwner: TComponent);
begin
  inherited;
  if (csDesigning in ComponentState ) then begin
    Width  := 28;
    Height := 28
  end else begin
    ImeMode := imDisable;
    BorderStyle := bsNone;
    Hide;
  end;
end;

//-----------------------------------------------------------------------------
//  CreateParamsメソッド処理
//  コントロールのスタイル等を設定
//-----------------------------------------------------------------------------
procedure TplPopupListBox.CreateParams(var Params: TCreateParams);
var
  ParentForm : TCustomForm;
begin
  inherited;

  if not (csDesigning in ComponentState ) then begin
    Params.Style := Params.Style and not WS_CHILD or WS_POPUP or WS_BORDER;

    Params.WindowClass.Style := CS_SAVEBITS or CS_DROPSHADOW;
    ParentForm := GetParentForm(Self);
    if ParentForm.Handle <> 0 then Params.WndParent := ParentForm.Handle;
  end;
end;

//-----------------------------------------------------------------------------
//  本コンポ表示用のメソッド
//  X,Y(スクリーン座標)の位置から表示する
//  aHeightを指定すると,画面下端で表示する際に,その分だけ上から表示する
//-----------------------------------------------------------------------------
procedure TplPopupListBox.ShowBeneath(aLeft, aTop: Integer; aHeight: Integer=0);
var
  aBottom : Integer;
  aRight  : Integer;
  CtrlPos : TPoint;
  Monitor : TMonitor;
begin
  CtrlPos := Point(aLeft, aTop);
  //表示位置の調整
  aRight  := CtrlPos.X + Width;
  aBottom := CtrlPos.Y + Height;

  Monitor := Screen.MonitorFromPoint(CtrlPos);
  if Monitor.WorkareaRect.Bottom < aBottom then begin
    CtrlPos.Y := CtrlPos.Y - aHeight - Height;
  end;
  if Monitor.WorkareaRect.Left > CtrlPos.X then begin
    CtrlPos.X := Monitor.WorkareaRect.Left;
  end else
  if Monitor.WorkareaRect.Right < aRight then begin
    CtrlPos.X := Monitor.WorkareaRect.Right - Width;
  end;

  SetBounds(CtrlPos.x, CtrlPos.y, Width, Height);
  ItemIndex := -1;

  //TListBoxのShowメソッドを実行
  Show;

  if not Focused and CanFocus then SetFocus;
end;

//-----------------------------------------------------------------------------
//  DoEnterメソッド処理
//  TWinControlがフォーカスを受取ると自動的に実行される
//  Showメソッドで実行するよりもチラつきが少ない
//-----------------------------------------------------------------------------
procedure TplPopupListBox.DoEnter;
var
  ParentForm : TCustomForm;
begin
  inherited;

  //このコンポを表示するフォームを疑似的にアクティブ状態にする
  ParentForm := GetParentForm(Self);
  if ParentForm.Handle <> 0 then begin
    SendMessage(ParentForm.Handle, WM_NCACTIVATE, 1, 0);
  end;
end;

//-----------------------------------------------------------------------------
//  KeyDownメソッド処理
//-----------------------------------------------------------------------------
procedure TplPopupListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if (Key = VK_ESCAPE) or (Key = VK_RETURN) then begin
    Key := 0;
  end else begin
    inherited;
  end;
end;

//-----------------------------------------------------------------------------
//  KeyPressメソッド処理
//-----------------------------------------------------------------------------
procedure TplPopupListBox.KeyPress(var Key: Char);
begin
  if Key = Char(VK_RETURN) then begin
    Closeup;
  end else
  if Key = Char(VK_ESCAPE) then begin
    ItemIndex := -1;
    Closeup;
  end else begin
    inherited;
  end;
end;

//-----------------------------------------------------------------------------
//  WM_LBUTTONDOWNメッセージ処理
//-----------------------------------------------------------------------------
procedure TplPopupListBox.WMLButtonDown(var Message: TWMLButtonDown);
var
  Where : Integer;
  APos  : TPoint;
begin
  APos := Point(Message.Pos.x, Message.Pos.y);

  if MouseIsOnScrollbar(APos, Where) then begin
    PerformNCMouseAction(WM_NCLBUTTONDOWN, Where, APos);
  end else begin
    inherited;
  end;
end;

//-----------------------------------------------------------------------------
//  WM_LBUTTONUPメッセージ処理
//-----------------------------------------------------------------------------
procedure TplPopupListBox.WMLButtonUp(var Message: TWMLButtonUp);
var
  Where : Integer;
  APos  : TPoint;
begin
  APos := Point(Message.Pos.x, Message.Pos.y);

  //スクロールバー上にある場合
  if MouseIsOnScrollbar(APos, Where) then begin
    PerformNCMouseAction(WM_NCLBUTTONUP, Where, APos);
  end else begin
    inherited;
    if not MultiSelect then begin
      Closeup;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  WM_MOUSEMOVEメッセージ処理
//-----------------------------------------------------------------------------
procedure TplPopupListBox.WMMouseMove(var Message: TWMMouseMove);
var
  Where : Integer;
  APos  : TPoint;
begin
  APos := Point(Message.Pos.x, Message.Pos.y);

  //スクロールバー上にある場合
  if MouseIsOnScrollbar(APos, Where) then begin
    PerformNCMouseAction(WM_NCMOUSEMOVE, Where, APos);
  end else begin
    inherited;
  end;
end;

//-----------------------------------------------------------------------------
//  引数のPosがマウスがスクロールバーの上にあるかを調査する関数
//-----------------------------------------------------------------------------
function TplPopupListBox.MouseIsOnScrollbar(const Pos: TPoint; var
  HittestCode: Integer): Boolean;
var
  APos : TPoint;
begin
  if csDesigning In ComponentState then begin
    Result := False;
  end else begin
    APos := Pos;
    Windows.ClientToScreen(Handle, APos);
    Hittestcode := Perform(WM_NCHITTEST, 0, MakeLParam(APos.X, APos.Y));
    Result      := (Hittestcode = HTVSCROLL) or (Hittestcode = HTHSCROLL);
  end;
end;

//-----------------------------------------------------------------------------
//  各マウスイベント(メッセージ)処理から呼出して実行する関数
//  マウスがスクロールバー上にある場合は,非クライアント領域として操作
//-----------------------------------------------------------------------------
function TplPopupListBox.PerformNCMouseAction(Msg, HittestCode: Integer;
  const Pos: TPoint): Integer;
var
  APos : TPoint;
begin
  APos := Pos;
  Windows.ClientToScreen(Handle, APos);
  Result := Perform(Msg, HittestCode, MakeLParam(APos.X, APos.Y));
end;

//-----------------------------------------------------------------------------
//  WM_ACTIVATEメッセージ処理
//  本コンポが非アクティブになったら閉じる
//
//  MultiSelect=Trueの場合の対策
//  MultiSelect=Falseの場合はクリックで閉じるので必要ない
//-----------------------------------------------------------------------------
procedure TplPopupListBox.WMActivate(var Message: TWMActivate);
begin
  inherited;
  if Visible then begin
    if (Message.ActiveWindow <> Handle) and (Message.Active = 0) then begin
      CloseUp;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  閉じる時の処理用関数
//-----------------------------------------------------------------------------
procedure TplPopupListBox.CloseUp;
begin
  Hide;

  //OnCloseUpイベントが設定してあれば実行
  if Assigned(FCloseupEvent) then begin
    FCloseupEvent(Self);
  end;
end;

//-----------------------------------------------------------------------------
//  コンポーネント登録情報
//-----------------------------------------------------------------------------
procedure Register;
begin
  RegisterComponents('plXRAY', [TplPopupListBox]);
end;

end.