diff --git a/examples/messageboxes/testmsgboxes.lpi b/examples/messageboxes/testmsgboxes.lpi new file mode 100644 index 0000000000..f15aa94178 --- /dev/null +++ b/examples/messageboxes/testmsgboxes.lpi @@ -0,0 +1,138 @@ + + + + + + + + + + + <Scaled Value="True"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + </General> + <BuildModes Count="3"> + <Item1 Name="Default" Default="True"/> + <Item2 Name="gtk3"> + <MacroValues Count="1"> + <Macro1 Name="LCLWidgetType" Value="gtk3"/> + </MacroValues> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="testmsgboxes"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf3"/> + <UseExternalDbgSyms Value="True"/> + </Debugging> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + </Item2> + <Item3 Name="qt5"> + <MacroValues Count="1"> + <Macro2 Name="LCLWidgetType" Value="qt5"/> + </MacroValues> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="testmsgboxes"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf3"/> + <UseExternalDbgSyms Value="True"/> + </Debugging> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + </Item3> + <SharedMatrixOptions Count="2"> + <Item1 ID="457214733240" Modes="gtk3" Type="IDEMacro" MacroName="LCLWidgetType" Value="gtk3"/> + <Item2 ID="686369672140" Modes="qt5" Type="IDEMacro" MacroName="LCLWidgetType" Value="qt5"/> + </SharedMatrixOptions> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="testmsgboxes.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="testmsgboxes"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf3"/> + <UseExternalDbgSyms Value="True"/> + </Debugging> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/examples/messageboxes/testmsgboxes.lpr b/examples/messageboxes/testmsgboxes.lpr new file mode 100644 index 0000000000..9c8c414a58 --- /dev/null +++ b/examples/messageboxes/testmsgboxes.lpr @@ -0,0 +1,23 @@ +program testmsgboxes; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource:=True; + Application.Title:='Test message-boxes'; + Application.Scaled:=True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/examples/messageboxes/unit1.lfm b/examples/messageboxes/unit1.lfm new file mode 100644 index 0000000000..a8434f1a0f --- /dev/null +++ b/examples/messageboxes/unit1.lfm @@ -0,0 +1,266 @@ +object Form1: TForm1 + Left = 781 + Height = 481 + Top = 193 + Width = 585 + BorderStyle = bsDialog + Caption = 'Test for various message-boxes' + ClientHeight = 481 + ClientWidth = 585 + Position = poScreenCenter + LCLVersion = '2.1.0.0' + object EditCaption: TEdit + Left = 104 + Height = 33 + Top = 8 + Width = 472 + TabOrder = 0 + Text = 'StrCaption' + end + object EditMessage: TEdit + Left = 104 + Height = 33 + Top = 40 + Width = 472 + TabOrder = 1 + Text = 'StrMessage' + end + object Label1: TLabel + AnchorSideTop.Control = EditCaption + AnchorSideTop.Side = asrCenter + Left = 8 + Height = 17 + Top = 16 + Width = 57 + Caption = 'Caption:' + ParentColor = False + end + object Label2: TLabel + AnchorSideTop.Control = EditMessage + AnchorSideTop.Side = asrCenter + Left = 8 + Height = 17 + Top = 48 + Width = 63 + Caption = 'Message:' + ParentColor = False + end + object ButtonClose: TButton + AnchorSideRight.Control = Owner + AnchorSideRight.Side = asrBottom + AnchorSideBottom.Control = Owner + AnchorSideBottom.Side = asrBottom + Left = 479 + Height = 33 + Top = 442 + Width = 100 + Anchors = [akRight, akBottom] + AutoSize = True + BorderSpacing.Around = 6 + Caption = 'Close' + Constraints.MinWidth = 100 + OnClick = ButtonCloseClick + TabOrder = 9 + end + object ButtonAppMsgbox: TButton + Left = 152 + Height = 25 + Top = 256 + Width = 264 + Caption = 'Application.MessageBox' + OnClick = ButtonAppMsgboxClick + TabOrder = 5 + end + object GroupBox1: TGroupBox + Left = 8 + Height = 170 + Top = 72 + Width = 217 + Caption = 'Button flags' + ClientHeight = 152 + ClientWidth = 215 + TabOrder = 2 + object CheckFlag_Ok: TRadioButton + Left = 8 + Height = 23 + Top = 0 + Width = 75 + Caption = 'MB_OK' + TabOrder = 3 + end + object CheckFlag_OkCancel: TRadioButton + Left = 8 + Height = 23 + Top = 24 + Width = 130 + Caption = 'MB_OKCANCEL' + Checked = True + TabOrder = 5 + TabStop = True + end + object CheckFlag_YesNo: TRadioButton + Left = 8 + Height = 23 + Top = 48 + Width = 102 + Caption = 'MB_YESNO' + TabOrder = 0 + end + object CheckFlag_YesNoCancel: TRadioButton + Left = 8 + Height = 23 + Top = 72 + Width = 157 + Caption = 'MB_YESNOCANCEL' + TabOrder = 1 + end + object CheckFlag_RetryCancel: TRadioButton + Left = 8 + Height = 23 + Top = 96 + Width = 152 + Caption = 'MB_RETRYCANCEL' + TabOrder = 2 + end + object CheckFlag_AbortRetryIgnore: TRadioButton + Left = 8 + Height = 23 + Top = 120 + Width = 198 + Caption = 'MB_ABORTRETRYIGNORE' + TabOrder = 4 + end + end + object ButtonLCLIntfMsgbox: TButton + Left = 152 + Height = 25 + Top = 288 + Width = 264 + Caption = 'LCLIntf.MessageBox' + OnClick = ButtonLCLIntfMsgboxClick + TabOrder = 6 + end + object GroupBox2: TGroupBox + Left = 232 + Height = 169 + Top = 72 + Width = 225 + Caption = 'Icon flags' + ClientHeight = 151 + ClientWidth = 223 + TabOrder = 3 + object CheckFlag_Info: TRadioButton + Left = 8 + Height = 23 + Top = 0 + Width = 189 + Caption = 'MB_ICONINFORMATION' + Checked = True + TabOrder = 0 + TabStop = True + end + object CheckFlag_Warn: TRadioButton + Left = 8 + Height = 23 + Top = 24 + Width = 158 + Caption = 'MB_ICONWARNING' + TabOrder = 2 + end + object CheckFlag_Error: TRadioButton + Left = 8 + Height = 23 + Top = 48 + Width = 136 + Caption = 'MB_ICONERROR' + TabOrder = 3 + end + object CheckFlag_Ask: TRadioButton + Left = 8 + Height = 23 + Top = 72 + Width = 161 + Caption = 'MB_ICONQUESTION' + TabOrder = 4 + end + object CheckFlag_NoneIcon: TRadioButton + Left = 8 + Height = 23 + Top = 96 + Width = 59 + Caption = 'none' + TabOrder = 1 + end + end + object ButtonMsgDlg: TButton + Left = 152 + Height = 25 + Top = 320 + Width = 264 + Caption = 'MessageDlg' + OnClick = ButtonMsgDlgClick + TabOrder = 7 + end + object GroupBox3: TGroupBox + Left = 463 + Height = 168 + Top = 72 + Width = 113 + Caption = 'Def button' + ClientHeight = 150 + ClientWidth = 111 + TabOrder = 4 + object CheckFlag_B1: TRadioButton + Left = 16 + Height = 23 + Top = 0 + Width = 34 + Caption = '1' + Checked = True + TabOrder = 0 + TabStop = True + end + object CheckFlag_B2: TRadioButton + Left = 16 + Height = 23 + Top = 24 + Width = 34 + Caption = '2' + TabOrder = 1 + end + object CheckFlag_B3: TRadioButton + Left = 16 + Height = 23 + Top = 48 + Width = 34 + Caption = '3' + TabOrder = 2 + end + object CheckFlag_B4: TRadioButton + Left = 16 + Height = 23 + Top = 72 + Width = 34 + Caption = '4' + TabOrder = 3 + end + end + object ButtonPromptUser: TButton + Left = 152 + Height = 25 + Top = 352 + Width = 264 + Caption = 'PromptUser' + OnClick = ButtonPromptUserClick + TabOrder = 8 + end + object ButtonAskUser: TButton + Left = 152 + Height = 25 + Top = 384 + Width = 264 + Caption = 'AskUser (ignore flags)' + OnClick = ButtonAskUserClick + TabOrder = 10 + end +end diff --git a/examples/messageboxes/unit1.pas b/examples/messageboxes/unit1.pas new file mode 100644 index 0000000000..14ed5994d7 --- /dev/null +++ b/examples/messageboxes/unit1.pas @@ -0,0 +1,381 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls; + +type + TIntArray = array of Longint; + +type + + { TForm1 } + + TForm1 = class(TForm) + ButtonAskUser: TButton; + ButtonPromptUser: TButton; + ButtonAppMsgbox: TButton; + ButtonLCLIntfMsgbox: TButton; + ButtonMsgDlg: TButton; + CheckFlag_AbortRetryIgnore: TRadioButton; + CheckFlag_Ok: TRadioButton; + CheckFlag_OkCancel: TRadioButton; + CheckFlag_RetryCancel: TRadioButton; + CheckFlag_YesNo: TRadioButton; + CheckFlag_YesNoCancel: TRadioButton; + EditCaption: TEdit; + EditMessage: TEdit; + GroupBox1: TGroupBox; + GroupBox2: TGroupBox; + GroupBox3: TGroupBox; + Label1: TLabel; + Label2: TLabel; + ButtonClose: TButton; + CheckFlag_Info: TRadioButton; + CheckFlag_Warn: TRadioButton; + CheckFlag_Error: TRadioButton; + CheckFlag_Ask: TRadioButton; + CheckFlag_NoneIcon: TRadioButton; + CheckFlag_B1: TRadioButton; + CheckFlag_B2: TRadioButton; + CheckFlag_B3: TRadioButton; + CheckFlag_B4: TRadioButton; + procedure ButtonAppMsgboxClick(Sender: TObject); + procedure ButtonAskUserClick(Sender: TObject); + procedure ButtonCloseClick(Sender: TObject); + procedure ButtonLCLIntfMsgboxClick(Sender: TObject); + procedure ButtonMsgDlgClick(Sender: TObject); + procedure ButtonPromptUserClick(Sender: TObject); + private + function GetMsgFlags: integer; + function GetDlgType: TMsgDlgType; + function GetDlgButtons: TMsgDlgButtons; + function GetDlgTypeInt: integer; + function GetBtnArray: TIntArray; + function ButtonIdToString(N: integer): string; + function ButtonAltIdToString(N: integer): string; + + public + + end; + +var + Form1: TForm1; + +implementation + +uses + LCLType, LCLProc, LCLIntf, InterfaceBase, System.UITypes; + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.ButtonCloseClick(Sender: TObject); +begin + Close; +end; + +function TForm1.GetMsgFlags: integer; +begin + Result:= 0; + + if CheckFlag_Ok.Checked then + Result:= MB_OK + else + if CheckFlag_OkCancel.Checked then + Result:= MB_OKCANCEL + else + if CheckFlag_YesNo.Checked then + Result:= MB_YESNO + else + if CheckFlag_YesNoCancel.Checked then + Result:= MB_YESNOCANCEL + else + if CheckFlag_RetryCancel.Checked then + Result:= MB_RETRYCANCEL + else + if CheckFlag_AbortRetryIgnore.Checked then + Result:= MB_ABORTRETRYIGNORE; + + if CheckFlag_Info.Checked then + Inc(Result, MB_ICONINFORMATION) + else + if CheckFlag_Warn.Checked then + Inc(Result, MB_ICONWARNING) + else + if CheckFlag_Error.Checked then + Inc(Result, MB_ICONERROR) + else + if CheckFlag_Ask.Checked then + Inc(Result, MB_ICONQUESTION); + + if CheckFlag_B1.Checked then + Inc(Result, MB_DEFBUTTON1) + else + if CheckFlag_B2.Checked then + Inc(Result, MB_DEFBUTTON2) + else + if CheckFlag_B3.Checked then + Inc(Result, MB_DEFBUTTON3) + else + if CheckFlag_B4.Checked then + Inc(Result, MB_DEFBUTTON4); +end; + +function TForm1.GetDlgType: TMsgDlgType; +begin + if CheckFlag_Info.Checked then + Result:= mtInformation + else + if CheckFlag_Warn.Checked then + Result:= mtWarning + else + if CheckFlag_Error.Checked then + Result:= mtError + else + if CheckFlag_Ask.Checked then + Result:= mtConfirmation + else + Result:= mtCustom; +end; + +function TForm1.GetDlgButtons: TMsgDlgButtons; +begin + if CheckFlag_Ok.Checked then + Result:= [mbOk] + else + if CheckFlag_OkCancel.Checked then + Result:= mbOKCancel + else + if CheckFlag_YesNo.Checked then + Result:= mbYesNo + else + if CheckFlag_YesNoCancel.Checked then + Result:= mbYesNoCancel + else + if CheckFlag_RetryCancel.Checked then + Result:= [mbRetry, mbCancel] + else + if CheckFlag_AbortRetryIgnore.Checked then + Result:= mbAbortRetryIgnore + else + Result:= [mbOk]; +end; + +function TForm1.GetDlgTypeInt: integer; +begin + if CheckFlag_Info.Checked then + Result:= idDialogInfo + else + if CheckFlag_Warn.Checked then + Result:= idDialogWarning + else + if CheckFlag_Error.Checked then + Result:= idDialogError + else + if CheckFlag_Ask.Checked then + Result:= idDialogConfirm + else + Result:= 0; +end; + +function TForm1.GetBtnArray: TIntArray; +begin + SetLength(Result, 0); + if CheckFlag_Ok.Checked then + begin + SetLength(Result, 1); + Result[0]:= idButtonOk; + end + else + if CheckFlag_OkCancel.Checked then + begin + SetLength(Result, 2); + Result[0]:= idButtonOk; + Result[1]:= idButtonCancel; + end + else + if CheckFlag_YesNo.Checked then + begin + SetLength(Result, 2); + Result[0]:= idButtonYes; + Result[1]:= idButtonNo; + end + else + if CheckFlag_YesNoCancel.Checked then + begin + SetLength(Result, 3); + Result[0]:= idButtonYes; + Result[1]:= idButtonNo; + Result[2]:= idButtonCancel; + end + else + if CheckFlag_RetryCancel.Checked then + begin + SetLength(Result, 2); + Result[0]:= idButtonRetry; + Result[1]:= idButtonCancel; + end + else + if CheckFlag_AbortRetryIgnore.Checked then + begin + SetLength(Result, 3); + Result[0]:= idButtonAbort; + Result[1]:= idButtonRetry; + Result[2]:= idButtonIgnore; + end; +end; + +function TForm1.ButtonIdToString(N: integer): string; +begin + case N of + ID_OK: Result:= 'ID_OK'; + ID_CANCEL: Result:= 'ID_CANCEL'; + ID_YES: Result:= 'ID_YES'; + ID_NO: Result:= 'ID_NO'; + ID_RETRY: Result:= 'ID_RETRY'; + ID_IGNORE: Result:= 'ID_IGNORE'; + ID_ABORT: Result:= 'ID_ABORT'; + ID_CLOSE: Result:= 'ID_CLOSE'; + ID_HELP: Result:= 'ID_HELP'; + else Result:= IntToStr(N); + end; +end; + +function TForm1.ButtonAltIdToString(N: integer): string; +begin + case N of + idButtonOk: Result:= 'idButtonOk'; + idButtonCancel: Result:= 'idButtonCancel'; + idButtonYes: Result:= 'idButtonYes'; + idButtonNo: Result:= 'idButtonNo'; + idButtonRetry: Result:= 'idButtonRetry'; + idButtonIgnore: Result:= 'idButtonIgnore'; + idButtonAbort: Result:= 'idButtonAbort'; + idButtonClose: Result:= 'idButtonClose'; + idButtonHelp: Result:= 'idButtonHelp'; + else Result:= IntToStr(N); + end; +end; + +procedure TForm1.ButtonAppMsgboxClick(Sender: TObject); +var + N: integer; +begin + N:= Application.MessageBox( + PChar(EditMessage.Text), + PChar(EditCaption.Text), + GetMsgFlags); + Caption:= 'Application.MessageBox() returned '+ButtonIdToString(N); +end; + +procedure TForm1.ButtonAskUserClick(Sender: TObject); +var + Buttons: TDialogButtons; + N: integer; + NDef: integer; +begin + NDef:= -1; + if CheckFlag_B1.Checked then + NDef:= 0 + else + if CheckFlag_B2.Checked then + NDef:= 1 + else + if CheckFlag_B3.Checked then + NDef:= 2 + else + if CheckFlag_B4.Checked then + NDef:= 3; + + Buttons:= TDialogButtons.Create(TDialogButton); + with Buttons.Add do + begin + Caption:= '<ok>'; + ModalResult:= mrOk; + end; + with Buttons.Add do + begin + Caption:= '<cancel>'; + ModalResult:= mrCancel; + end; + with Buttons.Add do + begin + Caption:= '<yes>'; + ModalResult:= mrYes; + end; + with Buttons.Add do + begin + Caption:= '<no>'; + ModalResult:= mrNo; + end; + with Buttons.Add do + begin + Caption:= '<ignore>'; + ModalResult:= mrIgnore; + end; + + if (NDef>=0) and (NDef<Buttons.Count) then + Buttons.DefaultButton:= Buttons[NDef]; + + N:= AskUser( + EditCaption.Text, + EditMessage.Text, + GetDlgTypeInt, + Buttons, + 0); + FreeAndNil(Buttons); + + Caption:= 'AskUser() returned '+ButtonIdToString(N); +end; + +procedure TForm1.ButtonLCLIntfMsgboxClick(Sender: TObject); +var + N: integer; +begin + N:= LCLIntf.MessageBox(Handle, + PChar(EditMessage.Text), + PChar(EditCaption.Text), + GetMsgFlags + ); + Caption:= 'LCLIntf.MessageBox() returned '+ButtonIdToString(N); +end; + +procedure TForm1.ButtonMsgDlgClick(Sender: TObject); +var + Res: TModalResult; +begin + Res:= MessageDlg( + EditCaption.Text, + EditMessage.Text, + GetDlgType, + GetDlgButtons, + 0); + Caption:= 'MessageDlg() returned '+ModalResultStr[Res]; +end; + +procedure TForm1.ButtonPromptUserClick(Sender: TObject); +var + Btn: array of Longint; + N: integer; +begin + Btn:= GetBtnArray; + if Length(Btn)=0 then exit; + + N:= PromptUser( + EditCaption.Text, + EditMessage.Text, + GetDlgTypeInt, + @Btn[0], + Length(Btn), + 0, + 0); + Caption:= 'PromptUser() returned '+ButtonAltIdToString(N); +end; + +end. +