paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-20 18:22:44 +02:00
Code Issues Packages Projects Releases Wiki Activity
dbcda8ed24
lazarus/lcl/dialogs.pp
lazarus 64182d6814 AJ: Moved form contents creation to gtkproc for code 
reuse between GNOME and GTK, and to make GNOME MDI
    programming easier later on.

git-svn-id: trunk@3561 -
2002-10-25 15:27:02 +00:00

524 lines
18 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
dialogs.pp
----------
Component Library Standard dialogs Controls
***************************************************************************/
*****************************************************************************
* *
* 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. *
* *
*****************************************************************************
}
{
@author(TMyClass - Michael A. Hess <author@emailaddress.com>)
@author(TMyOtherClass - Other Author Name <otherauthor@emailaddress.com>)
@created()
@lastmod()
Detailed description of the Unit.
}
unit Dialogs;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCLlinux, FileCtrl, LCLStrConsts, LCLType, VCLGlobals,
LMessages, Forms, Controls, GraphType, Graphics, Buttons, StdCtrls;
//type
// TDialogButtons = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry,
// mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp);
// TDialogButtonsSet = set of TDialogButtons;
type
TMsgDlgType = (mtWarning, mtError, mtInformation, mtConfirmation,
mtCustom);
TMsgDlgBtn = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore,
mbAll, mbNoToAll, mbYesToAll, mbHelp);
TMsgDlgButtons = set of TMsgDlgBtn;
const
mbYesNoCancel = [mbYes, mbNo, mbCancel];
mbOKCancel = [mbOK, mbCancel];
mbAbortRetryIgnore = [mbAbort, mbRetry, mbIgnore];
type
{ TCommonDialog }
TCommonDialog = class(TComponent)
private
FHandle : integer;
FHeight: integer;
FWidth: integer;
FOnCanClose: TCloseQueryEvent;
FOnShow, FOnClose : TNotifyEvent;
FTitle : string;
FUserChoice: integer;
FHelpContext: THelpContext;
procedure SetHandle(const AValue: integer);
protected
function DoExecute : boolean; virtual;
public
FCompStyle : LongInt;
constructor Create (AOwner : TComponent); override;
function Execute : boolean; virtual;
property Handle : integer read FHandle write SetHandle;
property Title : string read FTitle write FTitle;
property UserChoice : integer read FUserChoice write FUserChoice;
procedure Close;
published
property OnClose : TNotifyEvent read FOnClose write FOnClose;
property OnCanClose: TCloseQueryEvent read FOnCanClose write FOnCanClose;
property OnShow : TNotifyEvent read FOnShow write FOnShow;
property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
property Width: integer read FWidth write FWidth;
property Height: integer read FHeight write FHeight;
end;
{ TFileDialog }
TFileDialog = class(TCommonDialog)
private
FDefaultExt: string;
FFileName : String;
FFiles: TStrings;
FFilter: String;
FFilterIndex: Integer;
FHistoryList: TStrings;
FInitialDir: string;
FOldWorkingDir: string;
FOnHelpClicked: TNotifyEvent;
procedure SetDefaultExt(const AValue: string);
protected
function DoExecute : boolean; override;
procedure SetFileName(value :String); virtual;
procedure SetFilter(value :String); virtual;
procedure SetHistoryList(const AValue: TStrings); virtual;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
function Execute : boolean; override;
property Files: TStrings read FFiles;
property HistoryList: TStrings read FHistoryList write SetHistoryList;
published
property DefaultExt: string read FDefaultExt write SetDefaultExt;
property FileName : String read FFileName write SetFileName;
property Filter : String read FFilter write SetFilter;
property FilterIndex: Integer read FFilterIndex write FFilterIndex default 1;
property InitialDir: string read FInitialDir write FInitialDir;
property OnHelpClicked: TNotifyEvent read FOnHelpClicked write FOnHelpClicked;
end;
{ TOpenDialog }
TOpenOption = (
ofReadOnly,
ofOverwritePrompt, // tests if secected file exists and if so shows a
// message, to inform the user, that file will be
// overwritten
ofHideReadOnly,
ofNoChangeDir, // do not change current directory
ofShowHelp, // show a help button
ofNoValidate,
ofAllowMultiSelect,// allow multiselection
ofExtensionDifferent,
ofPathMustExist, // shows an error message if selected path does not exist
ofFileMustExist, // shows an error message if selected file does not exist
ofCreatePrompt,
ofShareAware,
ofNoReadOnlyReturn,// do not return filenames that are readonly
ofNoTestFileCreate,
ofNoNetworkButton,
ofNoLongNames,
ofOldStyleDialog,
ofNoDereferenceLinks,// do not expand filenames
ofEnableIncludeNotify,
ofEnableSizing, // dialog can be resized, e.g. via the mouse
ofDontAddToRecent, // do not add the path to the history list
ofForceShowHidden, // includes in display files marked as hidden
ofViewDetail // details are OS and interface dependent
);
TOpenOptions = set of TOpenOption;
TOpenDialog = class(TFileDialog)
private
FOnFolderChange: TNotifyEvent;
FOnSelectionChange: TNotifyEvent;
FOptions: TOpenOptions;
protected
function DoExecute: boolean; override;
public
constructor Create(AOwner: TComponent); override;
published
property Options: TOpenOptions read FOptions write FOptions
default [ofEnableSizing, ofViewDetail];
property OnFolderChange: TNotifyEvent read FOnFolderChange write FOnFolderChange;
property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;
end;
{ TSaveDialog }
TSaveDialog = class(TOpenDialog)
public
constructor Create(AOwner : TComponent); override;
end;
{ TColorDialog }
TColorDialog = class(TCommonDialog)
private
FColor : TColor;
public
constructor Create (AOwner : TComponent); override;
published
property Color : TColor read FColor write FColor;
end;
{ TFontDialog }
TFontDialogOption = (fdAnsiOnly, fdTrueTypeOnly, fdEffects,
fdFixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts,
fdNoSimulations, fdNoSizeSel, fdNoStyleSel, fdNoVectorFonts,
fdShowHelp, fdWysiwyg, fdLimitSize, fdScalableOnly, fdApplyButton);
TFontDialogOptions = set of TFontDialogOption;
TFontDialog = class(TCommonDialog)
private
FFont: TFont;
FMaxFontSize: Integer;
FMinFontSize: Integer;
FOnApplyClicked: TNotifyEvent;
FOptions: TFontDialogOptions;
FPreviewText: string;
procedure SetFont(const AValue: TFont);
public
procedure ApplyClicked; virtual;
constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
published
property Font: TFont read FFont write SetFont;
property MinFontSize: Integer read FMinFontSize write FMinFontSize;
property MaxFontSize: Integer read FMaxFontSize write FMaxFontSize;
property Options: TFontDialogOptions
read FOptions write FOptions default [fdEffects];
property OnApplyClicked: TNotifyEvent
read FOnApplyClicked write FOnApplyClicked;
property PreviewText: string read FPreviewText write FPreviewText;
end;
{ MessageDlg }
function MessageDlg(const aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
function MessageDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
function MessageDlgPos(const aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;
function MessageDlgPosHelp(const aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
const HelpFileName: string): Integer;
procedure ShowMessage(const aMsg: string);
procedure ShowMessageFmt(const aMsg: string; Params: array of const);
procedure ShowMessagePos(const aMsg: string; X, Y: Integer);
Function InputQuery(const ACaption, APrompt : String; MaskInput : Boolean; var Value : String) : Boolean;
Function InputQuery(const ACaption, APrompt : String; var Value : String) : Boolean;
Function InputBox(const ACaption, APrompt, ADefault : String) : String;
Function PasswordBox(const ACaption, APrompt : String) : String;
implementation
uses
InterfaceBase;
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
cLabelSpacing = 10; // distance between icon & label
function ShowMessageBox(Text, Caption : PChar; Flags : Longint) : Integer;
var
DlgType : TMsgDlgType;
Buttons : TMsgDlgButtons;
begin
//This uses TMessageBox class in MessageDialogs.inc
if (Flags and MB_RETRYCANCEL) = MB_RETRYCANCEL then
Buttons := [mbREtry, mbCancel]
else
if (Flags and MB_YESNO) = MB_YESNO then
Buttons := [mbYes, mbNo]
else
if (Flags and MB_YESNOCANCEL) = MB_YESNOCANCEL then
Buttons := [mbYes, mbNo, mbCancel]
else
if (Flags and MB_ABORTRETRYIGNORE) = MB_ABORTRETRYIGNORE then
Buttons := [mbAbort, mbRetry, mbIgnore]
else
if (Flags and MB_OKCANCEL) = MB_OKCANCEL then
Buttons := [mbOK,mbCancel]
else
if (Flags and MB_OK) = MB_OK then
Buttons := [mbOK]
else
Buttons := [mbOK];
if (Flags and MB_ICONQUESTION) = MB_ICONQUESTION then
DlgTYpe := mtConfirmation
else
if (Flags and MB_ICONINFORMATION) = MB_ICONINFORMATION then
DlgTYpe := mtInformation
else
if (Flags and MB_ICONERROR) = MB_ICONERROR then
DlgTYpe := mtError
else
if (Flags and MB_ICONWARNING) = MB_ICONWARNING then
DlgTYpe := mtWarning
else
DlgTYpe := mtCustom;
Result := MessageDlg(Caption,Text,DlgType,Buttons,0);
end;
{$I colordialog.inc}
{$I commondialog.inc}
{$I filedialog.inc}
{$I fontdialog.inc}
{$I inputdialog.inc}
{$I messagedialogs.inc}
{$I promptdialog.inc}
initialization
Forms.MessageBoxFunction:=@ShowMessageBox;
InterfaceBase.InputDialogFunction:=@ShowInputDialog;
InterfaceBase.PromptDialogFunction:=@ShowPromptDialog;
finalization
end.
{ =============================================================================
$Log$
Revision 1.26 2002/10/25 15:27:02 lazarus
AJ: Moved form contents creation to gtkproc for code
reuse between GNOME and GTK, and to make GNOME MDI
programming easier later on.
Revision 1.25 2002/10/25 14:59:11 lazarus
AJ: MessageDlgs -> PromptUser, better Cancel/Default order
Revision 1.24 2002/10/25 10:06:34 lazarus
MG: broke interfacebase uses circles
Revision 1.23 2002/10/25 09:47:37 lazarus
MG: added inputdialog.inc
Revision 1.22 2002/10/24 10:37:04 lazarus
MG: broke dialogs.pp <-> forms.pp circle
Revision 1.21 2002/10/24 10:05:51 lazarus
MG: broke graphics.pp <-> clipbrd.pp circle
Revision 1.20 2002/10/11 16:00:39 lazarus
AJ: made InputQuery Interface Dependant
Revision 1.19 2002/10/10 13:29:08 lazarus
AJ: added LoadStockPixmap routine & minor fixes to/for GNOMEInt
Revision 1.18 2002/09/27 20:52:21 lazarus
MWE: Applied patch from "Andrew Johnson" <aj_genius@hotmail.com>
Here is the run down of what it includes -
-Vasily Volchenko's Updated Russian Localizations
-improvements to GTK Styles/SysColors
-initial GTK Palette code - (untested, and for now useless)
-Hint Windows and Modal dialogs now try to stay transient to
the main program form, aka they stay on top of the main form
and usually minimize/maximize with it.
-fixes to Form BorderStyle code(tool windows needed a border)
-fixes DrawFrameControl DFCS_BUTTONPUSH to match Win32 better
when flat
-fixes DrawFrameControl DFCS_BUTTONCHECK to match Win32 better
and to match GTK theme better. It works most of the time now,
but some themes, noteably Default, don't work.
-fixes bug in Bitmap code which broke compiling in NoGDKPixbuf
mode.
-misc other cleanups/ fixes in gtk interface
-speedbutton's should now draw correctly when flat in Win32
-I have included an experimental new CheckBox(disabled by
default) which has initial support for cbGrayed(Tri-State),
and WordWrap, and misc other improvements. It is not done, it
is mostly a quick hack to test DrawFrameControl
DFCS_BUTTONCHECK, however it offers many improvements which
can be seen in cbsCheck/cbsCrissCross (aka non-themed) state.
-fixes Message Dialogs to more accurately determine
button Spacing/Size, and Label Spacing/Size based on current
System font.
-fixes MessageDlgPos, & ShowMessagePos in Dialogs
-adds InputQuery & InputBox to Dialogs
-re-arranges & somewhat re-designs Control Tabbing, it now
partially works - wrapping around doesn't work, and
subcontrols(Panels & Children, etc) don't work. TabOrder now
works to an extent. I am not sure what is wrong with my code,
based on my other tests at least wrapping and TabOrder SHOULD
work properly, but.. Anyone want to try and fix?
-SynEdit(Code Editor) now changes mouse cursor to match
position(aka over scrollbar/gutter vs over text edit)
-adds a TRegion property to Graphics.pp, and Canvas. Once I
figure out how to handle complex regions(aka polygons) data
properly I will add Region functions to the canvas itself
(SetClipRect, intersectClipRect etc.)
-BitBtn now has a Stored flag on Glyph so it doesn't store to
lfm/lrs if Glyph is Empty, or if Glyph is not bkCustom(aka
bkOk, bkCancel, etc.) This should fix most crashes with older
GDKPixbuf libs.
Revision 1.17 2002/08/06 09:32:48 lazarus
MG: moved TColor definition to graphtype.pp and registered TColor names
Revision 1.16 2002/07/29 13:39:06 lazarus
MG: removed ambigious TBitmap from LCLType and added Escape key to MessageDlgs
Revision 1.15 2002/07/04 11:46:00 lazarus
MG: moved resourcestring to lclstrconsts.pas
Revision 1.14 2002/06/04 15:17:21 lazarus
MG: improved TFont for XLFD font names
Revision 1.13 2002/05/30 14:11:11 lazarus
MG: added filters and history to TOpenDialog
Revision 1.12 2002/05/29 21:44:37 lazarus
MG: improved TCommon/File/OpenDialog, fixed TListView scrolling and broder
Revision 1.11 2002/05/10 06:05:49 lazarus
MG: changed license to LGPL
Revision 1.10 2002/01/25 19:42:56 lazarus
Keith: Improved events and common dialogs on Win32
Revision 1.9 2001/12/11 14:36:41 lazarus
MG: started multiselection for TOpenDialog
Revision 1.8 2001/11/01 18:48:51 lazarus
Changed Application.Messagebox to use TMessageBox class.
Added icon images for mtError and mtConfirmation
Shane
Revision 1.7 2001/07/31 18:40:24 lazarus
MG: added unit info, arrow xpms, and many changes from jens arm
Revision 1.6 2001/06/06 12:30:41 lazarus
MG: bugfixes
Revision 1.5 2001/03/27 11:11:13 lazarus
MG: fixed mouse msg, added filedialog initialdir
Revision 1.4 2001/03/03 00:48:03 lazarus
+ added support for message dialogs
stoppok
Revision 1.3 2000/08/10 10:55:45 lazarus
Changed TCustomDialog to TCommonDialog
Shane
Revision 1.2 2000/08/09 18:32:10 lazarus
Added more code for the find function.
Shane
Revision 1.1 2000/07/13 10:28:23 michael
+ Initial import
Revision 1.10 2000/02/28 19:16:04 lazarus
Added code to the FILE CLOSE to check if the file was modified. HAven't gotten the application.messagebox working yet though. It won't stay visible.
Shane
Revision 1.9 2000/02/22 22:19:49 lazarus
TCustomDialog is a descendant of TComponent.
Initial cuts a form's proper Close behaviour.
Revision 1.8 2000/02/22 17:32:49 lazarus
Modified the ShowModal call.
For TCustomForm is simply sets the visible to true now and adds fsModal to FFormState. In gtkObject.inc FFormState is checked. If it contains fsModal then either gtk_grab_add or gtk_grab_remove is called depending on the value of VISIBLE.
The same goes for TCustomDialog (open, save, font, color).
I moved the Execute out of the individual dialogs and moved it into TCustomDialog and made it virtual because FONT needs to set some stuff before calling the inherited execute.
Shane
Revision 1.7 1999/12/10 00:47:01 lazarus
MWE:
Fixed some samples
Fixed Dialog parent is no longer needed
Fixed (Win)Control Destruction
Fixed MenuClick
Revision 1.6 1999/09/15 02:14:44 lazarus
*** empty log message ***
Revision 1.5 1999/08/16 18:45:38 lazarus
Added a TFont Dialog plus minor additions.
Shane Aug 16th 1999 14:07 CST
Revision 1.4 1999/07/31 06:39:21 lazarus
Modified the IntSendMessage3 to include a data variable. It isn't used
yet but will help in merging the Message2 and Message3 features.
Adjusted TColor routines to match Delphi color format
Added a TGdkColorToTColor routine in gtkproc.inc
Finished the TColorDialog added to comDialog example. MAH
}
Reference in New Issue View Git Blame Copy Permalink