 Home |
16-A. Modal Windows Top-Level Modal Windows |
Home |
Here at DelphiZeus, you have seen many ways to create top-level windows (Forms in a Delphi term). This lesson will give some methods for creating some "Modal" windows that block the user from accessing other forms of that thread. You know that the API function MessageBox( ) makes a modal window, and in Lesson-8 you got examples for the templete dialogs, which can be shown as a modal-window. With those modal dialogs, the system handles all of the work to disable the other forms and block code progression. If you want or need to do your own "Modal" effects for a top-level window, you will need some API methods to do this. The code example for this lesson is the MsgWnds.pas unit, which has code for modal message forms. This will have code to show you how to have "Message" windows that will disable other windows, and block code progression. |
| What is "Modal"? ? When a modal top-level window is displayed, users can ONLY interact with that window, and not with the forms that were already shown for that program (thread). User input (keyboard focus) can NOT be transfered to any other window of that program, the user must finish with the modal window before he can use other windows. If you only have one top level window, a method that you can use to do this is to have - EnableWindow(hForm1, False); to disable hForm1 and show your new window. When the new window closes you will then enable hForm1. This method gives a "Modal" effect, but does Not block code execution, and wait for a function to return, before other code is executed, although you can have code to run after the new window closes. To have a function that shows a modal window an blocks code execution takes some special coding, because you must block code progression AND allow system message handling (not block thread), which is not so easy. Pop-Up Message Windows
Disable All Thread Windows function EnumThreadWindows(
dwThreadId: Cardinal; // thread identifier
lpFn: Pointer; // pointer to callback function
lParam: Integer // integer value sent to callback
): BOOL; // True if succesfullThe dwThreadId parameter should be set to the thread ID you need the windows for. You must have a "CallBack Function" to use with this, it's memory address in placed in the lpFn parameter. This function is called, by the system, one time for every top-level window in that thread. This EnumThreadWndProc( ) function has the parameter syntax of -
function EnumThreadWndProc(
hWnd: Cardinal; // handle to thread top-level window
LParam: Integer // Integer value from EnumThreadWindows
): BOOL; StdCall; // True to continue, defined as StdCallThis function will execute with the top-level window handle in the hWnd parameter, and the EnumThreadWindows-LParam in the LParam. You set the result to True to continue the enumeration (get more windows), or False to stop it. In the MsgWnds.pas unit code, I will be recording all of the top-level window handles in an array of integers called aryEnabled, so each time this function is called the array size is increased and the hWnd handle added to the array.You can see the code methods I used for EnumThreadWindows( ) in the MsgWnds.pas unit code below. The top-level window disable starts with the DisableForms( ) procedure, which has the EnumThreadWindows( ), Since I want windows in the main thread, it uses the API function GetCurrentThreadId to supply the thread ID number. The enumeration callback function is FoundTopLevel( )
Blocking Code Progression function DoUserMsgs: Boolean;
var
aMsg: TMSG;
begin
{ for the WaitTilClose repeat loop , you will need to
get the message queue messages and dispatch them }
Result := False; //WaitTilClose loop continues while Result is False
while PeekMessage(aMsg, Zero, Zero, Zero, PM_REMOVE) do
if aMsg.message = WM_QUIT then
begin
Result := True; // set Result to end WaitTilClose repeat loop
// IMPORTANT, must get WM_QUIT and repost it
PostQuitMessage(Zero);
Break;
end else
if not IsDialogMessage(GetActiveWindow, aMsg) then
begin
TranslateMessage(aMsg);
DispatchMessage(aMsg);
end;
end;
function WaitTilClose(hWnd: Integer): Integer;
begin
// this function allows you to wait until the hWnd window closes
aResult.Result := IDCancel;
aResult.hWnd := Zero;
repeat
if DoUserMsgs or (aResult.hWnd = hWnd) then Break;
WaitMessage; { returns when message queue is not empty
the WaitMessage function is what allows the message window to
wait for the MsgResult function to return. The WaitMessage
function will yield control to other threads when
this thread has no messages}
until (aResult.hWnd = hWnd) or (not IsWindow(hWnd));
Result := aResult.Result;
end;These two functions are in the MsgWnds.pas Unit code below, the way I get a window close event to break the repeat loop, is with the aResult record. In the WaitTilClose function the aRecord is initialized to ID = IDCancel, , and hWnd = 0 . When a message window closes, it will set the aResult.hWnd to it's handle, the repeat loop tests the aResult.hWnd for the window handle, and will break out of the loop if the handle matches.
Using the MsgWnds.pas Unit There are only two public functions in the MsgWnds.pas Unit, ShowMsg( ) and MsgResult( ) . The ShowMsg( ) Procedure procedure ShowMsg( hParent: Integer; // owner window handle const Mess: String; // message text const Title: String // Text for caption title );This procedure will show a message window of only one size, 260 pixels wide and 124 pixels high. It creates a STATIC control to display the message text, and will have one button at the bottom of the window with the caption "OK" on it. You can place The MsgResult( ) Function function MsgResult( const Msg: String; // text for the message displayed const Title: String; // text for the Title Bar Caption pDlgSetUp1: PDlgSetUp // pointer to a TDlgSetUp record with options ): Integer; // returns button click IDI wanted this function to have many options and also a "Default" that did not require any options to be set, so I have the options parameter as a Pointer, instead of a TDlgSetUp. . For a simple default settings message box, with an "OK" button, you set the pDlgSetUp1 to NIL, and you do not do any code for options. Also you can set the pointer pDlgSetUp1 to a number, 1, 2, 3 or 4 and have a system message box Icon, and not do any code for options. I will show code for this later. If you want to set the options for this message form, you will need to make settings in the TDlgSetUp record passed to this function. Here is a list of what options I have for changing the message window -
The TDlgSetUp Record TYour = record // has settings for your button captions and icon
ButText1, ButText2, ButText3: String[12];
// 12 or less charaters on your button.
hIcon: Integer; // your Icon handle
end;
PDlgSetUp = ^TDlgSetUp;
TDlgSetUp = record
hParent: Integer; // dialog "Owner", form handle that calls dialog
CenterText: Boolean; // CenterText is True for text center aligned
dLeft, dTop: Integer; // positions, set to 0 for work area center
DlgIcon: TDlgIcon; // sets the Icon for the dialog
ClientIcon: TClientIcon; // set to have a Client area Icon
Buttons: TDlgButton; // sets the buttons, how many and captions
Your: TYour; // holds settings for "Your" options
end; Record Members -1: hParent - This is the window handle of the form that will "Own" (as parent) the Pop-Up window. 2: CenterText - A Boolean that will set the message text alignment, if True then the text is center align, if False then the text is left align. 3: dTop, dLeft - These two will set the screen position for the message window to the Top and Left placed in these integers. There is a check in the message window creation code of these values, to make sure that it will show the window on screen. Having a Modal window created and not visible to the user is bad coding. Also, for a Default screen center position, set them to a minus number like -1. 4: DlgIcon - Sets the icon used for the message window caption bar. This is a TDlgIcon type, and has the following values - 5: ClientIcon - Will set the if the window icon is shown on the client area. It can have one of three values defined in the TClientIcon type as - 6: Buttons - Sets the number of buttons shown on message form, and the caption text on these buttons. It is a TDlgButton type, defined as - 7: Your - This is a TYour record defined above, with 3 short strings for your button text and a hIcon for your icon handle. If you have a dbYour in the Buttons record member, you need to have your button caption text in the ButText short strings. The hIcon handle is Only used if the DlgIcon has the diYour in it. MsgResult( ) Function Return Values
Code For MsgWnds Unit Functions Here are some procedures that show some code for the ShowMsg and MsgResult functions. ShowMsg( ) Procedure begin
ShowMsg(hForm1, #10'A Short Message for you', 'Message Title');
// add the main Form handle, then your message and title text
MessageBox(hForm1, 'Code progress was NOT BLOCKED with ShowMsg',
'NO Wait', MB_ICONINFORMATION);
end;When you run this code the MessageBox window will show up over-top of the ShowMsg window, because code progression is not blocked by ShowMsg. The MessageBox function may be a better way to show your user a message, I have this ShowMsg procedure just as a demo, to show how the DisableForms procedure works. You can use the line feed character #10 in your message text to have line breaks in the STATIC control text. You should have a top-level window handle in the hParent parameter. The ShowMsg window is always the same size, but will be a good size for most messages.
MsgResult( ) Function begin
MsgResult('This has NIL as the pDlgSetUp1 parameter'#10+
'So this will have the "Default" settings',
'', nil);
MessageBox(hForm1, 'Program Execution was BLOCKED with the '+
'MsgResult function'#10'just like MessageBox( )',
'Wait', MB_ICONINFORMATION);
MsgResult('ERROR - This has "Pointer(1)" as the pDlgSetUp1 '+
'parameter'#10'So this will have the Error Icon '+
'with default settings', 'Fake Error', Pointer(1));
// having Pointer(1) will show the Error Icon
end;To use all the options available with MsgResult, you will need to fill in a TDlgSetUp record. First, the TDlgSetUp variable you use may NOT be initialized, so you should start by using ZeroMemory( ) or other way to initialize the values in your TDlgSetUp record variable. Using the ZeroMemory will set the record values as a "Default", as these - hParent as zero, code will execute to get a thread window as parent So you will need to change only the one not already set to what you want. Below is a procedure with example code for using the TDlgSetUp with MsgResult. It uses the ClientIcon as ciOver to show you how to get text to display under the client Icon, the top two lines of text are beside the icon and the third line can be below the icon. - procedure doMsgResult;
var
dSetUp: TDlgSetUp;
fRect: TRect;
begin
ZeroMemory(@dSetUp, SizeOf(dSetUp));
{The TDlgSetUp variable is NOT initialized, so it can have
any values in it, you should always ZeroMemory for it}
with dSetUp do
begin
//CenterText := False; // not needed
// since you have used ZeroMemory, defaults are set like -
// CenterText as False;
hParent := hForm1;
if GetWindowRect(hParent, fRect) then
begin
dTop := fRect.Top+128;
dLeft := fRect.Left+154;
end;
DlgIcon := diQuestion;
ClientIcon := ciOver;
// ciOver is user to get text Under the Icon
Buttons := dbYesNo;
end;
if MsgResult('This is a Question Message to read'#10+
'with ciOver third line goes under the icon'#10+
'Longest line of this message sets window width'#10+
'Do You want to do this?','',@dSetUp) = IDYes then
ShowMsg(hForm1, #10'Result was Yes', 'Result of MsgResult');
end;You can have buttons with your text captions on them, and a client icon showing your icon. Belows is a code example that uses the "Your" member of the TDlgSetUp record - procedure doYourMsg;
const
ReStr = 'Result of MsgResult';
var
dSetUp: TDlgSetUp;
Re1: Integer;
begin
ZeroMemory(@dSetUp, SizeOf(dSetUp));
// defaults are set with ZeroMemory
with dSetUp do
begin
CenterText := True;
hParent := hForm1;
dTop := 18;
DlgIcon := diYour;
// with diYour you place your custom icon in the Your.hIcon
ClientIcon := ciYes;
Buttons := dbYour3; // 3 custom text caption buttons
Your.ButText1 := 'Do It';
// these Your.ButText must be set to the 3 button captions
Your.ButText2 := 'Maybe Later';
Your.ButText3 := 'Forget It';
Your.hIcon := LoadIcon(hInstance,'YourIcon');
// place your custom icon handle in Your.hIcon
end;
Re1 := MsgResult('A Question Message, asking what to do.'#10+
'Second line has more info about options'#10+
'Pick the "Do It" to see a MsgResult'#10#10+
'Do You want to do this?',
'',@dSetUp);
if Re1 = IDOne then
MsgResult('The Result was "Do It"', ReStr, nil)
else if Re1 = IDTwo then
ShowMsg(hForm1, #10'Result was "Maybe Later"', ReStr)
else if Re1 = IDThree then
ShowMsg(hForm1, #10'Result was "Forget It"', ReStr)
else if Re1 = IDCancel then
ShowMsg(hForm1,
'Result was "Cancel"'#10'Clicked the X', ReStr);
end;
|
MsgWnds.pas Unit, a Message Window Unit
| Here is the code for this MsgWnds.pas Unit. There are functions to get all of the top level windows and disable them, and then enable them later. The ShowMsg procedure is a simple non-blockig message window code. If you want it to block code progression just add the WaitTilClose( ) function. This unit is mostly about the MsgResult( ) function, which you should look at to get ideas for making your own code-blocking modal windows. There are several parts to the MsgResult function, which gets the width and height needed for the text of the message, sets the icon, creates and positions the number of buttons. You can add your own message window options, maybe a color option. |
unit MsgWnds;
{This MsgWnds unit has two functions to show modal message windows.}
interface
// Below are the settings used for options in the MsgResult function
const
{IDStart and IDStop are added dialog button results,
for the Start and Stop buttons}
IDStart = 20;
IDStop = 21;
{ the 3 constant values below are returned by the MsgResult( ) function
if you have "Your" buttons on the message dialog}
IDOne = 600;
IDTwo = 601;
IDThree = 602;
type
{the 3 types below TDlgIcon, TClientIcon and TDlgButton are used in the
TDlgSetUp record. The TDlgButton sets the buttons shown on the dialog.
The TDlgIcon sets the icon shown on the dialog. The TClientIcon sets if
an Icon will be shown on the Client Area.}
TDlgIcon = (diInfo, diError, diWarn, diQuestion, diYour, diDef);
{ diQuestion, diError, diWarn, diInfo - will use the system dialog Icons
diYour - will set the Icon you place in TDlgSetUp.Your.hIcon
diDef - will use the default Application Icon in Resource MainIcon }
TClientIcon = (ciNone, ciYes, ciOver);
{ ciNone - No Icon on the Client Area
ciYes - places Icon at top, on the right of all text, will NOT cover text
ciOver - Icon on the top-right of Client Area, overlaps any text under it }
TDlgButton = (dbOK, dbOkCancel, dbYesNo, dbYesNoCancel, dbRetryCancel,
dbStartCancel, dbStopContinue, dbYour1, dbYour2, dbYour3);
{ you should get the buttons captions from the TDlgButton Names,
like dbOkCancel - two buttons with OK on one and Cancel on the other.
If you want to place your own text on buttons, use dbYour1 for One Button
use dbYour2 for 2 buttons, dbYour3 for 3 buttons. Place the button's
caption in the ButText1, ButText2 strings of the TDlgSetUp.Your record}
TYour = record // has settings for button captions and icon
ButText1, ButText2, ButText3: String[12]; { only 12 charaters on a button.
if you set TDlgButton to dbYour1, dbYour2 or dbYour3 then place the
caption text for your buttons in ButText1, ButText2 and ButText3 }
hIcon: Integer; // this Icon handle is used if you set diYour in DlgIcon
end;
PDlgSetUp = ^TDlgSetUp;
TDlgSetUp = record
hParent: Integer; // sets Parent "Owner" of dialog, form that calls dialog
CenterText: Boolean; // set CenterText to true or text is left aligned
dLeft, dTop: Integer; // position of window, set to 0 for work area center
DlgIcon: TDlgIcon; // sets the Icon for the dialog
ClientIcon: TClientIcon; // set to have a Client area Icon
Buttons: TDlgButton; // sets the buttons, how many and captions
Your: TYour; // holds settings for "Your" options
end;
procedure ShowMsg(hParent: Integer; const Mess, Title: String);
{ ShowMsg is a simple "Modal" window that does NOT Block code progression.
It is mostly to show you how block user input to forms on screen}
function MsgResult(const Msg, Title: String; pDlgSetUp1: PDlgSetUp): Integer;
{ the MsgResult function is for message display that blocks code progression.
You have string inputs for the message and title. There is a pDlgSetUp1
parameter, which is a pointer type, if you have NIL for this pointer, you
will get the default settings with an OK button. You fill and place a
TDlgSetUp in this pointer to use the Options available in this function}
implementation
uses Windows, Messages;
const
Zero = 0;
ID_Static = 200;
var
MsgClass: TWndClass;
aResult: record hWnd, Result: Integer; end;
// aResult is used to get a button click Result for the MsgResult function
FontBut, aFont: Cardinal;
hFParent: Integer;
aryMsgForms: Array of Integer;
{ aryMsgForms has all of the handles of the message windows
this will allow more than one message window to exist }
aryEnable: Array of Integer;
// aryEnable has all of the handles for the dis-abled windows
procedure DeleteMsgForm(Handle: Integer);
var
i: Integer;
begin
// this procedure removes a handle form the aryMsgForms array
for i := Zero to High(aryMsgForms) do
if Handle = aryMsgForms[i] then
begin
if i <> High(aryMsgForms) then
MoveMemory(@aryMsgForms[i],@aryMsgForms[i+1],
SizeOf(Integer)*(High(aryMsgForms)-i));
// the MoveMemory will move all of the array data forward one position
setLength(aryMsgForms, Length(aryMsgForms)-1);
Break;
end;
end;
function FoundTopLevel(hWnd, LParam: Integer): BOOL; StdCall;
var
i: Integer;
begin
// this is the call back function for EnumThreadWindows function
Result := True;
// return true to get all windows
{I wanted to be able to show more than one Message-window, the Msg-windows
are also top-level, and I did not want any Msg-Wnds to be disabled,
so I add all Msg-Wnds handles to the aryMsgForms array}
for i := Zero to High(aryMsgForms) do
if hWnd = aryMsgForms[i] then Exit;
// if a top-level is a Msg-Wnd then exit and do NOT add it to aryEnable
SetLength(aryEnable, Length(aryEnable)+1);
// make aryEnable larger and add window handle
aryEnable[High(aryEnable)] := hWnd;
end;
procedure DisableForms;
var
i: Integer;
begin
{ if there is no aryEnable handles, then use EnumThreadWindows
to get all top-level windows in the aryEnable array }
if Length(aryEnable) = Zero then
begin
EnumThreadWindows(GetCurrentThreadId, @FoundTopLevel, Zero);
// after all top-level are in aryEnable, dis-able all with EnableWindow( )
for i := Zero To High(aryEnable) do
EnableWindow(aryEnable[i], False);
end;
end;
function MsgFunc(hWnd,Msg,wParam,lParam:Integer):Integer; stdcall;
var
PaintS: TPaintStruct;
i: Integer;
cRect: TRect;
begin
// this is the Window Proc for all of the message windows
case Msg of
WM_CLOSE: begin
// when a message window closes the aResult is set
if (aResult.hWnd <> hWnd) then // you test to see if aResult.Result is valid
begin
aResult.Result := IDCancel;
aResult.hWnd := hWnd;
end;
DeleteMsgForm(hWnd);
// remove this window from the aryMsgForms array with DeleteMsgForm
if High(aryMsgForms) < Zero then
begin
// if all of the msg forms are closed, then High(aryMsgForms) is -1
// you need to enable all the top windows
for i := Zero to High(aryEnable) do
EnableWindow(aryEnable[i], True);
SetLength(aryEnable, Zero); // reset aryEnabled array to zero
end;
end;
WM_PAINT: begin
// to have a visual clue for a message window I paint a white line
GetClientRect(hWnd, cRect);
BeginPaint(hWnd, PaintS);
SelectObject(PaintS.hDC, GetStockObject(NULL_BRUSH));
SelectObject(PaintS.hDC, GetStockObject(WHITE_PEN));
Rectangle(Paints.hDC,cRect.Left, cRect.Top, cRect.Right, cRect.Bottom);
EndPaint(hWnd,PaintS);
Result := Zero;
Exit;
end;
WM_COMMAND: if HIWORD(WParam) = BN_CLICKED then
begin
// aResult is used for the WaitMessage repeat loop, so set it for button click
aResult.Result := LOWORD(wParam); // button ID
aResult.hWnd := hWnd; // set aResult.hWnd to handle for valid Result in WM_CLOSE
PostMessage(hWnd, WM_CLOSE, Zero, Zero); // any button clicked closes window
end;
end;
Result := DefWindowProc(hWnd,Msg,wParam,lParam);
end;
function DoUserMsgs: Boolean;
var
aMsg: TMSG;
begin
{ for the WaitTilClose repeat loop , you will need to
get the message queue messages and dispatch them }
Result := False; // WaitTilClose loop continues as long as Result is False
while PeekMessage(aMsg, Zero, Zero, Zero, PM_REMOVE) do
if aMsg.message = WM_QUIT then
begin
Result := True;
// IMPORTANT, must get WM_QUIT and repost it, set Result so repeat loop is ended
PostQuitMessage(Zero);
Break;
end else
if not IsDialogMessage(GetActiveWindow, aMsg) then
begin
TranslateMessage(aMsg);
DispatchMessage(aMsg);
end;
end;
function WaitTilClose(hWnd: Integer): Integer;
begin
// this function allows you to wait until the hWnd window closes
aResult.Result := IDCancel;
aResult.hWnd := Zero;
repeat
if DoUserMsgs or (aResult.hWnd = hWnd) then Break;
WaitMessage;
{ the WaitMessage function is what allows this to be a "Modal" window AND
wait for this MsgResult function to return. The WaitMessage function will
yield control to other threads when this thread has no messages }
until (aResult.hWnd = hWnd) or (not IsWindow(hWnd));
Result := aResult.Result;
end;
procedure ShowMsg(hParent: Integer; const Mess, Title: String);
var
hNew, hBut: Integer;
begin
{this ShowMsg procedure creates a modal message box window.
It does NOT block code progression like the API MessageBox function.
But it does disable all top-level windows for a modal effect.
For this lesson, the code here is simple, I do NOT size the message window
or offer any options except the message and title strings,
there can only be an OK button}
hNew := CreateWindow(MsgClass.lpszClassName, PChar(Title),
WS_CAPTION or WS_POPUP or WS_VISIBLE,
((GetSystemMetrics(SM_CXSCREEN) div 2)-130)+(High(aryMsgForms)*6),
(GetSystemMetrics(SM_CYSCREEN) div 2)-75, 260, 124,
hParent, Zero, hInstance, nil);
if hNew = Zero then Exit;
setLength(aryMsgForms, Length(aryMsgForms)+1);
aryMsgForms[High(aryMsgForms)] := hNew;
{ you must add this window handle to the aryMsgForms array
to have more than one message window}
SendMessage(CreateWindow('STATIC',PChar(Mess),
WS_VISIBLE or WS_CHILD,6,6,246,54,hNew,ID_Static,hInstance,nil),
WM_SETFONT,aFont,Zero);
hBut := CreateWindow('BUTTON', 'O K',
WS_VISIBLE or WS_CHILD or BS_PUSHBUTTON or WS_BORDER or WS_TABSTOP,
102,64,58,26,hNew,IDOk,hInstance,nil);
SendMessage(hBut, WM_SETFONT, FontBut, Zero);
SetFocus(hBut);
DisableForms;
// call DisableForms procedure to have a Modal effect
// WaitTilClose(hNew);
// if you want to block code progression then add the WaitTilClose above
end;
function FindParent(hWnd, LParam: Integer): BOOL; StdCall;
begin
Result := True;
if GetWindowLong(hWnd, GWL_HWNDPARENT) = Zero then
begin
hFParent := hWnd;
Result := False;
end;
end;
{below is the MsgResult function, this has many options that are in a TDlgSetUp
record in the pDlgSetUp1 parameter. To have an auto-sizing, muti-button,
client icon many option message box, requires much code}
function MsgResult(const Msg, Title: String; pDlgSetUp1: PDlgSetUp): Integer;
var
hNew: Integer;
TextRect, Rect1: TRect;
sDC, hIcon1: Cardinal;
DSU1: TDlgSetUp;
aTitle: String;
workRect: TRect;
first: Boolean;
procedure MakeButton(const Cap: String; aPos, ID: Integer; but: Integer = 2);
var
bRect: TRect;
aLeft, aWnd: Integer;
begin
// this procedure will make and position all of the buttons
if but = 1 then // sets the button position in aLeft for number of buttons
aLeft := (Rect1.Right - 80) div 2
else
if but < 3 then
aLeft := (Rect1.Right - (80 * 2) - 10) div 2
else
aLeft := (Rect1.Right - (80 * 3) - 20) div 2;
case aPos of // aPos has the button's order place in it
1: SetRect(bRect,aLeft,TextRect.Bottom+3,80,24); // first button
2: SetRect(bRect,aLeft+90,TextRect.Bottom+3,80,24); // second button
3: SetRect(bRect,aLeft+180,TextRect.Bottom+3,80,24);
else SetRect(bRect,104,TextRect.Bottom+3,80,24);
end;
aWnd := CreateWindow('BUTTON', PChar(Cap),
WS_VISIBLE or WS_CHILD or BS_PUSHBUTTON or WS_TABSTOP,
bRect.Left,bRect.Top,bRect.Right,bRect.bottom,hNew,ID,hInstance,nil);
SendMessage(aWnd, WM_SETFONT, FontBut, Zero);
if first then
SetFocus(aWnd); // give focus to first button made
first := False;
end;
begin
first := True; // first is used to set focus on the first button created
hFParent := Zero;
EnumThreadWindows(GetCurrentThreadId, @FindParent, Zero);
{ FindParent function should get the main window, you should have a parent
for message windows, if the hParent is not a window then hFParent is used }
if IsBadCodePtr(pDlgSetUp1) then // use defaults if pDlgSetUp1 is not a PDlgSetUp
begin
{I have this fuction so if you set the pDlgSetUp1 to nil, you get the
default settings, added to DSU1 below }
ZeroMemory(@DSU1, SizeOf(DSU1)); // sets defaults in record
with DSU1 do
begin
hParent := hFParent;
ClientIcon := ciYes;
{ I have added a way to set the Icon and have default entrys also added.
the pDlgSetUp1 can be set to 1, 2, 3, or 4 , for an Icon number}
case Cardinal(pDlgSetUp1) of
1: DlgIcon := diError;
2: DlgIcon := diWarn;
3: DlgIcon := diQuestion;
4: begin
DlgIcon := diDef;
ClientIcon := ciNone;
end;
end;
end;
pDlgSetUp1 := @DSU1; // DSU1 as the default
end; // if IsBadCodePtr
Result := IDCancel;
hIcon1 := Zero;
aTitle := 'Message';
with pDlgSetUp1^ do // set the Icon used for this message box
if (DlgIcon = diYour) and (Your.hIcon > 32) then
hIcon1 := Your.hIcon
else
case DlgIcon of
diQuestion: begin
aTitle := 'Question';
hIcon1 := LoadIcon(Zero,IDI_QUESTION);
end;
diError: begin
aTitle := 'Error';
hIcon1 := LoadIcon(Zero,IDI_ERROR);
end;
diWarn: begin
aTitle := 'Warning';
hIcon1 := LoadIcon(Zero,IDI_EXCLAMATION);
end;
diInfo: begin
aTitle := 'Infomation';
hIcon1 := LoadIcon(Zero,IDI_ASTERISK);
end;
diDef: hIcon1 := MsgClass.hIcon;
end;
if Length(Title) > Zero then
aTitle := Title;
{the code below with TextRect will get the rectangle size of the Text in the
Message parameter using the DrawText( ) function,
the size of the window will be changed to fit the text rectangle}
SetRect(TextRect, Zero, Zero, GetSystemMetrics(SM_CXSCREEN) div 2, Zero);
sDC := GetDC(Zero);
SelectObject(sDC, aFont);
DrawText(sDC, PChar(Msg), -1, TextRect,
DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK);
ReleaseDC(Zero, sDC);
// if short text, I make sure the window is not smaller than 204 pixels wide
if pDlgSetUp1.Buttons in [dbYesNoCancel, dbYour3] then
begin
if TextRect.Right < 274 then
TextRect.Right := 274;
end else
if TextRect.Right < 204 then
TextRect.Right := 204;
Inc(TextRect.Bottom, 16);
if (pDlgSetUp1.ClientIcon = ciYes) and (hIcon1 > 32) then
SetRect(Rect1,Zero,Zero,TextRect.Right+47,TextRect.Bottom+60)
else
SetRect(Rect1,Zero,Zero,TextRect.Right+16,TextRect.Bottom+60);
if not AdjustWindowRect(Rect1,WS_OVERLAPPEDWINDOW,False) then
SetRect(Rect1,Zero,Zero,TextRect.Right+6,TextRect.Bottom+34);
if not SystemParametersInfo(SPI_GETWORKAREA, Zero, @workRect,Zero) then
SetRect(workRect, Zero, Zero, GetSystemMetrics(SM_CXSCREEN),
GetSystemMetrics(SM_CYSCREEN)-32);
with pDlgSetUp1^, workRect do
begin
// setting dTop to less than 1 (zero) will get center screen Y
if dTop < 1 then
dTop := ((Bottom - Top) div 2)- (Rect1.Bottom div 2)
else
if dTop > Bottom-36 then dTop := Bottom-36;
{ IMPORTANT - you should test to see if window is visible on the
work area, since this is a Modal window, it should be available to the user}
if dLeft < 1 then // dLeft to zero will set center screen X
dLeft := ((Right - Left) div 2)- (Rect1.Right div 2)
else
if dLeft > Right-36 then dLeft := Right-36;
if not IsWindow(hParent) then // try to have an owner window
hParent := hFParent;
hNew := CreateWindow(MsgClass.lpszClassName, PChar(aTitle),
WS_CAPTION or WS_SYSMENU or WS_POPUP or WS_VISIBLE,
dLeft, dTop, Rect1.Right, Rect1.Bottom,
hParent, 0, hInstance, nil);
end;
if hNew = Zero then Exit;
GetClientRect(hNew, Rect1);
if hIcon1 <> Zero then
begin
if hIcon1 <> MsgClass.hIcon then
SendMessage(hNew, WM_SETICON, 1, hIcon1);
if pDlgSetUp1.ClientIcon <> ciNone then
SendMessage(CreateWindow('Static', nil,
WS_VISIBLE or WS_CHILD or SS_ICON or WS_CLIPSIBLINGS,
Rect1.Right-33,1,32,32,hNew,Zero,hInstance,nil),
STM_SETIMAGE, IMAGE_ICON, hIcon1);
end;
if Ord(pDlgSetUp1.CenterText) > 1 then pDlgSetUp1.CenterText := False;
// the code above is if the TDlgSetUp has not been filled with Zeros
SendMessage(CreateWindow('STATIC',PChar(Msg),
WS_VISIBLE or WS_CHILD or WS_CLIPSIBLINGS or
(SS_CENTER * Ord(pDlgSetUp1.CenterText)),8,8,TextRect.Right,
TextRect.Bottom,hNew,ID_Static,hInstance,nil),
WM_SETFONT, aFont, Zero);
setLength(aryMsgForms, Length(aryMsgForms)+1);
aryMsgForms[High(aryMsgForms)] := hNew; // add this to the aryMsgForms handles
with pDlgSetUp1^ do
case Buttons of // sets the number of buttons, their caption and ID number
dbOK: MakeButton('O K', 1, IDOK, 1);
dbOkCancel: begin
MakeButton('O K', 1, IDOK);
MakeButton('Cancel', 2, IDCancel);
end;
dbYesNo: begin
MakeButton('YES', 1, IDYes);
MakeButton('NO', 2, IDNo);
end;
dbYesNoCancel: begin
MakeButton('YES', 1, IDYes, 3);
MakeButton('NO', 2, IDNo, 3);
MakeButton('Cancel', 3, IDCancel, 3);
end;
dbRetryCancel: begin
MakeButton('Retry', 1, IDRetry);
MakeButton('Cancel', 2, IDCancel);
end;
dbStartCancel: begin
MakeButton('Start', 1, IDStart);
MakeButton('Cancel', 2, IDCancel);
end;
dbStopContinue: begin
MakeButton('Stop', 1, IDStop);
MakeButton('Continue', 2, IDCancel);
end;
dbYour1: MakeButton(Your.ButText1, 1, IDOne, 1);
dbYour2: begin
MakeButton(Your.ButText1, 1, IDOne);
MakeButton(Your.ButText2, 2, IDTwo);
end;
dbYour3: begin
MakeButton(Your.ButText1, 1, IDOne, 3);
MakeButton(Your.ButText2, 2, IDTwo, 3);
MakeButton(Your.ButText3, 3, IDThree, 3);
end;
end;
DisableForms; // set for modal
Result := WaitTilClose(hNew);
// WaitTilClose will process messages AND not return until msg window is closed
end;
procedure DoSetup;
var
NonClMetrics: TNonClientMetrics;
FontLog1: TLogFont;
begin
// initialization code, register the class and makes fonts
ZeroMemory(@MsgClass, SizeOf(MsgClass));
with MsgClass do
begin
Style := CS_PARENTDC or CS_BYTEALIGNCLIENT;;
hInstance := SysInit.hInstance;
hIcon := LoadIcon(hInstance,'MAINICON');
if hIcon = Zero then
hIcon := LoadIcon(Zero,IDI_WINLOGO);
lpfnWndProc := @MsgFunc;
hbrBackground := COLOR_BTNFACE+1;
lpszClassName := 'Msg4 Class12';
hCursor := LoadCursor(Zero,IDC_ARROW);
end;
RegisterClass(MsgClass);
NonClMetrics.cbSize := SizeOf(NonClMetrics);
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Zero, @NonClMetrics,Zero);
aFont := CreateFontIndirect(NonClMetrics.lfMessageFont);
// get system message font
ZeroMemory(@FontLog1, SizeOf(FontLog1));
with FontLog1 do
begin
lfHeight := -11;
lfWidth := 5;
lfOutPrecision := OUT_TT_PRECIS;
lfPitchAndFamily := VARIABLE_PITCH or FF_SWISS;
lfFaceName := 'Arial'#0;
end;
if aFont = Zero then
aFont := CreateFontIndirect(FontLog1);
with FontLog1 do
begin
lfHeight := -12;
lfWidth := 6;
lfWeight := 700;
end;
FontBut := CreateFontIndirect(FontLog1);
end;
initialization
DoSetUp;
finalization
DeleteObject(FontBut);
DeleteObject(aFont);
end. |
I hope you can take time to try and experiment with the different methods presented in the code above for
modal windows. You can change the defaults in the MsgResult function to those that you might use more.
You can also add your own options to the TDlgSetUp Record, or maybe add a "Sound" when
the MsgResult window is displayed with the MessageBeep(MB_ICONERROR) function.
Next Page
The next page shows you how to create a Program that makes a Tray icon in the task bar's status area.
Tray Icon Program
H O M E
