show a MessageBox with a "Don't show this message again"-Checkbox?

...show a MessageBox with a "Don't show this message again"-Checkbox?
Autor: P. Below

Example call:
Beispielaufruf:
procedure TForm1.Button1Click(Sender: TObject);
var
askNoMore : Boolean;
begin
askNoMore:= False;
MessageDlgWithNoMorebox('Delete File?','Would you like to delete this file?', mtConfirmation,
[mbOK, mbCancel], 1, 0, askNoMore);
end;

{== MyDialogs =========================================================}
{: Collects modified dialog functions
@author Dr. Peter Below
@desc Version: 1.0 Created: 07.06.98<BR>
Version 1.01 created 4 Juli 2001, added translation of
button captions.<BR>
Last modified 4 Juli 2001<P>
}
{======================================================================}
unit MyDialogs;

interface

uses Dialogs;

function DefMessageDlg(const aCaption : string;
const Msg : string;
DlgType : TMsgDlgType;
Buttons : TMsgDlgButtons;
DefButton : integer;
HelpCtx : longint): integer;

function MessageDlgWithNoMorebox(const aCaption : string;
const Msg : string;
DlgType : TMsgDlgType;
Buttons : TMsgDlgButtons;
DefButton : integer;
HelpCtx : longint;
var askNoMore : boolean): integer;

implementation

uses Windows, Classes, Controls, stdctrls, sysutils, forms;

const { Copied from Dialogs }
ModalResults : array[TMsgDlgBtn] of integer = (mrYes, mrNo, mrOk,
mrCancel, mrAbort, mrRetry, mrIgnore, mrAll,
mrNoToAll, mrYesToAll, 0);

var { Filled during unit initialization }
ButtonCaptions : array[TMsgDlgBtn] of string;

{ Convert a modal result to a TMsgDlgBtn code. }
function ModalResultToBtn(res : TModalResult): TMsgDlgBtn;
begin
for Result := Low(Result) to High(Result) do
begin
if ModalResults[Result] = res then
Exit;
end; { For }
Result := mbHelp; // to remove warning only
Assert(False, 'ModalResultToBtn: unknown modalresult ' +
IntToStr(res));
end; { ModalResultToBtn }

{ When the button captions on the message form are translated
the button size and as a consequence the button positions need
to be adjusted. }
procedure AdjustButtons(aForm : TForm);
var
buttons : TList;
btnWidth : integer;
btnGap : integer;

procedure CollectButtons;
var
i : integer;
begin
for i := 0 to aForm.Controlcount - 1 do
if aForm.Controls is TButton then
buttons.Add(aForm.Controls[i]);
end; [i]{ CollectButtons }

procedure MeasureButtons;
var
i : integer;
textrect : TRect;
w : integer;
begin
btnWidth := TButton(buttons[0]).Width;
aForm.Canvas.Font := aForm.Font;
for i := 0 to buttons.Count - 1 do
begin
TextRect := Rect(0, 0, 0, 0);
Windows.DrawText(aform.canvas.handle,
PChar(TButton(buttons).Caption), - 1,
TextRect,
DT_CALCRECT or DT_LEFT or DT_SINGLELINE);
with TextRect do w := Right - Left + 16;
if w > btnWidth then btnWidth := w;
end; [i]{ For }
if buttons.Count > 1 then
btnGap := TButton(buttons[1]).Left -
TButton(buttons[0]).Left -
TButton(buttons[0]).Width
else
btnGap := 0;
end; { MeasureButtons }

procedure SizeButtons;
var
i : integer;
begin
for i := 0 to buttons.Count - 1 do
TButton(buttons).Width := btnWidth;
end; [i]{ SizeButtons }

procedure ArrangeButtons;
var
i : integer;
total, left : integer;
begin
total := (buttons.Count - 1) * btnGap;
for i := 0 to buttons.Count - 1 do
Inc(total, TButton(buttons).Width);
left := (aForm.ClientWidth - total) div 2;
if left < 0 then
begin
aForm.Width := aForm.Width + 2 * Abs(left) + 16;
left := 8;
end; [i]{ If }
for i := 0 to buttons.Count - 1 do
begin
TButton(buttons).Left := left;
Inc(left, btnWidth + btnGap);
end;
end; [i]{ ArrangeButtons }
begin
buttons := TList.Create;
try
CollectButtons;
if buttons.Count = 0 then
Exit;
MeasureButtons;
SizeButtons;
ArrangeButtons;
finally
buttons.Free;
end; { finally }
end; { AdjustButtons }

procedure InitMsgForm(aForm : TForm; const aCaption : string;
helpCtx : longint; DefButton : integer);
var
i : integer;
btn : TButton;
begin
with aForm do
begin
if Length(aCaption) > 0 then
Caption := aCaption;
HelpContext := HelpCtx;
for i := 0 to ComponentCount - 1 do
begin
if Components is TButton then
begin
btn := TButton(Components[i]);
btn.Default := btn.ModalResult = DefButton;
if btn.Default then
ActiveControl := Btn;
[i]{$IFNDEF STANDARDCAPTIONS}
btn.Caption :=
ButtonCaptions[ModalResultToBtn(btn.Modalresult)];
{$ENDIF}
end;
end; { For }
{$IFNDEF STANDARDCAPTIONS}
AdjustButtons(aForm);
{$ENDIF}
end;
end; { InitMsgForm }

{-- DefMessageDlg -----------------------------------------------------}
{: Creates a MessageDlg with translated button captions and a configurable
default button and caption.
@Param aCaption Caption to use for the dialog. If empty the
default is used.
@Param Msg message to display
@Param DlgType type of dialog, see MessageDlg online help
@Param Buttons buttons to display, see MessageDlg online help
@Param DefButton ModalResult of the button that should be the
default.
@Param HelpCtx help context (optional)
@Returns the ModalResult of the dialog
}{ Created 07.06.1998 by P. Below, modified 04.07.2001
-----------------------------------------------------------------------}
function DefMessageDlg(const aCaption : string; const Msg : string;
DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; DefButton : integer;
HelpCtx : longint): integer;
var
aForm : TForm;
begin { DefMessageDlg }
aForm := CreateMessageDialog(Msg, DlgType, Buttons);
try
InitMsgForm(aForm, aCaption, helpCtx, DefButton);
Result := aForm.ShowModal;
finally
aForm.Free;
end;
end; { DefMessageDlg }

resourcestring
{$IFDEF GERMAN}
AskNoMoreCaption = 'Diesen Dialog nicht mehr anzeigen';
{$ELSE}
AskNoMoreCaption = 'Don''t show this dialog again';
{$ENDIF}

{-- MessageDlgWithNoMorebox -------------------------------------------}
{: Creates a MessageDlg with translated button captions and a configurable
default button and caption.
@Param aCaption Caption to use for the dialog. If empty the
default is used.
@Param Msg message to display
@Param DlgType type of dialog, see MessageDlg online help
@Param Buttons buttons to display, see MessageDlg online help
@Param DefButton ModalResult of the button that should be the
default.
@Param HelpCtx help context (optional)
@Param askNoMore if this is passed in as True the function will directly
return the DefButton result. Otherwise a checkbox is
shown beneath the buttons which the user can check to
not have this dialog show up in the future. Its checked
state is returned in the parameter.
@Returns the ModalResult of the dialog
}{ Created 4.7.2001 by P. Below
-----------------------------------------------------------------------}
function MessageDlgWithNoMorebox(const aCaption : string;
const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons;
DefButton : integer; HelpCtx : longint;
var askNoMore : boolean): integer;
var
aForm : TForm;
chk : TCheckbox;
begin { MessageDlgWithNoMorebox }
if askNoMore then
Result := DefButton
else
begin
aForm := CreateMessageDialog(Msg, DlgType, Buttons);
try
InitMsgForm(aForm, aCaption, helpCtx, DefButton);
chk := TCheckbox.Create(aForm);
chk.Parent := aForm;
chk.SetBounds(16, aForm.ClientHeight, aForm.Clientwidth - 32,
chk.Height);
chk.Checked := False;
chk.Caption := AskNoMoreCaption;
AForm.Height := aForm.Height + chk.Height + 8;
Result := aForm.ShowModal;
askNoMore := chk.Checked;
finally
aForm.Free;
end;
end;
end; { MessageDlgWithNoMorebox }

resourcestring
{$IFDEF GERMAN}
cmbYes = '&Ja';
cmbNo = '&Nein';
cmbOK = 'OK';
cmbCancel = 'Abbrechen';
cmbHelp = '&Hilfe';
cmbAbort = '&Abbrechen';
cmbRetry = '&Wiederholen';
cmbIgnore = '&Ignorieren';
cmbAll = '&Alle';
cmbNoToAll = 'N&ein für alle';
cmbYesToAll = 'Ja für &alle';
{$ELSE}
cmbYes = '&Yes';
cmbNo = '&No';
cmbOK = 'OK';
cmbCancel = 'Cancel';
cmbHelp = '&Help';
cmbAbort = '&Abort';
cmbRetry = '&Retry';
cmbIgnore = '&Ignore';
cmbAll = '&All';
cmbNoToAll = 'N&o to All';
cmbYesToAll = 'Yes to &All';
{$ENDIF}

procedure InitButtonCaptions;
begin
ButtonCaptions[mbYes] := cmbYes;
ButtonCaptions[mbNo] := cmbNo;
ButtonCaptions[mbOK] := cmbOK;
ButtonCaptions[mbCancel] := cmbCancel;
ButtonCaptions[mbAbort] := cmbAbort;
ButtonCaptions[mbRetry] := cmbRetry;
ButtonCaptions[mbIgnore] := cmbIgnore;
ButtonCaptions[mbAll] := cmbAll;
ButtonCaptions[mbNoToAll] := cmbNoToAll;
ButtonCaptions[mbYesToAll] := cmbYesToAll;
ButtonCaptions[mbHelp] := cmbHelp;
end; { InitButtonCaptions }

initialization
InitButtonCaptions;
end.