// Style プロパティの値を lbOwnerDrawFixed にして ItemHeight の値を変更
    FplPopupListBox1.Style := lbOwnerDrawFixed;
    FplPopupListBox1.ItemHeight := 19;

  FplPopupListBox1.IntegralHeight := True;

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;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    procedure SpeedButton1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FplPopupListBox1 : TplPopupListBox;
    procedure OnplPopupListBox1CloseUp(Sender: TObject);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  SpeedButton1.Caption := '▼';

  CheckBox1.Caption := 'デフォルト描画';
  CheckBox2.Caption := 'フォーカスの枠線';
  CheckBox1.Checked := True;
  CheckBox2.Checked := True;
end;

//=============================================================================
//  TplPopupListBox コンポをポップアップ表示
//  コンポーネントは実行時生成
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  LPos : TPoint;
begin
  if not Assigned(FplPopupListBox1) then begin
    FplPopupListBox1 := TplPopupListBox.Create(Self);
    FplPopupListBox1.Parent := self;

    // イベント用のメソッドを設定
    FplPopupListBox1.OnCloseUp := OnplPopupListBox1CloseUp;

    FplPopupListBox1.Width := Edit1.Width + 25;
    FplPopupListBox1.IntegralHeight := True;

    // Style プロパティの値を lbOwnerDrawFixed にして ItemHeight の値を変更
    FplPopupListBox1.Style := lbOwnerDrawFixed;
    FplPopupListBox1.ItemHeight := 19;
  end;

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

  // デフォルト描画とフォーカスの枠線描画の設定
  FplPopupListBox1.DefaultDraw := CheckBox1.Checked;
  FplPopupListBox1.FocusRect   := CheckBox2.Checked;


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

//=============================================================================
//  TplPopupListBoxコンポのOnCloseUpイベント処理
//  項目をマウスクリックで選択するとコンポが閉じて，このイベントが発生する
//  [Enter], [ESC] キーでもコンポが閉じて，このイベントが発生する
//=============================================================================
procedure TForm1.OnplPopupListBox1CloseUp(Sender: TObject);
begin
  if FplPopupListBox1.ItemIndex >= 0 then begin
    Edit1.Text := FplPopupListBox1.Items[FplPopupListBox1.ItemIndex];
  end else begin
    // [ESC]で閉じるとここが実行される
    // Edit1.Text := '';
  end;
  Edit1.SetFocus;
  Edit1.SelStart := Length(Edit1.Text);
end;

end.

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);
    procedure FormCreate(Sender: TObject);
  private
    FplPopupListBox1 : TplPopupListBox;
    procedure OnplPopupListBox1Click(Sender: TObject);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  SpeedButton1.Caption := '▼';
end;

//=============================================================================
//  TplPopupListBox コンポをポップアップ表示
//  コンポーネントは実行時生成
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  LPos   : TPoint;
  LIndex : Integer;
begin
  if not Assigned(FplPopupListBox1) then begin
    FplPopupListBox1 := TplPopupListBox.Create(Self);
    FplPopupListBox1.Parent := self;

    // イベント用のメソッドを設定
    FplPopupListBox1.OnClick   := OnplPopupListBox1Click;

    FplPopupListBox1.Width := Edit1.Width + 25;
    FplPopupListBox1.IntegralHeight := True;

    // Style プロパティの値を lbOwnerDrawFixed にして ItemHeight の値を変更
    FplPopupListBox1.Style := lbOwnerDrawFixed;
    FplPopupListBox1.ItemHeight := 19;

    // デフォルト描画とフォーカスの枠線描画の設定
    FplPopupListBox1.DefaultDraw := False;
    FplPopupListBox1.FocusRect := False;

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

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

  // Edit1.Text と同じ文字列の項目を選択状態にする
  LIndex := FplPopupListBox1.Items.IndexOf(Edit1.Text);
  FplPopupListBox1.ItemIndex := LIndex;
end;

//=============================================================================
//  TplPopupListBoxコンポのOnClickイベント処理
//  TComboBoxのような使い方
//  TListBoxは，TComboBoxとは違い，元の値を表示したまま選択作業ができる
//  このような使い方は変則であるが，テストなので
//
//  選択項目を矢印キーで変更するとこのイベントが発生する
//  実際には OnSelectItem のような動作
// [ESC] で閉じても現在の値が TEdit にセットされる
//=============================================================================
procedure TForm1.OnplPopupListBox1Click(Sender: TObject);
var
  LIndex : Integer;
begin
  LIndex := TplPopupListBox(Sender).ItemIndex;
  Edit1.Text := TplPopupListBox(Sender).Items[LIndex];
end;

end.

unit plPopupListBox;

interface

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

type
  TplPopupListBox = class(TCustomListBox)
  private
    FCloseupEvent : TNotifyEvent;
    FDefaultDraw  : Boolean;
    FFocusRect    : Boolean;
    FSelBackColor : TColor;
    FSelFontColor : TColor;
    FDropDownRows: Integer;
    procedure SetDefaultDraw(const Value: Boolean);
    procedure SetFocusRect(const Value: Boolean);
    procedure SetSelBackColor(const Value: TColor);
    procedure SetSelFontColor(const Value: TColor);
    procedure SetDropDownRows(const Value: Integer);
  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;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
      override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
  public
    procedure ShowBeneath(ALeft, ATop: Integer; AHeight: Integer=0);
    constructor Create(AOwner: TComponent); override;
    property DefaultDraw  : Boolean read FDefaultDraw write SetDefaultDraw;
    property FocusRect    : Boolean read FFocusRect write SetFocusRect;
    property SelBackColor : TColor read FSelBackColor write SetSelBackColor;
    property SelFontColor : TColor read FSelFontColor write SetSelFontColor;
    property DropDownRows : Integer read FDropDownRows write SetDropDownRows;
  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,
  Types;

{ 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;
    Width  := 120;
    Height := 220;
    Hide;
  end;

  FDefaultDraw   :=  True;
  FFocusRect     := True;
  FSelBackColor  := $00FFD2A6;
  FSelFontColor  := clBlack;
  FDropDownRows := 8;
end;

//-----------------------------------------------------------------------------
//  CreateParamsメソッド処理
//  コントロールのスタイル等を設定
//-----------------------------------------------------------------------------
procedure TplPopupListBox.CreateParams(var Params: TCreateParams);
var
  LParentForm : 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;
    LParentForm := GetParentForm(Self);
    if LParentForm.Handle <> 0 then Params.WndParent := LParentForm.Handle;
  end;
end;

//-----------------------------------------------------------------------------
//  DefaultDraw プロパティの設定用メソッド
//-----------------------------------------------------------------------------
procedure TplPopupListBox.SetDefaultDraw(const Value: Boolean);
begin
  if FDefaultDraw <> Value then begin
    FDefaultDraw := Value;
    Invalidate;
  end;
end;

//-----------------------------------------------------------------------------
//  FocusRect プロパティの設定用メソッド
//  フォーカスの枠線を描画するかどうかのフラグ
//-----------------------------------------------------------------------------
procedure TplPopupListBox.SetFocusRect(const Value: Boolean);
begin
  if FFocusRect <> Value then begin
    FFocusRect := Value;
    Invalidate;
  end;
end;

//-----------------------------------------------------------------------------
//  SelBackColor プロパティの設定用メソッド
//  選択行の背景色のプロパティの設定
//  DefaultDraw プロパティの値が False の時に有効となる
//-----------------------------------------------------------------------------
procedure TplPopupListBox.SetSelBackColor(const Value: TColor);
begin
  if FSelBackColor <> Value then begin
    FSelBackColor := Value;
    Invalidate;
  end;
end;

//-----------------------------------------------------------------------------
//  SelFontColor プロパティの設定用メソッド
//  選択行の文字の色のプロパティの設定
//  DefaultDraw プロパティの値が False の時に有効となる
//-----------------------------------------------------------------------------
procedure TplPopupListBox.SetSelFontColor(const Value: TColor);
begin
  if FSelFontColor <> Value then begin
　　  FSelFontColor := Value;
    Invalidate;
  end;
end;
//-----------------------------------------------------------------------------
//  DropDownCount プロパティの設定用メソッド
//  ドロップダウンのリストの項目数
//-----------------------------------------------------------------------------
procedure TplPopupListBox.SetDropDownRows(const Value: Integer);
begin
  if FDropDownRows <> Value then begin
    FDropDownRows := Value;
  end;
end;

//-----------------------------------------------------------------------------
//  本コンポ表示用のメソッド
//  X,Y(スクリーン座標)の位置から表示する
//  AHeightを指定すると，画面下端で表示する際に，その分だけ上から表示する
//-----------------------------------------------------------------------------
procedure TplPopupListBox.ShowBeneath(ALeft, ATop: Integer; AHeight: Integer=0);
var
  LBottom  : Integer;
  LRight   : Integer;
  LCtrlPos : TPoint;
  LMonitor : TMonitor;
begin
  if FDropDownRows >= Items.Count then FDropDownRows := Items.Count;
  if FDropDownRows <= 1 then FDropDownRows := 1;
  Height := FDropDownRows * ItemHeight + 4;

  LCtrlPos := Point(ALeft, ATop);
  // 表示位置の調整
  LRight  := LCtrlPos.X + Width;
  LBottom := LCtrlPos.Y + Height;

  LMonitor := Screen.MonitorFromPoint(LCtrlPos);
  if LMonitor.WorkareaRect.Bottom < LBottom then begin
    LCtrlPos.Y := LCtrlPos.Y - AHeight - Height;
  end;
  if LMonitor.WorkareaRect.Left > LCtrlPos.X then begin
    LCtrlPos.X := LMonitor.WorkareaRect.Left;
  end else
  if LMonitor.WorkareaRect.Right < LRight then begin
    LCtrlPos.X := LMonitor.WorkareaRect.Right - Width;
  end;

  SetBounds(LCtrlPos.x, LCtrlPos.y, Width, Height);
  ItemIndex := -1;
  if Items.Count >= 1 then ItemIndex := 0;

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

  if not Focused and CanFocus then SetFocus;
end;

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

  // このコンポを表示するフォームを疑似的にアクティブ状態にする
  LParentForm := GetParentForm(Self);
  if LParentForm.Handle <> 0 then begin
    SendMessage(LParentForm.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
    if Key = VK_ESCAPE then begin
      ItemIndex := -1;
    end;
    Key := 0;
  end else
  if (Key = VK_DOWN) and (ssAlt in Shift) then begin
    Key := 0;
    CloseUp;
  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
  LWhere : Integer;
  LPos   : TPoint;
begin
  LPos := Point(Message.Pos.x, Message.Pos.y);

  if MouseIsOnScrollbar(LPos, LWhere) then begin
    PerformNCMouseAction(WM_NCLBUTTONDOWN, LWhere, LPos);
  end else begin
    inherited;
  end;
end;

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

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

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

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

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

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

//-----------------------------------------------------------------------------
//  マウスホイール操作の処理
//  この処理がないと親コントロールがスクロールメッセージを受信してしまう
//-----------------------------------------------------------------------------
function TplPopupListBox.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
begin
  Result := inherited;

  if Visible and MouseInClient then begin
    if WheelDelta > 0 then begin
      Perform(WM_VSCROLL, MakeWParam(SB_LINEUP, 0), 0);
    end else begin
      Perform(WM_VSCROLL, MakeWParam(SB_LINEDOWN, 0), 0);
    end;
    // 他のウィンドウにはスクロールメッセージを送信しない
    Result := True;
  end;
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
      ItemIndex := -1;
      CloseUp;
    end;
  end;
end;

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

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

  // 親コントロールにフォーカス移動
  // 親以外のコントロールにフォーカスしたい場合は利用側のコードで対応する
  TWinControl(Parent).SetFocus;
  SetActiveWindow(TWinControl(Parent).Handle);
end;

//-----------------------------------------------------------------------------
//  DrawItem メソッドの処理
//  イベントでは全て自前の処理となるが，継承クラスのメソッドでは使い分けが可能
//-----------------------------------------------------------------------------
procedure TplPopupListBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  LRect      : TRect;
  LText      : string;
  LFormat    : TTextFormat;
  LTempColor : TColor;
begin
  LTempColor := Canvas.Font.Color;

  if FDefaultDraw then begin
    inherited DrawItem(Index, Rect, State);
  end else begin
    if odSelected in State then begin
      Canvas.Brush.Color := FSelBackColor;
      Canvas.Font.Color  := FSelFontColor;
    end else begin
      Canvas.Brush.Color := Color;
      Canvas.Font.Color  := clBlack;
    end;
    Canvas.FillRect(Rect);

    LRect := Rect;
    InflateRect(LRect , -3, 0);
    LText := Items[Index];
    LFormat := [tfLeft, tfVerticalCenter, tfSingleLine];
    Canvas.TextRect(LRect, LText, LFormat);
  end;
  Canvas.Font.Color := LTempColor;

  if (odFocused in State) and not FFocusRect then begin
    Canvas.DrawFocusRect(Rect);
  end;
end;

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

end.