windows - How to simulate drop-down form in Delphi? -

how can create "drop-down" window using delphi?

everything beyond point research effort; , in no way related answer.

research effort

making proper drop-down requires lot of pieces work together. assume people don't difficult question, , rather asked 7 separate questions; each 1 addressing 1 tiny piece of problem. follows research effort solving deceptively simple problem.

---

note defining characteristics of drop-down window:

• 1. drop-down extends outside it's "owner" window
• 2. "owner" window keeps focus; drop-down never steals focus
• 3. drop-down window has drop-shadow

this delphi variation of same question asked in winforms:

• how simulate drop-down window in winforms?

the answer in winforms use toolstripdropdown class. helper class turns form drop-down.

lets in delphi

i start creating gaudy dropdown form, serves example:

next drop button, thing click make drop-down appear:

and wire-up initial code show form needs in onclick:

procedure tform3.button1mousedown(sender: tobject;        button: tmousebutton; shift: tshiftstate; x, y: integer); var     frmpopup: tfrmpopup;     pt: tpoint; begin     frmpopup := tfrmpopup.create(self);      //show form under, , right aligned, button     pt := self.clienttoscreen(button1.boundsrect.bottomright);     dec(pt.x, frmpopup.clientwidth);      frmpopup.show(self, self.handle, pt); end; 

edit: changed mousedown rather click. click incorrect, drop-down shown without need click. 1 of unresolved issues how hide drop-down if user mouse-downs button again. we'll leave person answers question solve. in question research effort - not solution.

and we're off:

now how right way?

first thing notice right away lack of drop-shadow. that's because need apply cs_dropshadow window style:

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; 

that fixes that:

focus stealing

the next issue calling .show on popup causes steal focus (the title bar of application indicates has lost focus). sertac comes solution this.

• when popup receives it's wm_activate message indicating receiving focus (i.e. lo(wparam) <> wa_inactive):
• send parent form wm_ncactivate(true, -1) indicate should draw still has focus

we handle wm_activate:

protected    procedure wmactivate(var msg: twmactivate); message wm_activate; 

and implementation:

procedure tfrmpopup.wmactivate(var msg: twmactivate); begin     //if being activated, give pretend activation state our owner     if (msg.active <> wa_inactive)         sendmessage(self.popupparent.handle, wm_ncactivate, wparam(true), -1);      inherited; end; 

so owner window looks still has focus (who knows if correct way - looks still has focus):

rolling up

fortunately, sertac solves problem of how dismiss window whenever user clicks away:

• when popup receives it's wm_activate message indicating losing focus (i.e. lo(wparam) = wa_inactive):
• send owner control notification rolling up
• free popup form

we add our existing wm_activate handler:

procedure tfrmpopup.wmactivate(var msg: twmactivate); begin     //if being activated, give pretend activation state our owner     if (msg.active <> wa_inactive)         sendmessage(self.popupparent.handle, wm_ncactivate, wparam(true), -1);      inherited;      //if we're being deactivated, need rollup     if msg.active = wa_inactive     begin         //todo: tell our owner we've rolled          //note: parent should not using rollup time read state of controls in popup.         //      every time in popup changes, drop-down should give inforamtion owner         self.release; //use release let wmactivate complete     end; end; 

sliding dropdown

dropdown controls use animatewindow slide drop-down down. microsoft's own combo.c:

if (!(test_effectpusif(pusif_comboboxanimation))       || (getappcompatflags2(ver40) & gacf2_animationoff)) {    ntusershowwindow(hwndlist, sw_showna); }  else  {    animatewindow(hwndlist, cms_qanimation, (fanimpos ? aw_ver_positive :             aw_ver_negative) | aw_slide); } 

after checking if animations should used, use animatewindow show window. can use systemparametersinfo spi_getcomboboxanimation:

determines whether slide-open effect combo boxes enabled. pvparam parameter must point bool variable receives true enabled, or false disabled.

inside our newly consecrated tfrmpopup.show method, can check if client area animations enabled, , call either animatewindow or show depending on user's preference:

procedure tfrmpopup.show(owner: tform; notificationparentwindow: hwnd;       popupposition: tpoint); var     pt: tpoint;     comboboxanimation: bool; begin     fnotificationparentwnd := notificationparentwindow;      //we want dropdown form "owned" (i.e. not "parented" to) ownerwindow     self.parent := nil; //the default anyway; reinforce idea     self.popupparent := owner; //owner means win32 concept of owner (i.e. on top of, cf parent, means clipped child of)     self.popupmode := pmexplicit; //explicitely owned owner      //show form under, , right aligned, button     self.borderstyle := bsnone;     self.position := podesigned;     self.left := popupposition.x;     self.top := popupposition.y;      if not winapi.windows.systemparametersinfo(spi_getcomboboxanimation, 0, @comboboxanimation, 0)         comboboxanimation := false;      if comboboxanimation     begin         //200ms shell animation duration         animatewindow(self.handle, 200, aw_ver_positive or aw_slide or aw_activate);     end     else         inherited show; end; 

edit: turns out there spi_getcomboboxanimation should use on spi_getclientareaanimation. points depths of difficulty hidden behind subtle "how simulate drop-down". simulating drop-down requires lot of stuff.

the problem delphi forms pretty fall on dead if try use showwindow or animatewindow behind back:

how solve that?

it's odd microsoft uses either:

• showwindow(..., sw_shownoactivate), or
• animatewindow(...) *(without aw_activate)

to show drop-down listbox without activation. , yet spying on combobox spy++ can see wm_ncactivate flying around.

in past people have simulated slide window using repeated calls change height of drop-down form timer. not bad; changes size of form. rather sliding down, form grows down; can see controls change layout drop-down appears. no, having drop-down form remain it's real size, slide down wanted here.

i know animatewindow , delphi have never gotten along. , question has been asked, lot, long before stackoverflow arrived. asked in 2005 on newsgroups. can't stop me asking again.

i tried force form redraw after animates:

animatewindow(self.handle, 200, aw_ver_positive or aw_slide or aw_activate); self.repaint; self.update; self.invalidate; 

but doesn't work; sits there mocking me:

now showing again when want close-up

if combobox dropped down, , user tries mousedown on button, real windows combobox control not show control again, instead hides it:

the drop-down knows "dropped-down", useful can draw if in "dropped down" mode. need way know drop-down dropped down, , way know drop-down no longer dropped down. kind of boolean variable:

private    fdroppeddown: boolean; 

and seems me need tell host we're closing (i.e. losing activation). the host needs responsible destroying popup. (the host cannot responsible destroying popup; leads unresolvable race condition). create message used notify owner we're closing up:

const    wm_popupformcloseup = wm_app+89; 

note: don't know how people avoid message constant conflicts (especially since cm_base starts @ $b000 , cn_base starts @ $bc00).

building on sertac's activation/deactivation routine:

procedure tfrmpopup.wmactivate(var msg: twmactivate); begin     //if being activated, give pretend activation state our owner     if (msg.active <> wa_inactive)         sendmessage(self.popupparent.handle, wm_ncactivate, wparam(true), -1);      inherited;      //if we're being deactivated, need rollup     if msg.active = wa_inactive     begin         //done: tell our owner we've rolled         //note: must post message. if sent, owner         //will closeup notification before mousedown         //started this. when mousedown comes, think         //they not dropped down, , drop down new one.         postmessage(fnotificationparentwnd, wm_popupformcloseup, 0, 0);          self.release; //use release give wm_activate chance return     end; end; 

and have change our mousedown code understand drop-down still there:

procedure tform3.edit1mousedown(sender: tobject; button: tmousebutton; shift: tshiftstate; x, y: integer); var     frmpopup: tfrmpopup;     pt: tpoint; begin     //if (were) dropped down, don't drop-down again.     //if click us, pretend trying close drop-down rather open second copy     if fdroppeddown     begin         //and since we're receiving mouse input, defintion must have focus.         //and since drop-down self-destructs when loses activation,          //it can no longer dropped down (since no longer exists)         exit;     end;      frmpopup := tfrmpopup.create(self);      //show form under, , right aligned, button     pt := self.clienttoscreen(edit1.boundsrect.bottomright);     dec(pt.x, frmpopup.clientwidth);      frmpopup.show(self, self.handle, pt);     fdroppeddown := true; end; 

and think that's it

aside animatewindow conundrum, may have been able use research effort solve problems can think of in order to:

simulate drop-down form in delphi

of course, naught. might turn out there's vcl function:

tcomboboxhelper = class; public    class procedure showdropdownform(...); end; 

in case that correct answer.

at bottom of procedure tform3.button1click(sender: tobject); call frmpopup.show; change showwindow(frmpopup.handle, sw_shownoactivate); , after need call frmpopup.visible := true; else components on form won't show

so new procedure looks this:

uses   frmpopupu;  procedure tform3.button1click(sender: tobject); var   frmpopup: tfrmpopup;   pt: tpoint; begin   frmpopup := tfrmpopup.create(self);   frmpopup.borderstyle := bsnone;    //we want dropdown form "owned", not "parented"   frmpopup.parent := nil; //the default anyway; reinforce idea   frmpopup.popupparent := self;    //show form under, , right aligned, 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 components on form won't show   frmpopup.visible := true; end; 

but won't prevent popup stealing focus. inorder preventing that, need override wm_mouseactivate event in popup form

type   tfrmpopup = class(tform) ...     procedure wmmouseactivate(var message: twmmouseactivate); message wm_mouseactivate; ...   end; 

and implementation

procedure tfrmpopup.wmmouseactivate(var message: twmmouseactivate); begin   message.result := ma_noactivate; end; 

i've decided play arround popup window: first thing added close button. simple tbutton in onclick event calls close:

procedure tfrmpopup.button1click(sender: tobject); begin   close; end; 

but hide form, in order freeing added onformclose event:

procedure tfrmpopup.formclose(sender: tobject; var action: tcloseaction); begin   action := cafree; end; 

then thought funny add resize function

i did overriding wm_nchittest message :

procedure tfrmpopup.wmnchittest(var message: twmnchittest); const   edgedetect = 7; //adjust suit var   deltarect: trect; //not used rect, convenient structure begin   inherited;    message, deltarect   begin     left := xpos - boundsrect.left;     right := boundsrect.right - xpos;     top := ypos - boundsrect.top;     bottom := boundsrect.bottom - ypos;      if (top < edgedetect) , (left < edgedetect)       result := httopleft     else if (top < edgedetect) , (right < edgedetect)       result := httopright     else if (bottom < edgedetect) , (left < edgedetect)       result := htbottomleft     else if (bottom < edgedetect) , (right < edgedetect)       result := htbottomright     else if (top < edgedetect)       result := httop     else if (left < edgedetect)       result := htleft     else if (bottom < edgedetect)       result := htbottom     else if (right < edgedetect)       result := htright;   end; end; 

so i've ended :

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 suit var   deltarect: trect; //not used rect, convenient structure begin   inherited;    message, deltarect   begin     left := xpos - boundsrect.left;     right := boundsrect.right - xpos;     top := ypos - boundsrect.top;     bottom := boundsrect.bottom - ypos;      if (top < edgedetect) , (left < edgedetect)       result := httopleft     else if (top < edgedetect) , (right < edgedetect)       result := httopright     else if (bottom < edgedetect) , (left < edgedetect)       result := htbottomleft     else if (bottom < edgedetect) , (right < edgedetect)       result := htbottomright     else if (top < edgedetect)       result := httop     else if (left < edgedetect)       result := htleft     else if (bottom < edgedetect)       result := htbottom     else if (right < edgedetect)       result := htright;   end; end;  end. 

hope can use it.

full , functional code

the following unit tested in delphi 5 (emulated support popupparent). beyond that, drop-down needs. sertac solved animatewindow problem.

unit dropdownform;  {     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                 fpopup := tfrmoverduereportspopup.create(self);             if fpopup.droppeddown //don't drop-down again if we're showing                 exit;              pt := self.clienttoscreen(smartspeedbutton1.boundsrect.bottomright);             dec(pt.x, fpopup.width);              fpopup.showdropdown(self, pt);         end;      make form descend 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, creator can measure 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 no longer supported)     //but use of cs_dropshadow , spi_getdropshadow supported on xp (5.1) or newer     if (win32majorversion > 5) or ((win32majorversion = 5) , (win32minorversion >= 1))     begin         //use of drop-shadow controlled system preference         if not windows.systemparametersinfo(spi_getdropshadow, 0, @dropshadow, 0)             dropshadow := false;          if dropshadow             params.windowclass.style := params.windowclass.style or cs_dropshadow;     end;  {$ifndef supportspopupparent} //delphi 5 support "popupparent" style form ownership     if fpopupparent <> nil         params.wndparent := fpopupparent.handle; {$endif} end;  procedure tdropdownform.docloseup; begin     if assigned(foncloseup)         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 dropdown form "owned" (i.e. not "parented" to) ownerform     self.parent := nil; //the default anyway; reinforce idea     self.popupparent := ownerform; //owner means win32 concept of owner (i.e. on top of, cf parent, means clipped child of) {$ifdef supportspopupparent}     self.popupmode := pmexplicit; //explicitely owned owner {$endif}      //show form under, , right aligned, button //  self.borderstyle := bsnone; moved during formcreate; can creator can know our width measurements     self.position := podesigned;     self.left := popupposition.x;     self.top := popupposition.y;      //use of drop-down animation controlled preference     if not windows.systemparametersinfo(spi_getcomboboxanimation, 0, @comboboxanimation, 0)         comboboxanimation := false;      if comboboxanimation     begin         //delphi doesn't react having form show behind (e.g. showwindow, animatewindow).         //force delphi create wincontrols exist when form shown.         := 0 controlcount - 1         begin             if controls[i] twincontrol , controls[i].visible ,                     not twincontrol(controls[i]).handleallocated             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 being activated, give pretend activation state our owner     if (msg.active <> wa_inactive)         sendmessage(self.popupparent.handle, wm_ncactivate, wparam(true), -1);      inherited;      //if we're being deactivated, need rollup     if msg.active = wa_inactive     begin         {             post message (not send message) oursleves we're closing up.             gives chance mouse/keyboard event triggered closeup             believe drop-down still dropped down.             intentional, person dropping down knows not drop down again.             want clicking button while dropped hide it.             in order hide it, must still dropped down.         }         postmessage(self.handle, wm_popupformcloseup, wparam(self), lparam(0));     end; end;  procedure tdropdownform.wmnchittest(var message: twmnchittest); var     deltarect: trect; //not used rect, convenient structure     cx, cy: integer; begin     inherited;      if not self.resizable         exit;      //the sizable border preference     cx := getsystemmetrics(sm_cxsizeframe);     cy := getsystemmetrics(sm_cysizeframe);      message, deltarect     begin         left := xpos - boundsrect.left;         right := boundsrect.right - xpos;         top := ypos - boundsrect.top;         bottom := boundsrect.bottom - ypos;          if (top < cy) , (left < cx)             result := httopleft         else if (top < cy) , (right < cx)             result := httopright         else if (bottom < cy) , (left < cx)             result := htbottomleft         else if (bottom < cy) , (right < cx)             result := htbottomright         else if (top < cy)             result := httop         else if (left < cx)             result := htleft         else if (bottom < cy)             result := htbottom         else if (right < cx)             result := htright;     end; end;  procedure tdropdownform.wmpopupformcloseup(var msg: tmessage); begin     //this message gets posted us.     //now it's time closeup.     self.hide;      docloseup; //raise oncloseup event *after* we're hidden end;  end.