こんにちは、かとちんです。

コードエディタで、[Ctrl]+[Space] で出てくるポップアップリストボックス
が欲しいなぁと思ったんですが、Delphi-IDE　のみ持っていてどこにも提供
されていない〜 (;_;) ので、作成しました。

但し，「フォームに直接貼り付けること」「フォームのAutoScrollはFalseで
あること」という条件下でしか使えません。（-_-、) 解決できなかったぁ。

unit PopupListBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TPopupCloseEvent = procedure (Sender: TObject; ActiveTo: TControl)
                     of object;

  TPopupListBox = class(TColumnListBox)
  private
    { Private 宣言 }
    FPopExecuteNow: Boolean;
    FPopupNow: Boolean;
    FOnPopupClose: TPopupCloseEvent;
    procedure WMKillFocus(var Message: TWMKillFocus); message
                                                        WM_KILLFOCUS;
    procedure CMCancelMode(var Message: TCMCancelMode); message
                                                       CM_CANCELMODE;
  protected
    { Protected 宣言 }
    procedure Loaded; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
                      X, Y: Integer); override;
    procedure SetParent(AParent: TWinControl); override;
  public
    { Public 宣言 }
    constructor Create(AOwner: TComponent); override;
    procedure Popup(X, Y: Integer);
    procedure PopupCancel;
  published
    property Ctl3D default False;
    property OnPopupClose: TPopupCloseEvent read FOnPopupClose
                                            write FOnPopupClose;
  end;

procedure Register;
begin
  RegisterComponents('Samples', [TPopupListBox]);
end;

{ TPopupListBox }

constructor TPopupListBox.Create(AOwner: TComponent);
begin
  if not (AOwner is TForm) then
    raise Exception.Create('TPopupListBox:Owner must be a Form');
  inherited Create(AOwner);
  Ctl3D := False;
  ParentCtl3D := False;
  IntegralHeight := True;
end;

procedure TPopupListBox.Loaded;
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    Visible := False;
    SetBounds(-10000,-10000, Width, Height);
  end;
end;

procedure TPopupListBox.CMCancelMode(var Message: TCMCancelMode);
var
  C: TControl;
begin
  inherited;
  if FPopExecuteNow then Exit;
  if (Message.Sender <> Self) then
  begin
    if PopupMenu <> nil then
    begin
      // PopupMenu が表示されると Sender=nil で送られてくるので
      if (Message.Sender = nil) then Exit;
    end;
    C := Message.Sender;
    if not Visible then C := nil;
    PopupCancel;
    if Assigned(FOnPopupClose) then FOnPopupClose(Self, C);
  end;
end;

procedure TPopupListBox.WMKillFocus(var Message: TWMKillFocus);
var
  C: TControl;
begin
  inherited;
  if FPopExecuteNow then exit;
  C := FindControl(Message.FocusedWnd);
  if not Visible then C := nil;
  PopupCancel;
  if Assigned(FOnPopupClose) then FOnPopupClose(Self, C);
end;

procedure TPopupListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if (Key = VK_ESCAPE) or (Key = VK_RETURN) then
  begin
    PopupCancel;
    if Assigned(FOnPopupClose) then FOnPopupClose(Self, Self);
  end;
  inherited;
end;

procedure TPopupListBox.MouseUp(Button: TMouseButton; Shift:
TShiftState;
  X, Y: Integer);
begin
  if ItemAtPos(Point(X, Y), True) = ItemIndex then
  begin
    PopupCancel;
    if Assigned(FOnPopupClose) then FOnPopupClose(Self, Self);
  end;
  inherited;
end;

procedure TPopupListBox.Popup(X, Y: Integer);
begin
  if not (Owner is TForm) then Exit;
  PopupCancel;

  FPopExecuteNow := True;
  try
    Visible := True;
    TForm(Owner).ActiveControl := Self;

    if GetParent(Handle) = TForm(Owner).Handle then
    begin
      SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle,
                     GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
      // デスクトップを親にする
      SetWindowLong(Handle, GWL_HWNDPARENT, GetDesktopWindow);

      // デスクトップにポップアップ表示
      if X + Width > Screen.Width then X := Screen.Width - Width;
      if Y + Height > Screen.Height then Y := Screen.Height - Height;
      SetWindowPos(Handle, HWND_TOP, X, Y, 0, 0, SWP_NOSIZE);
    end;
    Show;
    FPopupNow := True;
  finally
    FPopExecuteNow := False;
  end;
end;

procedure TPopupListBox.PopupCancel;
begin
  if not (Owner is TForm) then Exit;
  if not FPopupNow then Exit;

  FPopExecuteNow := True;
  try
    Visible := False;
    if GetParent(Handle) <> TForm(Owner).Handle then
    begin
      Windows.SetParent(Handle, TForm(Owner).Handle);
      FPopupNow := False;
      SetBounds(-10000, -10000, Width, Height);
    end;
  finally
    FPopExecuteNow := False;
  end;
end;

procedure TPopupListBox.SetParent(AParent: TWinControl);
begin
  if AParent <> nil then
    if not (AParent is TForm) then
      raise Exception.Create('TPopupListBox:Parent must be a Form')
    else
      if TForm(AParent).AutoScroll then
      begin
        ShowMessage(
          'TPopupListBox: Form''s AutoScroll must be False. Changed.'
        );
        TForm(AParent).AutoScroll := False;
      end;
  inherited;
end;


　⌒　⌒　  2000/01/24(月)  午後 10:00  かとちん(JDX06162)
　◎　◎　  mailto:tarochan.kato@nifty.ne.jp
∋　▽　∈  http://pc2.techno-ware-unet.ocn.ne.jp/~kato/

Original document by かとちん        氏 ID:(JDX06162)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。