mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-12-03 11:57:42 +01:00
528 lines
17 KiB
PHP
528 lines
17 KiB
PHP
{******************************************************************************
|
|
MessageDialogs
|
|
******************************************************************************
|
|
|
|
*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.LCL, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
current design flaws:
|
|
|
|
- The actual design ignores any features provided by the underlying
|
|
widgetset. This is because the GTK libraries do not provide an
|
|
abstract dialog class
|
|
|
|
Delphi compatibility:
|
|
|
|
- the interface is almost like in delphi 5
|
|
|
|
TODO:
|
|
- calculate the size required for the dialog based on the
|
|
current font and the length of the text to be displayed
|
|
- remove all those nasty constants (cBitmapWidth...)
|
|
- use better strategy to set default button in function SetButtons
|
|
- Help-button
|
|
|
|
}
|
|
type
|
|
|
|
{ TMessageBox
|
|
|
|
Internal class used to build a MessageBox.
|
|
}
|
|
TMessageBox = class (TForm)
|
|
procedure MessageBoxKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
private
|
|
FBitmap : TBitmap;
|
|
FDlgType : TMsgDlgType;
|
|
FButtons : TMsgDlgButtons;
|
|
FRelayoutNeeded: boolean;
|
|
FUpdateCounter: integer;
|
|
FMsgLines: TStringList;
|
|
procedure SetMessage(const value : string);
|
|
function GetMessage: string;
|
|
procedure SetDialogType (const value : TMsgDlgType);
|
|
procedure SetButtons (const value : TMsgDlgButtons);
|
|
procedure ReLayout;
|
|
function LineWidth(Index: integer): integer;
|
|
function LineHeight: integer;
|
|
public
|
|
constructor Create (AOwner : TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Paint; override;
|
|
procedure FormActivate(Sender: TObject);
|
|
property TheMessage : string read GetMessage write SetMessage;
|
|
property DialogType : TMsgDlgType write SetDialogType;
|
|
property Buttons : TMsgDlgButtons write SetButtons;
|
|
procedure BeginUpdate;
|
|
procedure EndUpdate;
|
|
end;
|
|
|
|
const
|
|
//
|
|
//TODO: all the constants below should be replaced in the future
|
|
// their only purpose is to overcome some current design flaws &
|
|
// missing features in the GTK libraries
|
|
//
|
|
cBitmapX = 10; // x-position for bitmap in messagedialog
|
|
cBitmapY = 10; // y-position for bitmap in messagedialog
|
|
cBitmapWidth = 32; // width of the dialogs icon
|
|
cBitmapHeight= 32; // height of the dialogs icon
|
|
cLabelSpacing= 10; // distance between icon & label
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.Create
|
|
Params: AOwner: the owner of the class
|
|
Returns: Nothing
|
|
|
|
Constructor for a MessageBox
|
|
------------------------------------------------------------------------------}
|
|
constructor TMessageBox.Create (AOwner : TComponent);
|
|
begin
|
|
inherited Create (AOwner);
|
|
|
|
FMsgLines := TStringList.Create;
|
|
ControlStyle:= ControlStyle-[csSetCaption];
|
|
BorderStyle := bsDialog;
|
|
Position := poScreenCenter;
|
|
Width := 200;
|
|
Height := 100;
|
|
FDlgType := mtInformation;
|
|
FBitmap := nil;
|
|
FButtons := [mbOk];
|
|
FRelayoutNeeded := false;
|
|
FUpdateCounter := 0;
|
|
OnKeyDown:=@MessageBoxKeyDown;
|
|
OnActivate:=@FormActivate;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.Destroy
|
|
Params: ---
|
|
Returns: Nothing
|
|
|
|
Destructor for a MessageBox
|
|
------------------------------------------------------------------------------}
|
|
destructor TMessageBox.Destroy;
|
|
begin
|
|
FBitmap.Free;
|
|
FMsgLines.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.FormActivate
|
|
Params: ---
|
|
Returns: Nothing
|
|
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TMessageBox.FormActivate(Sender: TObject);
|
|
var i: integer;
|
|
begin
|
|
for i:=0 to ComponentCount-1 do begin
|
|
if (Components[i] is TBitBtn) and (TBitBtn(Components[i]).Default) then begin
|
|
// TBitBtn(Components[i]).SetFocus;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.Paint
|
|
Params: ---
|
|
Returns: Nothing
|
|
|
|
Draw the icon in the messagebox.
|
|
------------------------------------------------------------------------------}
|
|
procedure TMessageBox.Paint;
|
|
begin
|
|
inherited Paint;
|
|
if assigned (FBitmap) then
|
|
Canvas.CopyRect(Bounds(cBitmapX, cBitmapY,cBitmapWidth,cBitmapHeight),
|
|
FBitmap.Canvas,
|
|
Rect(0,0,cBitmapWidth,cBitmapHeight));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.LineWidth
|
|
Params: Index - index of the line to check the width
|
|
Returns: Text width of the line
|
|
------------------------------------------------------------------------------}
|
|
function TMessageBox.LineWidth(Index: integer): integer;
|
|
begin
|
|
if (Index>=0) and (Index<FMsgLines.Count) then
|
|
Result:=Canvas.TextWidth(FMsgLines[Index])
|
|
else
|
|
Result:=0;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.LineHeight
|
|
Params: nothing
|
|
Returns: Text height of the line
|
|
------------------------------------------------------------------------------}
|
|
function TMessageBox.LineHeight: integer;
|
|
begin
|
|
Result:=Canvas.TextHeight('ABCDEFGHIJKLMNOPQRSTUVWXYZgp09')+8;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.MessageBoxKeyDown
|
|
|
|
OnKeyDown Event handler for messages dialogs.
|
|
The 'Escape' key has the same meaning as a Cancel or Abort click.
|
|
------------------------------------------------------------------------------}
|
|
procedure TMessageBox.MessageBoxKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
begin
|
|
if (Key=VK_Escape) then begin
|
|
if mbCancel in FButtons then
|
|
ModalResult:=mrCancel
|
|
else if mbAbort in FButtons then
|
|
ModalResult:=mrAbort;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.SetMessage
|
|
Params: value - text to be displayed in the message box
|
|
Returns: Nothing
|
|
|
|
Sets the Text in MessageBox
|
|
------------------------------------------------------------------------------}
|
|
procedure TMessageBox.SetMessage (const Value : string);
|
|
begin
|
|
if Value=FMsgLines.Text then exit;
|
|
FMsgLines.Text:=Value;
|
|
FRelayoutNeeded:=true;
|
|
ReLayout;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.GetMessage
|
|
Params: Nothing
|
|
Returns: Message Text
|
|
|
|
Sets the Text in MessageBox
|
|
------------------------------------------------------------------------------}
|
|
function TMessageBox.GetMessage: string;
|
|
begin
|
|
if FMsgLines<>nil then
|
|
Result:=FMsgLines.Text
|
|
else
|
|
Result:='';
|
|
end;
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.SetDialogType
|
|
Params: value - the type of dialog to be shown
|
|
Returns: Nothing
|
|
|
|
Sets the type of dialog.
|
|
------------------------------------------------------------------------------}
|
|
procedure TMessageBox.SetDialogType (const Value : TMsgDlgType);
|
|
var DefaultCaption: boolean;
|
|
begin
|
|
if (value = FDlgType) and (assigned (FBitmap)) then exit;
|
|
DefaultCaption:=(Caption=cMtCaption[FDlgType]) or (Caption='');
|
|
FDlgType := value;
|
|
FBitmap.Free;
|
|
FBitmap := TBitmap.Create;
|
|
FBitmap.Handle := CreatePixmapIndirect(@mtImages[FDlgType],
|
|
ColorToRGB(clBtnFace));
|
|
if DefaultCaption then
|
|
Caption := cMtCaption[FDlgType];
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.SetButtons
|
|
Params: value - the set of buttons required
|
|
Returns: Nothing
|
|
|
|
Depending on "value" this method inserts some buttons into the dialog.
|
|
The more buttons required, the wider the dialog will be.
|
|
------------------------------------------------------------------------------}
|
|
procedure TMessageBox.SetButtons(const value : TMsgDlgButtons);
|
|
begin
|
|
if FButtons = Value then exit;
|
|
FButtons := Value;
|
|
if FButtons=[] then FButtons:=[mbOk];
|
|
FRelayoutNeeded:=true;
|
|
ReLayout;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TMessageBox.ReLayout
|
|
Params: nothing
|
|
Returns: Nothing
|
|
------------------------------------------------------------------------------}
|
|
procedure TMessageBox.ReLayout;
|
|
const
|
|
cBtnWidth = 85; //TODO: Take into account different languages; button width may vary!
|
|
cBtnDist = cBtnWidth + 25;
|
|
cBtnHeight = 32;
|
|
cMinLeft = cBitmapX + cBitmapWidth + cLabelSpacing;
|
|
var
|
|
aButton : TBitBtn; // temp. variable to create buttons
|
|
aBitmap : TBitmap; // temp. variable to create bitmaps for buttons
|
|
curBtn : TMsgDlgBtn; // variable to loop through TMsgDlgButtons
|
|
ButtonLeft : integer; // left position of button(s)
|
|
LabelLeft : integer; // left position of labels
|
|
reqBtnWidth : integer; // width neccessary to display buttons
|
|
reqWidth : integer; // width neccessary to display all
|
|
LabelWidth : integer; // max width of labels
|
|
LabelHeight : integer;
|
|
TempLabel : TLabel; // temporary label components
|
|
LabelIndex : integer;
|
|
i, j : integer;
|
|
ButtonIndex : integer;
|
|
begin
|
|
if FUpdateCounter>0 then exit;
|
|
|
|
// calculate label width
|
|
LabelWidth:=0;
|
|
for i:=0 to FMsgLines.Count-1 do begin
|
|
j:=LineWidth(i);
|
|
if j>LabelWidth then LabelWidth:=j;
|
|
end;
|
|
LabelHeight:=LineHeight;
|
|
|
|
// destroy old BitBtns
|
|
for i:=ComponentCount-1 downto 0 do
|
|
if Components[i] is TBitBtn then
|
|
Components[i].Free;
|
|
|
|
// calculate the width we need to display the buttons
|
|
reqBtnWidth := 0;
|
|
for curBtn := low (TMsgDlgBtn) to high (TMsgDlgBtn) do
|
|
if curBtn in FButtons then inc(reqBtnWidth, cBtnDist);
|
|
|
|
// patch positions to center label and buttons
|
|
reqWidth:=reqBtnWidth;
|
|
if reqWidth < LabelWidth then reqWidth:=LabelWidth;
|
|
LabelLeft := ((reqWidth - LabelWidth) div 2) + cMinLeft;
|
|
ButtonLeft := cMinLeft + ((reqWidth - reqBtnWidth) div 2) + (25 div 2);
|
|
|
|
// set size of form
|
|
SetBounds(Left,Top,reqWidth+cMinLeft+cLabelSpacing,
|
|
4*cLabelSpacing+FMsgLines.Count*(LabelHeight+cLabelSpacing)+cBtnHeight);
|
|
|
|
// create and position the labels
|
|
i:=0;
|
|
LabelIndex:=0;
|
|
while (i<ComponentCount) and (LabelIndex<FMsgLines.Count) do begin
|
|
if (Components[i] is TLabel) then begin
|
|
TempLabel:=TLabel(Components[i]);
|
|
with TempLabel do begin
|
|
SetBounds(LabelLeft,
|
|
cLabelSpacing+(cLabelSpacing+LabelHeight)*LabelIndex,
|
|
LabelWidth,LabelHeight);
|
|
Caption:=FMsgLines[LabelIndex];
|
|
Visible:=true;
|
|
end;
|
|
inc(LabelIndex);
|
|
end else
|
|
inc(i);
|
|
end;
|
|
while (i<ComponentCount) do
|
|
if (Components[i] is TLabel) then Components[i].Free;
|
|
while LabelIndex<FMsgLines.Count do begin
|
|
TempLabel:=TLabel.Create(Self);
|
|
with TempLabel do begin
|
|
Parent := Self;
|
|
Name:='MsgLabel'+IntToStr(LabelIndex);
|
|
SetBounds(LabelLeft,
|
|
cLabelSpacing+(cLabelSpacing+LabelHeight)*LabelIndex,
|
|
LabelWidth,LabelHeight);
|
|
Caption:=FMsgLines[LabelIndex];
|
|
Visible:=true;
|
|
end;
|
|
inc(LabelIndex);
|
|
end;
|
|
|
|
// create the buttons
|
|
ButtonIndex := -1;
|
|
for curBtn := low(TMsgDlgBtn) to high(TMsgDlgBtn) do begin
|
|
if curBtn in FButtons then begin
|
|
inc(ButtonIndex);
|
|
aButton := TBitBtn.Create(self);
|
|
With aButton do begin
|
|
Parent := Self;
|
|
SetBounds (ButtonLeft,
|
|
3*cLabelSpacing+(cLabelSpacing+LabelHeight)*FMsgLines.Count,
|
|
cBtnWidth, cBtnHeight);
|
|
inc(ButtonLeft, cBtnDist);
|
|
Layout := blGlyphLeft;
|
|
// ToDo: when TBitmap streaming is working, load image from resource
|
|
aBitmap := TBitmap.Create;
|
|
aBitmap.Handle := CreatePixmapIndirect(@mbImages [curBtn],
|
|
ColorToRGB(clBtnFace));
|
|
Glyph := aBitmap;
|
|
ModalResult := cMbResult[curBtn];
|
|
Caption := cMbCaption[curBtn];
|
|
if ButtonIndex=0 then Default := true;
|
|
if curbtn in [mbOK, mbYes] then Default := true;
|
|
Visible:=true;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
for i:=0 to ComponentCount-1 do begin
|
|
if (Components[i] is TBitBtn) and (TBitBtn(Components[i]).Default) then begin
|
|
TBitBtn(Components[i]).SetFocus;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
FRelayoutNeeded:=false;
|
|
end;
|
|
|
|
procedure TMessageBox.BeginUpdate;
|
|
begin
|
|
inc(FUpdateCounter);
|
|
end;
|
|
|
|
procedure TMessageBox.EndUpdate;
|
|
begin
|
|
dec(FUpdateCounter);
|
|
if FUpdateCounter<0 then FUpdateCounter:=0;
|
|
if (FUpdateCounter=0) and (FRelayoutNeeded) then
|
|
ReLayout;
|
|
end;
|
|
|
|
// ---------------------------------------------------------------------------
|
|
|
|
function CreateMessageDialog(const aMsg: string; DlgType: TMsgDlgType;
|
|
Buttons: TMsgDlgButtons): TForm;
|
|
var
|
|
msgbox : TMessageBox;
|
|
begin
|
|
msgbox := TMessageBox.Create (application);
|
|
msgbox.BeginUpdate;
|
|
msgbox.theMessage := aMsg;
|
|
msgBox.DialogType := DlgType;
|
|
msgBox.Buttons := buttons;
|
|
msgbox.EndUpdate;
|
|
Result := msgbox;
|
|
end;
|
|
|
|
function CreateMessageDialogWithCap(const aCaption, aMsg: string;
|
|
DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): TForm;
|
|
var
|
|
msgbox : TMessageBox;
|
|
begin
|
|
msgbox := TMessageBox.Create (Application);
|
|
msgbox.BeginUpdate;
|
|
msgbox.theMessage := aMsg;
|
|
msgBox.DialogType := DlgType;
|
|
msgBox.Buttons := buttons;
|
|
msgBox.Caption := aCaption;
|
|
msgbox.EndUpdate;
|
|
Result := msgbox;
|
|
end;
|
|
|
|
function MessageDlg(const aMsg: string; DlgType: TMsgDlgType;
|
|
Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
|
|
var
|
|
aDialog : TForm;
|
|
begin
|
|
aDialog := CreateMessageDialog (aMsg, DlgType, buttons);
|
|
try
|
|
Result := aDialog.ShowModal;
|
|
finally
|
|
aDialog.Free;
|
|
end;
|
|
end;
|
|
|
|
function MessageDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;
|
|
Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
|
|
var
|
|
aDialog : TForm;
|
|
begin
|
|
aDialog := CreateMessageDialogWithCap(aCaption, aMsg, DlgType, buttons);
|
|
try
|
|
Result := aDialog.ShowModal;
|
|
finally
|
|
aDialog.Free;
|
|
end;
|
|
end;
|
|
|
|
function MessageDlgPos(const aMsg: string; DlgType: TMsgDlgType;
|
|
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;
|
|
var
|
|
aDialog : TForm;
|
|
begin
|
|
aDialog := CreateMessageDialog (aMsg, DlgType, buttons);
|
|
aDialog.Position:=poDefault;
|
|
aDialog.Left := x;
|
|
aDialog.Top := y;
|
|
Result := aDialog.ShowModal;
|
|
end;
|
|
|
|
function MessageDlgPosHelp(const aMsg: string; DlgType: TMsgDlgType;
|
|
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
|
|
const HelpFileName: string): Integer;
|
|
begin
|
|
writeln ('MessageDlgPosHelp ****** NOT YET FULLY IMPLEMENTED ********');
|
|
//TODO: set helpcontext and helpfile
|
|
result := MessageDlg (aMsg, DlgType, buttons, helpctx);
|
|
end;
|
|
|
|
procedure ShowMessage(const aMsg: string);
|
|
begin
|
|
MessageDlg (aMsg, mtInformation, [mbOK], 0);
|
|
end;
|
|
|
|
procedure ShowMessageFmt(const aMsg: string; Params: array of const);
|
|
begin
|
|
MessageDlg (Format (aMsg, Params), mtInformation, [mbOK], 0);
|
|
end;
|
|
|
|
procedure ShowMessagePos(const aMsg: string; X, Y: Integer);
|
|
begin
|
|
writeln ('ShowMessagePos ****** NOT YET FULLY IMPLEMENTED ********');
|
|
MessageDlg (aMsg, mtInformation, [mbOK], 0);
|
|
end;
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.11 2002/07/29 13:39:07 lazarus
|
|
MG: removed ambigious TBitmap from LCLType and added Escape key to MessageDlgs
|
|
|
|
Revision 1.10 2002/06/06 07:23:24 lazarus
|
|
MG: small fixes to reduce form repositioing
|
|
|
|
Revision 1.9 2002/05/10 06:05:53 lazarus
|
|
MG: changed license to LGPL
|
|
|
|
Revision 1.8 2001/12/10 22:39:37 lazarus
|
|
MG: added perl highlighter
|
|
|
|
Revision 1.7 2001/10/16 10:51:10 lazarus
|
|
MG: added clicked event to TButton, MessageDialog reacts to return key
|
|
|
|
Revision 1.6 2001/10/07 07:35:28 lazarus
|
|
MG: minor fix
|
|
|
|
Revision 1.4 2001/07/31 18:40:24 lazarus
|
|
MG: added unit info, arrow xpms, and many changes from jens arm
|
|
|
|
Revision 1.3 2001/06/14 14:57:58 lazarus
|
|
MG: small bugfixes and less notes
|
|
|
|
Revision 1.1 2001/03/03 00:50:34 lazarus
|
|
+ added support for message dialogs (messagedialogs.inc)
|
|
+ added some pixmaps for message dialogs(messagedialogpixmaps.inc)
|
|
stoppok
|
|
|
|
}
|