How to simulate drop-down form in Delphi?

Question

How can i create a \"drop-down\" window using Delphi?

Everything beyond this point is research effort; and is in no way related to the answer.

Research

Answer 1

At the bottom of procedure TForm3.Button1Click(Sender: TObject); you call frmPopup.Show; change that to ShowWindow(frmPopup.Handle, SW_SHOWNOACTIVATE); and after that you need to call frmPopup.Visible := True; else the components on the form won't show

So the new procedure looks like this:

uses
  frmPopupU;

procedure TForm3.Button1Click(Sender: TObject);
var
  frmPopup: TfrmPopup;
  pt: TPoint;
begin
  frmPopup := TfrmPopup.Create(Self);
  frmPopup.BorderStyle := bsNone;

  //We want the dropdown form "owned", but not "parented" to us
  frmPopup.Parent := nil; //the default anyway; but just to reinforce the idea
  frmPopup.PopupParent := Self;

  //Show the form just under, and right aligned, to this button
  frmPopup.Position := poDesigned;
  pt := Self.ClientToScreen(Button1.BoundsRect.BottomRight);
  Dec(pt.X, frmPopup.ClientWidth);
  frmPopup.Left := pt.X;
  frmPopup.Top := pt.Y;

  //  frmPopup.Show;
  ShowWindow(frmPopup.Handle, SW_SHOWNOACTIVATE);
  //Else the components on the form won't show
  frmPopup.Visible := True;
end;

But this won't prevent you popup from stealing focus. Inorder for preventing that, you need to override the WM_MOUSEACTIVATE event in your popup form

type
  TfrmPopup = class(TForm)
...
    procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
...
  end;

And the implementation

procedure TfrmPopup.WMMouseActivate(var Message: TWMMouseActivate);
begin
  Message.Result := MA_NOACTIVATE;
end;

I've decided to play arround with your popup window: The first thing I added was a close button. Just a simple TButton which in its onCLick Event calls Close:

procedure TfrmPopup.Button1Click(Sender: TObject);
begin
  Close;
end;

But that would only hide the form, in order for freeing it I added a OnFormClose event:

procedure TfrmPopup.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

Then finally I thought it would be funny to add a resize function

I did that by overriding the WM_NCHITTEST Message :

procedure TfrmPopup.WMNCHitTest(var Message: TWMNCHitTest);
const
  EDGEDETECT = 7; //adjust to suit yourself
var
  deltaRect: TRect; //not really used as a rect, just a convenient structure
begin
  inherited;

  with Message, deltaRect do
  begin
    Left := XPos - BoundsRect.Left;
    Right := BoundsRect.Right - XPos;
    Top := YPos - BoundsRect.Top;
    Bottom := BoundsRect.Bottom - YPos;

    if (Top < EDGEDETECT) and (Left < EDGEDETECT) then
      Result := HTTOPLEFT
    else if (Top < EDGEDETECT) and (Right < EDGEDETECT) then
      Result := HTTOPRIGHT
    else if (Bottom < EDGEDETECT) and (Left < EDGEDETECT) then
      Result := HTBOTTOMLEFT
    else if (Bottom < EDGEDETECT) and (Right < EDGEDETECT) then
      Result := HTBOTTOMRIGHT
    else if (Top < EDGEDETECT) then
      Result := HTTOP
    else if (Left < EDGEDETECT) then
      Result := HTLEFT
    else if (Bottom < EDGEDETECT) then
      Result := HTBOTTOM
    else if (Right < EDGEDETECT) then
      Result := HTRIGHT;
  end;
end;

So finally I've ended up with this :

unit frmPopupU;

interface

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

type
  TfrmPopup = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  public
    procedure CreateParams(var Params: TCreateParams); override;
  end;

implementation

{$R *.dfm}

{ TfrmPopup }

procedure TfrmPopup.Button1Click(Sender: TObject);
begin
  Close;
end;

procedure TfrmPopup.CreateParams(var Params: TCreateParams);
const
  CS_DROPSHADOW = $00020000;
begin
  inherited CreateParams({var}Params);
  Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;

procedure TfrmPopup.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

procedure TfrmPopup.FormCreate(Sender: TObject);
begin
  DoubleBuffered := true;
  BorderStyle := bsNone;
end;

procedure TfrmPopup.WMMouseActivate(var Message: TWMMouseActivate);
begin
  Message.Result := MA_NOACTIVATE;
end;

procedure TfrmPopup.WMNCHitTest(var Message: TWMNCHitTest);
const
  EDGEDETECT = 7; //adjust to suit yourself
var
  deltaRect: TRect; //not really used as a rect, just a convenient structure
begin
  inherited;

  with Message, deltaRect do
  begin
    Left := XPos - BoundsRect.Left;
    Right := BoundsRect.Right - XPos;
    Top := YPos - BoundsRect.Top;
    Bottom := BoundsRect.Bottom - YPos;

    if (Top < EDGEDETECT) and (Left < EDGEDETECT) then
      Result := HTTOPLEFT
    else if (Top < EDGEDETECT) and (Right < EDGEDETECT) then
      Result := HTTOPRIGHT
    else if (Bottom < EDGEDETECT) and (Left < EDGEDETECT) then
      Result := HTBOTTOMLEFT
    else if (Bottom < EDGEDETECT) and (Right < EDGEDETECT) then
      Result := HTBOTTOMRIGHT
    else if (Top < EDGEDETECT) then
      Result := HTTOP
    else if (Left < EDGEDETECT) then
      Result := HTLEFT
    else if (Bottom < EDGEDETECT) then
      Result := HTBOTTOM
    else if (Right < EDGEDETECT) then
      Result := HTRIGHT;
  end;
end;

end.

Hope you can use it.

Full and functional code

The following unit was tested only in Delphi 5 (emulated support for PopupParent). But beyond that, it does everything a drop-down needs. Sertac solved the AnimateWindow problem.

unit DropDownForm;

{
    A drop-down style form.

    Sample Usage
    =================

        procedure TForm1.SpeedButton1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
        var
            pt: TPoint;
        begin
            if FPopup = nil then
                FPopup := TfrmOverdueReportsPopup.Create(Self);
            if FPopup.DroppedDown then //don't drop-down again if we're already showing it
                Exit;

            pt := Self.ClientToScreen(SmartSpeedButton1.BoundsRect.BottomRight);
            Dec(pt.X, FPopup.Width);

            FPopup.ShowDropdown(Self, pt);
        end;

    Simply make a form descend from TDropDownForm.

        Change:
            type
                TfrmOverdueReportsPopup = class(TForm)

        to:
            uses
                DropDownForm;

            type
                TfrmOverdueReportsPopup = class(TDropDownForm)
}

interface

uses
    Forms, Messages, Classes, Controls, Windows;

const
    WM_PopupFormCloseUp = WM_USER+89;

type
    TDropDownForm = class(TForm)
    private
        FOnCloseUp: TNotifyEvent;
        FPopupParent: TCustomForm;
        FResizable: Boolean;
        function GetDroppedDown: Boolean;
{$IFNDEF SupportsPopupParent}
        procedure SetPopupParent(const Value: TCustomForm);
{$ENDIF}
    protected
        procedure CreateParams(var Params: TCreateParams); override;
        procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
        procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;

        procedure DoCloseup; virtual;

        procedure WMPopupFormCloseUp(var Msg: TMessage); message WM_PopupFormCloseUp;

{$IFNDEF SupportsPopupParent}
        property PopupParent: TCustomForm read FPopupParent write SetPopupParent;
{$ENDIF}
  public
        constructor Create(AOwner: TComponent); override;

        procedure ShowDropdown(OwnerForm: TCustomForm; PopupPosition: TPoint);
        property DroppedDown: Boolean read GetDroppedDown;
        property Resizable: Boolean read FResizable write FResizable;

        property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  end;

implementation

uses
    SysUtils;

{ TDropDownForm }

constructor TDropDownForm.Create(AOwner: TComponent);
begin
    inherited;

    Self.BorderStyle := bsNone; //get rid of our border right away, so the creator can measure us accurately
    FResizable := True;
end;

procedure TDropDownForm.CreateParams(var Params: TCreateParams);
const
    SPI_GETDROPSHADOW = $1024;
    CS_DROPSHADOW = $00020000;
var
    dropShadow: BOOL;
begin
    inherited CreateParams({var}Params);

    //It's no longer documented (because Windows 2000 is no longer supported)
    //but use of CS_DROPSHADOW and SPI_GETDROPSHADOW are only supported on XP (5.1) or newer
    if (Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) then
    begin
        //Use of a drop-shadow is controlled by a system preference
        if not Windows.SystemParametersInfo(SPI_GETDROPSHADOW, 0, @dropShadow, 0) then
            dropShadow := False;

        if dropShadow then
            Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
    end;

{$IFNDEF SupportsPopupParent} //Delphi 5 support for "PopupParent" style form ownership
    if FPopupParent <> nil then
        Params.WndParent := FPopupParent.Handle;
{$ENDIF}
end;

procedure TDropDownForm.DoCloseup;
begin
    if Assigned(FOnCloseUp) then
        FOnCloseUp(Self);
end;

function TDropDownForm.GetDroppedDown: Boolean;
begin
    Result := (Self.Visible);
end;

{$IFNDEF SupportsPopupParent}
procedure TDropDownForm.SetPopupParent(const Value: TCustomForm);
begin
    FPopupParent := Value;
end;
{$ENDIF}

procedure TDropDownForm.ShowDropdown(OwnerForm: TCustomForm; PopupPosition: TPoint);
var
    comboBoxAnimation: BOOL;
    i: Integer;

const
    AnimationDuration = 200; //200 ms
begin
    //We want the dropdown form "owned" by (i.e. not "parented" to) the OwnerForm
    Self.Parent := nil; //the default anyway; but just to reinforce the idea
    Self.PopupParent := OwnerForm; //Owner means the Win32 concept of owner (i.e. always on top of, cf Parent, which means clipped child of)
{$IFDEF SupportsPopupParent}
    Self.PopupMode := pmExplicit; //explicitely owned by the owner
{$ENDIF}

    //Show the form just under, and right aligned, to this button
//  Self.BorderStyle := bsNone; moved to during FormCreate; so can creator can know our width for measurements
    Self.Position := poDesigned;
    Self.Left := PopupPosition.X;
    Self.Top := PopupPosition.Y;

    //Use of drop-down animation is controlled by preference
    if not Windows.SystemParametersInfo(SPI_GETCOMBOBOXANIMATION, 0, @comboBoxAnimation, 0) then
        comboBoxAnimation := False;

    if comboBoxAnimation then
    begin
        //Delphi doesn't react well to having a form show behind its back (e.g. ShowWindow, AnimateWindow).
        //Force Delphi to create all the WinControls so that they will exist when the form is shown.
        for i := 0 to ControlCount - 1 do
        begin
            if Controls[i] is TWinControl and Controls[i].Visible and
                    not TWinControl(Controls[i]).HandleAllocated then
            begin
                TWinControl(Controls[i]).HandleNeeded;
                SetWindowPos(TWinControl(Controls[i]).Handle, 0, 0, 0, 0, 0,
                        SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW);
            end;
        end;
        AnimateWindow(Self.Handle, AnimationDuration, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
        Visible := True; // synch VCL
    end
    else
        inherited Show;
end;

procedure TDropDownForm.WMActivate(var Msg: TWMActivate);
begin
    //If we are being activated, then give pretend activation state back to our owner
    if (Msg.Active <> WA_INACTIVE) then
        SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);

    inherited;

    //If we're being deactivated, then we need to rollup
    if Msg.Active = WA_INACTIVE then
    begin
        {
            Post a message (not Send a message) to oursleves that we're closing up.
            This gives a chance for the mouse/keyboard event that triggered the closeup
            to believe the drop-down is still dropped down.
            This is intentional, so that the person dropping it down knows not to drop it down again.
            They want clicking the button while is was dropped to hide it.
            But in order to hide it, it must still be dropped down.
        }
        PostMessage(Self.Handle, WM_PopupFormCloseUp, WPARAM(Self), LPARAM(0));
    end;
end;

procedure TDropDownForm.WMNCHitTest(var Message: TWMNCHitTest);
var
    deltaRect: TRect; //not really used as a rect, just a convenient structure
    cx, cy: Integer;
begin
    inherited;

    if not Self.Resizable then
        Exit;

    //The sizable border is a preference
    cx := GetSystemMetrics(SM_CXSIZEFRAME);
    cy := GetSystemMetrics(SM_CYSIZEFRAME);

    with Message, deltaRect do
    begin
        Left := XPos - BoundsRect.Left;
        Right := BoundsRect.Right - XPos;
        Top := YPos - BoundsRect.Top;
        Bottom := BoundsRect.Bottom - YPos;

        if (Top < cy) and (Left < cx) then
            Result := HTTOPLEFT
        else if (Top < cy) and (Right < cx) then
            Result := HTTOPRIGHT
        else if (Bottom < cy) and (Left < cx) then
            Result := HTBOTTOMLEFT
        else if (Bottom < cy) and (Right < cx) then
            Result := HTBOTTOMRIGHT
        else if (Top < cy) then
            Result := HTTOP
        else if (Left < cx) then
            Result := HTLEFT
        else if (Bottom < cy) then
            Result := HTBOTTOM
        else if (Right < cx) then
            Result := HTRIGHT;
    end;
end;

procedure TDropDownForm.WMPopupFormCloseUp(var Msg: TMessage);
begin
    //This message gets posted to us.
    //Now it's time to actually closeup.
    Self.Hide;

    DoCloseup; //raise the OnCloseup event *after* we're actually hidden
end;

end.