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:
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_activatemessage 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_activatemessage 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), oranimatewindow(...)*(withoutaw_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.