paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 03:28:04 +02:00
Code Issues Packages Projects Releases Wiki Activity
main
lazarus/lcl/editbtn.pas

2567 lines
69 KiB
ObjectPascal
Raw Permalink Blame History

{
***************************************************************************
editbtn.pas
-----------
Component Library Extended dialogs Controls
***************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* See the file COPYING.modifiedLGPL.txt, 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. *
* *
*****************************************************************************
}
unit EditBtn;
{$mode objfpc}{$H+}
{$I lcl_defines.inc}
interface
uses
Classes, SysUtils, Types, Math, StrUtils, DateUtils,
LazFileUtils, LazUTF8,
LResources, LCLStrConsts, LCLType, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, Calendar, ExtDlgs, GroupedEdit, CalendarPopup,
MaskEdit, Menus, TimePopup, CalcForm, ImgList;
const
NullDate: TDateTime = 29584650.5 {appr 10 x MaxDateTime};
//Note: if you change this value to be in the range of allowed dates
//you will be unable to select that date from the calendar, so better not do that
//In hindside this vale should have been declared as a non-writeable constant
NullTime: TDateTime = 0;
type
{ TEbEdit }
TEbEdit = class(TGEEdit)
protected
procedure DoEnter; override;
procedure DoExit; override;
end;
TEditSpeedButton = class(TSpeedButton)
protected
procedure GlyphChanged(Sender: TObject); override;
end;
{ TCustomEditButton }
TCustomEditButton = class(TCustomAbstractGroupedEdit)
private
FButtonOnlyWhenFocused: Boolean;
FFlat: Boolean;
//Forwarded events from Button
//Forwarded events from Edit
function GetFocusOnButtonClick: Boolean;
function GetOnButtonClick: TNotifyEvent;
function GetButton: TSpeedButton;
function GetGlyph: TBitmap;
function GetNumGlyps: Integer;
function GetEdit: TEbEdit;
procedure SetFocusOnButtonClick(AValue: Boolean);
procedure SetOnButtonClick(AValue: TNotifyEvent);
procedure SetButtonOnlyWhenFocused(AValue: Boolean);
procedure SetFlat(AValue: Boolean);
procedure SetGlyph(AValue: TBitmap);
procedure SetNumGlyphs(AValue: Integer);
function GetImages: TCustomImageList;
procedure SetImages(const aImages: TCustomImageList);
function GetImageIndex: TImageIndex;
procedure SetImageIndex(const aImageIndex: TImageIndex);
function GetImageWidth: Integer;
procedure SetImageWidth(const aImageWidth: Integer);
protected
procedure ButtonClick; virtual;
procedure BuddyClick; override;
function GetEditorClassType: TGEEditClass; override;
function GetBuddyClassType: TControlClass; override;
class function GetControlClassDefaultSize: TSize; override;
function CalcButtonVisible: Boolean; virtual;
function GetDefaultGlyphName: string; virtual;
procedure CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer;
WithThemeSpace: Boolean); override;
procedure CheckButtonVisible;
procedure LoadDefaultGlyph;
procedure GlyphChanged(Sender: TObject); virtual;
property Button: TSpeedButton read GetButton;
property ButtonCaption: TCaption read GetBuddyCaption write SetBuddyCaption;
property ButtonCursor: TCursor read GetBuddyCursor write SetBuddyCursor default crDefault;
property ButtonHint: TTranslateString read GetBuddyHint write SetBuddyHint;
property ButtonOnlyWhenFocused: Boolean read FButtonOnlyWhenFocused write SetButtonOnlyWhenFocused default False;
property ButtonWidth: Integer read GetBuddyWidth write SetBuddyWidth;
property Edit: TEbEdit read GetEdit;
property Flat: Boolean read FFlat write SetFlat default False;
property FocusOnButtonClick: Boolean read GetFocusOnButtonClick write SetFocusOnButtonClick default False;
property Glyph: TBitmap read GetGlyph write SetGlyph;
property NumGlyphs: Integer read GetNumGlyps write SetNumGlyphs;
property Images: TCustomImageList read GetImages write SetImages;
property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex default -1;
property ImageWidth: Integer read GetImageWidth write SetImageWidth default 0;
property Spacing default 4;
property OnButtonClick: TNotifyEvent read GetOnButtonClick write SetOnButtonClick;
public
constructor Create(AOwner: TComponent); override;
end;
{ TEditButton }
TEditButton = class(TCustomEditButton)
public
property AutoSelected;
property Button;
property Edit;
published
property NumbersOnly;
property Action;
property AutoSelect;
property AutoSize default True;
property Align;
property Alignment;
property Anchors;
property BiDiMode;
property BorderSpacing;
property BorderStyle default bsNone;
property ButtonCaption;
property ButtonCursor;
property ButtonHint;
property ButtonOnlyWhenFocused;
property ButtonWidth;
property CharCase;
property Color;
property Constraints;
property Cursor;
property DirectInput;
property EchoMode;
property Enabled;
property Flat;
property FocusOnButtonClick;
property Font;
property Glyph;
// property HideSelection;
property Hint;
property Images;
property ImageIndex;
property ImageWidth;
property Layout;
property MaxLength;
property NumGlyphs;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PasswordChar;
property PopupMenu;
property ReadOnly;
property ShowHint;
property Spacing;
property TabOrder;
property TabStop;
property Text;
property TextHint;
property Visible;
property OnButtonClick;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnContextPopup;
property OnEditingDone;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnStartDrag;
property OnUTF8KeyPress;
end;
TFilterStringOption = (fsoCaseSensitive, fsoMatchOnlyAtStart);
TFilterStringOptions = set of TFilterStringOption;
// Called when an item is filtered. Returns true if the item passes the filter.
// Done=False means the data should also be filtered by its title string.
// Done=True means no other filtering is needed.
TFilterItemEvent = function (ItemData: Pointer; out Done: Boolean): Boolean of object;
TFilterItemExEvent = function (const ACaption: string; ItemData: Pointer;
out Done: Boolean): Boolean of object;
// Can be used only for items that have a checkbox. Returns true if checked.
TCheckItemEvent = function (Item: TObject): Boolean of object;
{ TCustomControlFilterEdit }
// An abstract base class for edit controls which filter data in
// visual controls like TListView and TTreeView.
TCustomControlFilterEdit = class(TCustomEditButton)
private
fFilter: string;
fFilterLowercase: string;
fFilterOptions: TFilterStringOptions;
fIdleConnected: Boolean;
fSortData: Boolean; // Data needs to be sorted.
fIsFirstSetFormActivate: Boolean;
fOnAfterFilter: TNotifyEvent;
procedure SetFilter(AValue: string);
procedure SetFilterOptions(AValue: TFilterStringOptions);
procedure SetSortData(AValue: Boolean);
procedure SetIdleConnected(const AValue: Boolean);
procedure OnAsync(Data: PtrInt);
function IsTextHintStored: Boolean;
protected
fAlreadyFiltered: Boolean;
fIsFirstUpdate: Boolean;
fNeedFiltering, fNeedButtonEnabled: Boolean;
fSelectedPart: TObject; // Select this node on next update
fOnFilterItem: TFilterItemEvent;
fOnFilterItemEx: TFilterItemExEvent;
fOnCheckItem: TCheckItemEvent;
procedure DestroyWnd; override;
procedure InternalSetFilter(const AValue: string);
function DoDefaultFilterItem(const ACaption: string;
const ItemData: Pointer): Boolean; virtual;
function DoFilterItem(const ACaption: string;
ItemData: Pointer): Boolean; virtual;
procedure EditKeyDown(var Key: Word; Shift: TShiftState); override;
procedure EditChange; override;
procedure BuddyClick; override;
procedure SortAndFilter; virtual; abstract;
procedure ApplyFilterCore; virtual; abstract;
procedure ApplyFilter(Immediately: Boolean = False);
procedure MoveNext(ASelect: Boolean = False); virtual; abstract;
procedure MovePrev(ASelect: Boolean = False); virtual; abstract;
procedure MovePageUp(ASelect: Boolean = False); virtual; abstract;
procedure MovePageDown(ASelect: Boolean = False); virtual; abstract;
procedure MoveHome(ASelect: Boolean = False); virtual; abstract;
procedure MoveEnd(ASelect: Boolean = False); virtual; abstract;
function ReturnKeyHandled: Boolean; virtual; abstract;
function GetDefaultGlyphName: string; override;
class procedure WSRegisterClass; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure InvalidateFilter;
procedure ResetFilter;
function ForceFilter(AFilter: String) : String;
procedure StoreSelection; virtual; abstract;
procedure RestoreSelection; virtual; abstract;
public
property Filter: string read fFilter write SetFilter;
property FilterLowercase: string read fFilterLowercase;
property IdleConnected: Boolean read fIdleConnected write SetIdleConnected;
property SortData: Boolean read fSortData write SetSortData;
property SelectedPart: TObject read fSelectedPart write fSelectedPart;
published
property CharCase default ecLowerCase;
property FilterOptions: TFilterStringOptions read fFilterOptions write SetFilterOptions default [];
property OnAfterFilter: TNotifyEvent read fOnAfterFilter write fOnAfterFilter;
property OnFilterItem: TFilterItemEvent read fOnFilterItem write fOnFilterItem;
deprecated 'Use OnFilterItemEx with a caption parameter instead.';
property OnFilterItemEx: TFilterItemExEvent read fOnFilterItemEx write fOnFilterItemEx;
property OnCheckItem: TCheckItemEvent read fOnCheckItem write fOnCheckItem;
// TEditButton properties.
property ButtonCaption;
property ButtonCursor;
property ButtonHint;
property ButtonOnlyWhenFocused;
property ButtonWidth;
property Constraints;
property DirectInput;
property Flat;
property FocusOnButtonClick;
// Other properties
property Align;
property Alignment;
property Anchors;
property BidiMode;
property BorderSpacing;
property BorderStyle;
property AutoSize;
property AutoSelect;
property Color;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property Glyph;
property NumGlyphs;
property Images;
property ImageIndex;
property ImageWidth;
property Layout;
property MaxLength;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property Spacing;
property TabOrder;
property TabStop;
property Text;
property TextHint stored IsTextHintStored;
property Visible;
property OnButtonClick;
property OnChange;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEditingDone;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnStartDrag;
property OnUTF8KeyPress;
end;
{ TFileNameEdit }
TAcceptFileNameEvent = procedure (Sender : TObject; Var Value : String) of Object;
TDialogKind = (dkOpen,dkSave,dkPictureOpen,dkPictureSave);
TFileNameEdit = class(TCustomEditButton)
private
FDialogOptions: TOpenOptions;
FFileName : String;
FDialogFiles : TStrings;
FDialogKind: TDialogKind;
FDialogTitle: String;
FFilter: String;
FFilterIndex: Integer;
FDefaultExt: String;
FHideDirectories: Boolean;
FInitialDir: String;
FOnAcceptFileName: TAcceptFileNameEvent;
FOnFolderChange: TNotifyEvent;
FFileNameChangeLock: Integer;
procedure SetFileName(const AValue: String);
protected
function GetDefaultGlyphName: string; override;
function CreateDialog(AKind: TDialogKind): TCommonDialog; virtual;
procedure SaveDialogResult(AKind: TDialogKind; D: TCommonDialog); virtual;
procedure ButtonClick; override;
procedure EditChange; override;
procedure DoFolderChange(Sender:TObject); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure RunDialog; virtual;
property AutoSelected;
property DialogFiles: TStrings read FDialogFiles;
published
// TFileName properties.
property FileName: String read FFileName write SetFileName;
property InitialDir: String read FInitialDir write FInitialDir;
property OnAcceptFileName: TAcceptFileNameEvent read FOnAcceptFileName write FOnAcceptFileName;
property OnFolderChange: TNotifyEvent read FOnFolderChange write FOnFolderChange;
property DialogKind: TDialogKind read FDialogKind write FDialogKind default dkOpen;
property DialogTitle: String read FDialogTitle write FDialogTitle;
property DialogOptions: TOpenOptions read FDialogOptions write FDialogOptions default DefaultOpenDialogOptions;
property Filter: String read FFilter write FFilter;
property FilterIndex: Integer read FFilterIndex write FFIlterIndex;
property DefaultExt: String read FDefaultExt write FDefaultExt;
property HideDirectories: Boolean read FHideDirectories write FHideDirectories;
// TEditButton properties.
property ButtonCaption;
property ButtonCursor;
property ButtonHint;
property ButtonOnlyWhenFocused;
property ButtonWidth;
property Constraints;
property DirectInput;
property Glyph;
property NumGlyphs;
property Images;
property ImageIndex;
property ImageWidth;
property Flat;
property FocusOnButtonClick;
// Other properties
property Align;
property Alignment;
property Anchors;
property AutoSelect;
property BidiMode;
property BorderSpacing;
property BorderStyle;
property AutoSize;
property Color;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property Layout;
property MaxLength;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property Spacing;
property TabOrder;
property TabStop;
property Text;
property TextHint;
property Visible;
property OnButtonClick;
property OnChange;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEditingDone;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnStartDrag;
property OnUTF8KeyPress;
end;
{ TDirectoryEdit }
TDirectoryEdit = class(TCustomEditButton)
private
FDialogTitle: String;
FRootDir: String;
FOnAcceptDir: TAcceptFileNameEvent;
FShowHidden: Boolean;
FDialogOptions: TOpenOptions;
function GetDirectory: String;
procedure SetDirectory(const AValue: String);
protected
function GetDefaultGlyphName: string; override;
function CreateDialog: TCommonDialog; virtual;
function GetDialogResult(D : TCommonDialog) : String; virtual;
procedure ButtonClick; override;
public
property AutoSelected;
constructor Create(AOwner: TComponent); override;
procedure RunDialog; virtual;
published
// TDirectory properties.
property Directory: String read GetDirectory write SetDirectory;
property RootDir: String read FRootDir write FRootDir;
property OnAcceptDirectory: TAcceptFileNameEvent read FOnAcceptDir write FonAcceptDir;
property DialogTitle: String read FDialogTitle write FDialogTitle;
property DialogOptions: TOpenOptions read FDialogOptions write FDialogOptions default DefaultOpenDialogOptions;
property ShowHidden: Boolean read FShowHidden write FShowHidden;
// TEditButton properties.
property ButtonCaption;
property ButtonCursor;
property ButtonHint;
property ButtonOnlyWhenFocused;
property ButtonWidth;
property Constraints;
property DirectInput;
property Glyph;
property NumGlyphs;
property Images;
property ImageIndex;
property ImageWidth;
property Flat;
property FocusOnButtonClick;
// Other properties
property Align;
property Alignment;
property Anchors;
property AutoSize;
property AutoSelect;
property BidiMode;
property BorderSpacing;
property BorderStyle;
property Color;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property Layout;
property MaxLength;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property Spacing;
property TabStop;
property Text;
property TextHint;
property Visible;
property OnButtonClick;
property OnChange;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEditingDone;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnStartDrag;
property OnUTF8KeyPress;
end;
{ TDateEdit }
TAcceptDateEvent = procedure (Sender : TObject; var ADate : TDateTime;
var AcceptDate: Boolean) of object;
TCustomDateEvent = procedure (Sender : TObject; var ADate : string) of object;
TDateRangeCheckEvent = procedure (Sender : TObject; var ADate : TDateTime) of object;
TDateOrder = (doNone,doMDY,doDMY,doYMd);
TDateEdit = class(TCustomEditButton)
private
FDateOrder: TDateOrder;
FDefaultToday: Boolean;
FDisplaySettings: TDisplaySettings;
FDroppedDown: Boolean;
FOnAcceptDate: TAcceptDateEvent;
FOnCustomDate: TCustomDateEvent;
FOnDateRangeCheck: TDateRangeCheckEvent;
FFixedDateFormat: string; //used when DateOrder <> doNone
FFreeDateFormat: String; //used when DateOrder = doNone
FDate: TDateTime;
FMinDate: TDateTime;
FMaxDate: TDateTime;
FUpdatingDate: Boolean;
procedure CheckRange(var ADate: TDateTime; AMinDate, AMaxDate: TDateTime);
procedure SetFreeDateFormat(AValue: String);
procedure SetMaxDate(AValue: TDateTime);
procedure SetMinDate(AValue: TDateTime);
function IsLimited: Boolean;
function GetMaxDateStored: Boolean;
function GetMinDateStored: Boolean;
function TextToDate(AText: String; ADefault: TDateTime): TDateTime;
function GetDate: TDateTime;
procedure SetDate(Value: TDateTime);
procedure CalendarPopupReturnDate(Sender: TObject; const ADate: TDateTime);
procedure CalendarPopupShowHide(Sender: TObject);
procedure SetDateOrder(const AValue: TDateOrder);
function DateToText(Value: TDateTime): String;
function IsNullDate(ADate: TDateTime): Boolean;
protected
class procedure WSRegisterClass; override;
function GetDefaultGlyphName: string; override;
procedure ButtonClick; override;
procedure EditDblClick; override;
procedure EditEditingDone; override;
procedure SetDirectInput(AValue: Boolean); override;
procedure RealSetText(const AValue: TCaption); override;
procedure SetDateMask; virtual;
procedure Loaded; override;
procedure DoDateRangeCheck(var ADate: TDateTime);
public
constructor Create(AOwner: TComponent); override;
function GetDateFormat: string;
property AutoSelected;
property Date: TDateTime read GetDate write SetDate;
property Button;
property DroppedDown: Boolean read FDroppedDown;
published
property CalendarDisplaySettings: TDisplaySettings read FDisplaySettings write FDisplaySettings;
property OnAcceptDate: TAcceptDateEvent read FOnAcceptDAte write FOnAcceptDate;
property OnCustomDate: TCustomDateEvent read FOnCustomDate write FOnCustomDate;
property OnDateRangeCheck: TDateRangeCheckEvent read FOnDateRangeCheck write FOnDateRangeCheck;
property ReadOnly;
property DefaultToday: Boolean read FDefaultToday write FDefaultToday default False;
Property DateOrder : TDateOrder Read FDateOrder Write SetDateOrder;
property DateFormat: String read FFreeDateFormat write SetFreeDateFormat;
property MinDate: TDateTime read FMinDate write SetMinDate stored GetMinDateStored;
property MaxDate: TDateTime read FMaxDate write SetMaxDate stored GetMaxDateStored;
property ButtonOnlyWhenFocused;
property ButtonCaption;
property ButtonCursor;
property ButtonHint;
property ButtonWidth;
property Action;
property Align;
property Alignment;
property Anchors;
property AutoSize;
property AutoSelect;
property BidiMode;
property BorderSpacing;
property BorderStyle;
property CharCase;
property Color;
property Constraints;
property DirectInput;
property Glyph;
property NumGlyphs;
property Images;
property ImageIndex;
property ImageWidth;
property DragMode;
property EchoMode;
property Enabled;
property Flat;
property FocusOnButtonClick;
property Font;
property Layout;
property MaxLength;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabStop;
property TabOrder;
property Spacing;
property Visible;
property Text;
property TextHint;
property OnButtonClick;
property OnChange;
property OnChangeBounds;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnEditingDone;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnUTF8KeyPress;
end;
{ TTimeEdit }
TAcceptTimeEvent = procedure (Sender : TObject; var ATime : TDateTime; var AcceptTime: Boolean) of object;
TCustomTimeEvent = procedure (Sender : TObject; var ATime : TDateTime) of object;
TTimeEdit = class(TCustomEditButton)
private
FTime: TTime;
IsEmptyTime: Boolean;
FDefaultNow: Boolean;
FDroppedDown: Boolean;
FSimpleLayout: Boolean;
FTimeAMPMString: array[0..1] of String;
FTimeFormat: String;
FTimeSeparator: String;
FOnAcceptTime: TAcceptTimeEvent;
FOnCustomTime: TCustomTimeEvent;
function GetTime: TDateTime;
function GetTimeAMPMString(AIndex: Integer): String;
procedure SetTime(AValue: TDateTime);
procedure SetEmptyTime;
function GetLayout: Boolean;
procedure SetLayout(AValue: Boolean);
procedure SetTimeAMPMString(AIndex: Integer; AValue: String);
procedure SetTimeFormat(AValue: String);
procedure SetTimeSeparator(AValue: String);
procedure TimePopupReturnTime(Sender: TObject; const ATime: TDateTime);
procedure TimePopupShowHide(Sender: TObject);
procedure OpenTimePopup;
procedure ParseInput;
function TryParseInput(AInput: String; out ParseResult: TDateTime): Boolean;
protected
function GetDefaultGlyphName: string; override;
function UsedFormatSettings: TFormatSettings;
function UsedTimeFormat: String;
function UsedTimeSeparator: Char;
procedure ButtonClick; override;
procedure EditDblClick; override;
procedure EditEditingDone; override;
public
constructor Create(AOwner: TComponent); override;
function ValidTimeFormat(AFormat: String): Boolean;
property Time: TDateTime read GetTime write SetTime;
property Button;
property DroppedDown: Boolean read FDroppedDown;
published
property DefaultNow: Boolean read FDefaultNow write FDefaultNow default False;
property OnAcceptTime: TAcceptTimeEvent read FOnAcceptTime write FOnAcceptTime;
property OnCustomTime: TCustomTimeEvent read FOnCustomTime write FOnCustomTime;
property ReadOnly;
property ButtonCaption;
property ButtonCursor;
property ButtonHint;
property ButtonOnlyWhenFocused;
property ButtonWidth;
property Action;
property Align;
property Alignment;
property Anchors;
property AutoSize;
property AutoSelect;
property BidiMode;
property BorderSpacing;
property BorderStyle;
property CharCase;
property Color;
property Constraints;
property DirectInput;
property Glyph;
property NumGlyphs;
property Images;
property ImageIndex;
property ImageWidth;
property DragMode;
property EchoMode;
property Enabled;
property Flat;
property FocusOnButtonClick;
property Font;
property MaxLength;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property SimpleLayout: Boolean read GetLayout write SetLayout default True;
property Spacing;
property TabStop;
property TabOrder;
property TimeAMString: String index 0 read GetTimeAMPMString write SetTimeAMPMString;
property TimeFormat: String read FTimeFormat write SetTimeFormat;
property TimeSeparator: String read FTimeSeparator write SetTimeSeparator;
property TimePMString: String index 1 read GetTimeAMPMString write SetTimeAMPMString;
property Visible;
property Text;
property TextHint;
property OnButtonClick;
property OnChange;
property OnChangeBounds;
property OnClick;
property OnDblClick;
property OnContextPopup;
property OnEditingDone;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnUTF8KeyPress;
end;
{ TCalcEdit }
TAcceptValueEvent = procedure(Sender: TObject; var AValue: Double; var Accept: Boolean) of object;
TCalcEdit = class(TCustomEditButton)
private
FDialogTitle: String;
FCalculatorLayout: TCalculatorLayout;
FOnAcceptValue: TAcceptValueEvent;
FDialogPosition: TPosition;
FDialogLeft: Integer;
FDialogTop: Integer;
function GetAsFloat: Double;
function GetAsInteger: Integer;
procedure SetAsFloat(const AValue: Double);
procedure SetAsInteger(const AValue: Integer);
function TitleStored: boolean;
protected
FCalcDialog : TForm;
function GetDefaultGlyphName: string; override;
procedure ButtonClick; override;
public
constructor Create(AOwner: TComponent); override;
procedure RunDialog; virtual;
property AutoSelected;
published
// CalcEdit properties
property CalculatorLayout : TCalculatorLayout read FCalculatorLayout write FCalculatorLayout;
property AsFloat : Double read GetAsFloat write SetAsFloat;
property AsInteger : Integer read GetAsInteger write SetAsInteger;
property OnAcceptValue : TAcceptValueEvent read FOnAcceptValue write FOnAcceptValue;
property DialogTitle : String read FDialogTitle write FDialogTitle stored TitleStored;
// TEditButton properties.
property ButtonCaption;
property ButtonCursor;
property ButtonHint;
property ButtonOnlyWhenFocused;
property ButtonWidth;
property Constraints;
property DialogPosition: TPosition read FDialogPosition write FDialogPosition default poScreenCenter;
property DialogTop: Integer read FDialogTop write FDialogTop;
property DialogLeft: Integer read FDialogLeft write FDialogLeft;
property DirectInput;
property Glyph;
property NumGlyphs;
property Images;
property ImageIndex;
property ImageWidth;
property Flat;
property FocusOnButtonClick;
// Other properties
property Align;
property Alignment;
property Anchors;
property BidiMode;
property BorderSpacing;
property BorderStyle;
property AutoSize;
property AutoSelect;
property Color;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property Layout;
property MaxLength;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property Spacing;
property TabOrder;
property TabStop;
property Text;
property TextHint;
property Visible;
property OnButtonClick;
property OnChange;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEditingDone;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnStartDrag;
property OnUTF8KeyPress;
end;
const
ResBtnListFilter = 'btnfiltercancel';
ResBtnFileOpen = 'btnselfile';
ResBtnSelDir = 'btnseldir';
ResBtnCalendar = 'btncalendar';
ResBtnCalculator = 'btncalculator';
ResBtnTime = 'btntime';
procedure Register;
implementation
{$R lcl_edbtnimg.res}
const
DTEpsilon = Double(1.0)/(24*3600*1000*10); //0.1 millisec (0.000000001157407407);
{ TEditSpeedButton }
procedure TEditSpeedButton.GlyphChanged(Sender: TObject);
begin
inherited GlyphChanged(Sender);
if (Owner is TCustomEditButton) then TCustomEditButton(Owner).GlyphChanged(Sender);
end;
{ TEbEdit }
procedure TEbEdit.DoEnter;
begin
if (Owner is TCustomEditButton) then TCustomEditButton(Owner).CheckButtonVisible;
inherited DoEnter;
end;
procedure TEbEdit.DoExit;
begin
if (Owner is TCustomEditButton) then TCustomEditButton(Owner).CheckButtonVisible;
inherited DoExit;
end;
{ TCustomEditButton }
procedure TCustomEditButton.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean);
begin
inherited CalculatePreferredSize(PreferredWidth, PreferredHeight, WithThemeSpace);
PreferredWidth := 0;
end;
procedure TCustomEditButton.SetFocusOnButtonClick(AValue: Boolean);
begin
FocusOnBuddyClick := AValue;
end;
procedure TCustomEditButton.SetOnButtonClick(AValue: TNotifyEvent);
begin
OnBuddyClick := AValue;
end;
procedure TCustomEditButton.SetButtonOnlyWhenFocused(AValue: Boolean);
begin
if FButtonOnlyWhenFocused <> AValue then
begin
FButtonOnlyWhenFocused := AValue;
CheckButtonVisible;
end;
end;
function TCustomEditButton.GetGlyph: TBitmap;
begin
Result := Button.Glyph;
end;
function TCustomEditButton.GetImageIndex: TImageIndex;
begin
Result := Button.ImageIndex;
end;
function TCustomEditButton.GetImages: TCustomImageList;
begin
Result := Button.Images;
end;
function TCustomEditButton.GetImageWidth: Integer;
begin
Result := Button.ImageWidth;
end;
function TCustomEditButton.GetButton: TSpeedButton;
begin
Result := TSpeedButton(Buddy);
end;
function TCustomEditButton.GetOnButtonClick: TNotifyEvent;
begin
Result := OnBuddyClick;
end;
procedure TCustomEditButton.GlyphChanged(Sender: TObject);
begin
if ((Button.Glyph=nil) or (Button.Glyph.Empty))
and (Button.Images=nil) and (Button.ImageIndex=-1) then
LoadDefaultGlyph;
end;
procedure TCustomEditButton.LoadDefaultGlyph;
var
N: string;
begin
N := GetDefaultGlyphName;
if N <> '' then
(Button as TEditSpeedButton).ButtonGlyph.LCLGlyphName := N;
end;
function TCustomEditButton.GetFocusOnButtonClick: Boolean;
begin
Result := FocusOnBuddyClick;
end;
function TCustomEditButton.GetNumGlyps: Integer;
begin
Result := Button.NumGlyphs;
end;
function TCustomEditButton.GetEdit: TEbEdit;
begin
Result := TEbEdit(BaseEditor);
end;
class function TCustomEditButton.GetControlClassDefaultSize: TSize;
begin
Result.CX := 80 + 23; //as TCustomEdit + TCustomSpeedButton
Result.CY := 23; //as TCustomEdit
end;
function TCustomEditButton.GetDefaultGlyphName: string;
begin
Result := '';
end;
procedure TCustomEditButton.SetFlat(AValue: Boolean);
begin
if FFlat = AValue then
Exit;
FFlat := AValue;
Button.Flat := AValue;
end;
procedure TCustomEditButton.SetNumGlyphs(AValue: Integer);
begin
Button.NumGlyphs := AValue;
end;
function TCustomEditButton.CalcButtonVisible: Boolean;
begin
Result := (csdesigning in ComponentState) or
(Visible and (Edit.Focused or not FButtonOnlyWhenFocused));
end;
procedure TCustomEditButton.CheckButtonVisible;
begin
if Assigned(Button) then
begin
Button.Visible := CalcButtonVisible;
UpdateSpacing;
end;
end;
procedure TCustomEditButton.ButtonClick;
begin
//debugln(['TCustomEditButton.ButtonClick']);
{Don't remove, even if this is an empty method!}
end;
procedure TCustomEditButton.BuddyClick;
begin
inherited BuddyClick;
ButtonClick;
end;
procedure TCustomEditButton.SetGlyph(AValue: TBitmap);
begin
Button.Glyph := AValue;
if AValue=nil then
LoadDefaultGlyph;
Invalidate;
end;
procedure TCustomEditButton.SetImageIndex(const aImageIndex: TImageIndex);
begin
Button.ImageIndex := aImageIndex;
end;
procedure TCustomEditButton.SetImages(const aImages: TCustomImageList);
begin
Button.Images := aImages;
end;
procedure TCustomEditButton.SetImageWidth(const aImageWidth: Integer);
begin
Button.ImageWidth := aImageWidth;
end;
function TCustomEditButton.GetEditorClassType: TGEEditClass;
begin
Result := TEbEdit;
end;
function TCustomEditButton.GetBuddyClassType: TControlClass;
begin
Result := TEditSpeedButton;
end;
constructor TCustomEditButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FButtonOnlyWhenFocused := False;
FocusOnButtonClick := False;
SetInitialBounds(0, 0, GetControlClassDefaultSize.CX, GetControlClassDefaultSize.CY);
LoadDefaultGlyph;
Spacing := 4;
end;
{ TCustomControlFilterEdit }
constructor TCustomControlFilterEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle:=ControlStyle-[csSetCaption];
CharCase:=ecLowerCase;
Button.Enabled:=False;
fFilterOptions:=[];
fIsFirstUpdate:=True;
fIsFirstSetFormActivate:=True;
TextHint:=rsFilter;
fNeedButtonEnabled:=True;
IdleConnected:=true;
end;
destructor TCustomControlFilterEdit.Destroy;
begin
IdleConnected:=False;
inherited Destroy;
end;
procedure TCustomControlFilterEdit.DestroyWnd;
begin
IdleConnected:=false;
inherited DestroyWnd;
end;
procedure TCustomControlFilterEdit.InternalSetFilter(const AValue: string);
begin
Button.Enabled:=AValue<>'';
fFilter:=AValue;
fFilterLowercase:=UTF8LowerCase(fFilter);
InvalidateFilter;
end;
procedure TCustomControlFilterEdit.SetFilter(AValue: string);
// AValue parameter must not have const modifier. It causes a crash, see issue #40300.
begin
if Text=AValue then Exit;
Text:=AValue; // ApplyFilter will be called by EditChange handler.
InternalSetFilter(AValue);
end;
procedure TCustomControlFilterEdit.SetFilterOptions(AValue: TFilterStringOptions);
begin
if fFilterOptions=AValue then Exit;
fFilterOptions:=AValue;
InvalidateFilter;
end;
procedure TCustomControlFilterEdit.SetSortData(AValue: Boolean);
begin
if fSortData=AValue then Exit;
fSortData:=AValue;
InvalidateFilter;
end;
function TCustomControlFilterEdit.DoDefaultFilterItem(const ACaption: string;
const ItemData: Pointer): Boolean;
var
NPos: integer;
begin
if fFilter='' then
exit(True);
if fsoCaseSensitive in fFilterOptions then
NPos := Pos(fFilter, ACaption)
else
NPos := Pos(fFilterLowercase, UTF8LowerCase(ACaption));
if fsoMatchOnlyAtStart in fFilterOptions then
Result := NPos=1
else
Result := NPos>0;
end;
function TCustomControlFilterEdit.DoFilterItem(const ACaption: string;
ItemData: Pointer): Boolean;
var
Done: Boolean;
begin
Done := False;
Result := False;
// Filter with event handler if there is one.
if Assigned(fOnFilterItemEx) then
Result := fOnFilterItemEx(ACaption, ItemData, Done);
// Support also the old filter event without a caption.
if (not (Result and Done)) and Assigned(fOnFilterItem) then
Result := fOnFilterItem(ItemData, Done);
// Filter by item's caption text if needed.
if not (Result or Done) then
Result := DoDefaultFilterItem(ACaption, ItemData);
end;
procedure TCustomControlFilterEdit.OnAsync(Data: PtrInt);
begin
if fNeedFiltering then begin
ApplyFilter(true);
fNeedFiltering:=False;
end;
if fNeedButtonEnabled then begin
Button.Enabled:=Text<>'';
fNeedButtonEnabled:=False;
end;
IdleConnected:=false;
if Assigned(fOnAfterFilter) then
fOnAfterFilter(Self);
end;
procedure TCustomControlFilterEdit.SetIdleConnected(const AValue: Boolean);
begin
if fIdleConnected=AValue then exit;
fIdleConnected:=AValue;
if fIdleConnected then
Application.QueueAsyncCall(@OnAsync, 0)
else
Application.RemoveAsyncCalls(Self);
end;
procedure TCustomControlFilterEdit.EditKeyDown(var Key: Word; Shift: TShiftState);
begin
inherited EditKeyDown(Key, Shift);
if Key = 0 then exit;
if Shift = [] then
case Key of
VK_RETURN: if ReturnKeyHandled then Key := 0;
end;
if (Shift = []) or (Shift = [ssShift]) then
case Key of
VK_UP: begin MovePrev (ssShift in Shift); Key := 0; end;
VK_DOWN: begin MoveNext (ssShift in Shift); Key := 0; end;
VK_PRIOR: begin MovePageUp (ssShift in Shift); Key := 0; end;
VK_NEXT: begin MovePageDown(ssShift in Shift); Key := 0; end;
end;
if (Shift = [ssCtrl]) or (Shift = [ssCtrl, ssShift]) then
case Key of
VK_HOME: begin MoveHome(ssShift in Shift); Key := 0; end;
VK_END: begin MoveEnd (ssShift in Shift); Key := 0; end;
end;
end;
procedure TCustomControlFilterEdit.EditChange;
begin
InternalSetFilter(Text);
inherited;
end;
procedure TCustomControlFilterEdit.BuddyClick;
begin
Text:='';
ResetFilter;
if FocusOnButtonClick then
Edit.SetFocus; //don't SelectAll here
inherited;
end;
procedure TCustomControlFilterEdit.ApplyFilter(Immediately: Boolean);
begin
if Immediately then begin
SortAndFilter;
if (fSelectedPart=Nil) and not fIsFirstUpdate then
StoreSelection; // At first round the selection is from caller
ApplyFilterCore; // The actual filtering implemented by inherited class.
fSelectedPart:=Nil;
if not fIsFirstUpdate then
RestoreSelection;
fIsFirstUpdate:=False;
end
else if [csDestroying,csDesigning]*ComponentState=[] then
InvalidateFilter;
end;
procedure TCustomControlFilterEdit.InvalidateFilter;
begin
if fAlreadyFiltered then Exit;
fNeedFiltering:=true;
IdleConnected:=true;
end;
function TCustomControlFilterEdit.IsTextHintStored: Boolean;
begin
Result := TextHint<>rsFilter;
end;
procedure TCustomControlFilterEdit.ResetFilter;
begin
Filter:='';
end;
function TCustomControlFilterEdit.ForceFilter(AFilter: String): String;
// Apply a new filter immediately without waiting for idle. Returns the previous filter.
begin
Result := FFilter;
if fFilter <> AFilter then begin
FFilter := AFilter;
ApplyFilter(True);
end;
end;
function TCustomControlFilterEdit.GetDefaultGlyphName: string;
begin
Result := ResBtnListFilter;
end;
class procedure TCustomControlFilterEdit.WSRegisterClass;
begin
inherited WSRegisterClass;
RegisterPropertyToSkip(TCustomControlFilterEdit, 'UseFormActivate', 'Property streamed in older Lazarus revision','');
end;
{ TFileNameEdit }
constructor TFileNameEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDialogFiles := TStringList.Create;
FDialogKind := dkOpen;
FDialogOptions := DefaultOpenDialogOptions;
end;
destructor TFileNameEdit.Destroy;
begin
FreeAndNil(FDialogFiles);
inherited Destroy;
end;
procedure TFileNameEdit.SetFileName(const AValue: String);
begin
if FFileNameChangeLock > 0 then
Exit;
FFileName := AValue;
Inc(FFileNameChangeLock);
try
if FHideDirectories then
Text:=ExtractFileName(AValue) //Originally used inherited RealSetText()
else
Text:=AValue
finally
Dec(FFileNameChangeLock);
end;
end;
function TFileNameEdit.CreateDialog(AKind: TDialogKind): TCommonDialog;
var
O: TOpenDialog;
S: TSaveDialog;
Dir: String;
begin
case AKind of
dkOpen, dkPictureOpen:
begin
if AKind = dkPictureOpen then
O := TOpenPictureDialog.Create(Self)
else
O := TOpenDialog.Create(Self);
Result := O;
end;
dkSave, dkPictureSave:
begin
S:=TSaveDialog.Create(Self);
S.DefaultExt := FDefaultExt;
Result := S;
end;
end;
if Result is TOpenDialog then
begin
O:=TOpenDialog(Result);
Dir:=ExtractFilePath(Filename);
if (Dir<>'') and DirPathExists(Dir) then
// setting a FileName with path disables InitialDir
O.FileName := FileName
else begin
// do not use path, so that InitialDir works
O.FileName := ExtractFileName(Filename);
end;
O.Options := DialogOptions;
O.Filter := Filter;
O.FilterIndex := FilterIndex;
if (InitialDir <> '') then //don't force currentdir here, let WS do it's normal "magic" to decide where to open
O.InitialDir := CleanAndExpandDirectory(InitialDir)
else
O.InitialDir := '';
end;
// Set some common things.
Result.Title := DialogTitle;
end;
procedure TFileNameEdit.SaveDialogResult(AKind: TDialogKind; D: TCommonDialog);
var
FN: String;
begin
case AKind of
dkOpen, dkPictureOpen :
begin
FilterIndex := TOpenDialog(D).FilterIndex;
FN := TOpenDialog(D).FileName;
if (FN <> '') then
begin
if Assigned(OnAcceptFileName) then
OnAcceptFileName(Self, FN);
end;
if (FN <> '') then
begin
// set FDialogFiles first since assigning of FileName trigger events
FDialogFiles.Text := TOpenDialog(D).Files.Text;
FileName := FN;
end;
end;
dkSave, dkPictureSave :
begin
FileName := TSaveDialog(D).FileName;
FilterIndex := TSaveDialog(D).FilterIndex;
FDialogFiles.Clear;
end;
end;
end;
procedure TFileNameEdit.ButtonClick;
begin
inherited ButtonClick;
RunDialog;
//Do this after the dialog, otherwise it just looks silly
if FocusOnButtonClick then FocusAndMaybeSelectAll;
end;
function TFileNameEdit.GetDefaultGlyphName: string;
begin
Result := ResBtnFileOpen;
end;
procedure TFileNameEdit.RunDialog;
var
D: TCommonDialog;
Res: Boolean;
begin
D := CreateDialog(DialogKind);
try
Res := D.Execute;
//this is analogue to how TOpenDialog behaves, InitialDir is retrieved from the dialog, even if user cancels the dialog.
if (D is TOpenDialog) then
InitialDir := TOpenDialog(D).InitialDir;
if Res then
SaveDialogResult(DialogKind, D);
finally
D.Free;
end
end;
procedure TFileNameEdit.EditChange;
begin
if FFileNameChangeLock <= 0 then
begin
Inc(FFileNameChangeLock);
try
if FHideDirectories and (ExtractFilePath(Text) = '') then
FFileName := ExtractFilePath(FFileName) + Text
else
FFileName := Text;
finally
Dec(FFileNameChangeLock);
end;
end;
inherited EditChange; //do this _after_ we have updated FFileName
end;
procedure TFileNameEdit.DoFolderChange(Sender: TObject);
begin
if Assigned(FOnFolderChange) then
FOnFolderChange(Self);
end;
{ TDirectoryEdit }
constructor TDirectoryEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDialogOptions := DefaultOpenDialogOptions;
end;
procedure TDirectoryEdit.SetDirectory(const AValue: String);
begin
if (Text<>AValue) then
Text:=AValue;
end;
function TDirectoryEdit.CreateDialog: TCommonDialog;
begin
Result:=TSelectDirectoryDialog.Create(Self);
if DirPathExists(Directory) then
begin
TSelectDirectoryDialog(Result).InitialDir:=Directory;
TSelectDirectoryDialog(Result).FileName:='';
end
else
begin
TSelectDirectoryDialog(Result).InitialDir:=RootDir;
TSelectDirectoryDialog(Result).FileName:=Directory;
end;
// Set some common things.
TSelectDirectoryDialog(Result).Options := DialogOptions;
Result.Title := DialogTitle;
end;
function TDirectoryEdit.GetDialogResult(D: TCommonDialog) : String;
begin
Result:=TSelectDirectoryDialog(D).FileName;
end;
procedure TDirectoryEdit.ButtonClick;
begin
inherited ButtonClick;
RunDialog;
//Do this after the dialog, oterwise it just looks silly
if FocusOnButtonClick then FocusAndMaybeSelectAll;
end;
function TDirectoryEdit.GetDefaultGlyphName: string;
begin
Result := ResBtnSelDir;
end;
procedure TDirectoryEdit.RunDialog;
var
D: String;
Dlg: TCommonDialog;
B: Boolean;
begin
Dlg:=CreateDialog;
try
B:=Dlg.Execute;
if B then
D:=GetDialogResult(Dlg);
finally
Dlg.Free;
end;
if B then
begin
if Assigned(FOnAcceptDir) then
begin
FOnAcceptdir(Self,D);
if (D<>'') then
Directory:=D;
end
else
Directory:=D;
end;
end;
function TDirectoryEdit.GetDirectory: String;
begin
Result:=Text;
end;
{ TDateEdit }
function StrToDateDef(cDate: String; dDefault: TDateTime): TDateTime;
begin
try
Result := StrToDate(cDate)
except
Result := dDefault;
end;
end;
constructor TDateEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDate := NullDate;
FMinDate := 0.0;
FMaxDate := 0.0;
FUpdatingDate := False;
FDefaultToday := False;
FDisplaySettings := [dsShowHeadings, dsShowDayNames];
end;
function TDateEdit.GetDateFormat: string;
begin
Result := FFixedDateFormat;
end;
function TDateEdit.GetDefaultGlyphName: string;
begin
Result := ResBtnCalendar;
end;
procedure TDateEdit.ButtonClick;//or onClick
var
PopupOrigin: TPoint;
ADate: TDateTime;
begin
inherited ButtonClick;
PopupOrigin := ControlToScreen(Point(0, Height));
ADate := GetDate;
if IsNullDate(ADate) then
ADate := SysUtils.Date;
if IsLimited then
CheckRange(ADate, FMinDate, FMaxDate)
else
CheckRange(ADate, MinDateTime, MaxDateTime);
ShowCalendarPopup(PopupOrigin, ADate, CalendarDisplaySettings,
FMinDate, FMaxDate,
@CalendarPopupReturnDate, @CalendarPopupShowHide, self);
//Do this after the dialog, otherwise it just looks silly
if FocusOnButtonClick then FocusAndMaybeSelectAll;
end;
procedure TDateEdit.EditDblClick;
begin
inherited EditDblClick;
if not ReadOnly then
ButtonClick;
end;
procedure TDateEdit.EditEditingDone;
var
AText: String;
begin
inherited EditEditingDone;
if DirectInput then
begin
AText := DateToText(GetDate);
if AText <> Text then //avoid unneccesary recalculation FDate
Text := AText;
end;
end;
procedure TDateEdit.SetDirectInput(AValue: Boolean);
var
Def: TDateTime;
begin
inherited SetDirectInput(AValue);
//Synchronize FDate
FDate := TextToDate(Text, NullDate);
//Force a valid date in the control, but not if Text was empty in designmode
if not ((csDesigning in ComponentState) and FDefaultToday and (IsNullDate(FDate))) then
SetDate(FDate);
end;
procedure TDateEdit.RealSetText(const AValue: TCaption);
begin
if (not DirectInput) and not FUpdatingDate then
begin
//force a valid date and set FDate
//debugln('TDateEdit.SetText: DirectInput = False');
if FDefaultToday then
FDate := TextToDate(AValue, SysUtils.Date)
else
FDate := TextToDate(AValue, NullDate);
//Allow to clear Text in Designer (Issue #0030425)
if (csDesigning in ComponentState) and (AValue = '') then
inherited RealSetText('')
else
inherited RealSetText(DateToText(FDate));
end else
inherited RealSetText(AValue);
end;
procedure TDateEdit.SetDateMask;
Var
S : String;
D : TDateTime;
begin
Case DateOrder of
doNone :
begin
S:=''; // no mask
FFixedDateFormat:='';
end;
doDMY,
doMDY :
begin
S:='99/99/9999;1;_';
if DateOrder=doMDY then
FFixedDateFormat:='mm/dd/yyyy'
else
FFixedDateFormat:='dd/mm/yyyy';
end;
doYMD :
begin
S:='9999/99/99;1;_';
FFixedDateFormat:='yyyy/mm/dd';
end;
end;
D:=GetDate;
EditMask:=S;
SetDate(D);
end;
procedure TDateEdit.Loaded;
begin
//Forces a valid Text in the control
if not (csDesigning in ComponentState) then
SetDate(FDate);
//avoid OnChange (regression introduced by #8ce29506c500e46d65b9a067bf446fd91224e6c0, happens when DirectInput=True and DefaultToday=True)
//the FEdit's OnChange is only forwarded once the whole component has been loaded, so call inherited after setting the text, not before
inherited Loaded;
end;
procedure TDateEdit.DoDateRangeCheck(var ADate: TDateTime);
begin
if Assigned(FOnDateRangeCheck) then
FOnDateRangeCheck(Self, ADate);
end;
Function ParseDate(S : String; Order : TDateOrder; Def: TDateTime) : TDateTime;
Var
P,N1,N2,N3 : Integer;
B : Boolean;
begin
Result:=Def;
P:=Pos(DefaultFormatSettings.DateSeparator,S);
If (P=0) then
Exit;
N1:=StrToIntDef(Copy(S,1,P-1),-1);
If (N1=-1) then Exit;
Delete(S,1,P);
P:=Pos(DefaultFormatSettings.DateSeparator,S);
If (P=0) then
Exit;
N2:=StrToIntDef(Copy(S,1,P-1),-1);
If (N2=-1) then Exit;
Delete(S,1,P);
N3:=StrToIntDef(S,-1);
If (N3=-1) then
exit;
Case Order of
doYMD : B:=TryEncodeDate(N1,N2,N3,Result);
doMDY : B:=TryEncodeDate(N3,N1,N2,Result);
doDMY : B:=TryEncodeDate(N3,N2,N1,Result);
else B:=false;
end;
If not B then // Not sure if TryEncodeDate touches Result.
Result:=Def;
end;
// Tries to parse string when DateOrder = doNone when string maybe contains
// literal day or monthnames. For example when ShortDateFormat = 'dd-mmm-yyy'
// Returns NullDate upon failure.
function ParseDateNoPredefinedOrder(SDate: String; FS: TFormatSettings): TDateTime;
var
Fmt: String;
DPos, MPos, YPos: SizeInt;
DStr, MStr, YStr: String;
LD, LM, LY: LongInt;
DD, MM, YY: Word;
const
Digits = ['0'..'9'];
procedure GetPositions(out DPos, MPos, YPos: SizeInt);
begin
DStr := '';
MStr := '';
YStr := '';
DPos := Pos('D', Fmt);
MPos := Pos('M', Fmt);
YPos := Pos('Y', Fmt);
if (YPos = 0) or (MPos = 0) or (DPos = 0) then Exit;
if (YPos > DPos) then YPos := 3 else YPos := 1;
if (DPos < MPos) then
begin
if (YPos = 3) then
begin
DPos := 1;
MPos := 2;
end
else
begin
DPos := 2;
MPos := 3;
end;
end
else
begin
if (YPos = 3) then
begin
DPos := 2;
MPos := 1;
end
else
begin
DPos := 3;
MPos := 2;
end;
end;
end;
procedure ReplaceLiterals;
var
i, P: Integer;
Sub: String;
begin
if (Pos('MMMM',Fmt) > 0) then
begin //long monthnames
//writeln('Literal monthnames');
for i := 1 to 12 do
begin
Sub := FS.LongMonthNames[i];
P := Pos(Sub, SDate);
if (P > 0) then
begin
Delete(SDate, P, Length(Sub));
Insert(IntToStr(i), SDate, P);
Break;
end;
end;
end
else
begin
if (Pos('MMM',Fmt) > 0) then
begin //short monthnames
for i := 1 to 12 do
begin
Sub := FS.ShortMonthNames[i];
P := Pos(Sub, SDate);
if (P > 0) then
begin
Delete(SDate, P, Length(Sub));
Insert(IntToStr(i), SDate, P);
Break;
end;
end;
end;
end;
if (Pos('DDDD',Fmt) > 0) then
begin //long daynames
//writeln('Literal daynames');
for i := 1 to 7 do
begin
Sub := FS.LongDayNames[i];
P := Pos(Sub, SDate);
if (P > 0) then
begin
Delete(SDate, P, Length(Sub));
Break;
end;
end;
end
else
begin
if (Pos('DDD',Fmt) > 0) then
begin //short daynames
for i := 1 to 7 do
begin
Sub := FS.ShortDayNames[i];
P := Pos(Sub, SDate);
if (P > 0) then
begin
Delete(SDate, P, Length(Sub));
Break;
end;
end;
end;
end;
SDate := Trim(SDate);
//writeln('ReplaceLiterals -> ',SDate);
end;
procedure Split(out DStr, MStr, YStr: String);
var
i, P: Integer;
Sep: Set of Char;
Sub: String;
begin
DStr := '';
MStr := '';
YStr := '';
Sep := [];
for i := 1 to Length(Fmt) do
if not (Fmt[i] in Digits) then Sep := Sep + [Fmt[i]];
//get fist part
P := 1;
while (P <= Length(SDate)) and (SDate[P] in Digits) do Inc(P);
Sub := Copy(SDate, 1, P-1);
Delete(SDate, 1, P);
if (DPos = 1) then DStr := Sub else if (MPos = 1) then MStr := Sub else YStr := Sub;
//get second part
if (SDate = '') then Exit;
while (Length(SDate) > 0) and (SDate[1] in Sep) do Delete(SDate, 1, 1);
if (SDate = '') then Exit;
P := 1;
while (P <= Length(SDate)) and (SDate[P] in Digits) do Inc(P);
Sub := Copy(SDate, 1, P-1);
Delete(SDate, 1, P);
if (DPos = 2) then DStr := Sub else if (MPos = 2) then MStr := Sub else YStr := Sub;
//get thirdpart
if (SDate = '') then Exit;
while (Length(SDate) > 0) and (SDate[1] in Sep) do Delete(SDate, 1, 1);
if (SDate = '') then Exit;
Sub := SDate;
if (DPos = 3) then DStr := Sub else if (MPos = 3) then MStr := Sub else YStr := Sub;
end;
procedure AdjustYear(var YY: Word);
var
CY, CM, CD: Word;
begin
DecodeDate(Date, CY, CM, CD);
LY := CY Mod 100;
CY := CY - LY;
if ((YY - LY) <= 50) then
YY := CY + YY
else
YY := CY + YY - 100;
end;
begin
Result := NullDate; //assume failure
if (Length(SDate) < 5) then Exit; //y-m-d is minimum we support
Fmt := UpperCase(FS.ShortDateFormat); //only care about y,m,d so this will do
GetPositions(DPos, MPos, YPos);
ReplaceLiterals;
if (not (SDate[1] in Digits)) or (not (SDate[Length(SDate)] in Digits)) then Exit;
Split(Dstr, MStr, YStr);
if not TryStrToInt(DStr, LD) or
not TryStrToInt(Mstr, LM) or
not TryStrToInt(YStr, LY) then Exit;
DD := LD;
MM := LM;
YY := LY;
if (YY < 100) and (Pos('YYYY', UpperCase(Fmt)) = 0) then
begin
AdjustYear(YY);
end;
if not TryEncodeDate(YY, MM, DD, Result) then
Result := NullDate;
end;
function TDateEdit.TextToDate(AText: String; ADefault: TDateTime): TDateTime;
var
FS: TFormatSettings;
begin
if Assigned(FOnCustomDate) then
FOnCustomDate(Self, AText);
if (DateOrder = doNone) then
begin
FS := DefaultFormatSettings;
if (FFreeDateFormat <> '') then
FS.ShortDateFormat := FFreeDateFormat;
if not TryStrToDate(AText, Result, FS) then
begin
Result := ParseDateNoPredefinedOrder(AText, FS);
if IsNullDate(Result) then Result := ADefault;
end;
end
else
Result := ParseDate(AText,DateOrder,ADefault)
end;
procedure TDateEdit.CheckRange(var ADate: TDateTime; AMinDate, AMaxDate: TDateTime);
begin
DoDateRangeCheck(ADate);
//otherwise you get a message like "Invalid Date: 31-12-9999. Must be between 1-1-0001 and 31-12-9999"
if (ADate < SysUtils.MinDateTime) then
raise EInvalidDate.CreateFmt(rsDateTooSmall, [DateToStr(SysUtils.MinDateTime)]);
if (ADate > SysUtils.MaxDateTime) then
raise EInvalidDate.CreateFmt(rsDateTooLarge, [DateToStr(SysUtils.MaxDateTime)]);
if (ADate < AMinDate) or (ADate > AMaxDate) then
raise EInvalidDate.CreateFmt(rsInvalidDateRangeHint, [DateToStr(ADate),
DateToStr(AMinDate), DateToStr(AMaxDate)]);
end;
procedure TDateEdit.SetFreeDateFormat(AValue: String);
var
D: TDateTime;
begin
if FFreeDateFormat = AValue then Exit;
if (Text <> '') and (FDateOrder = doNone) and (not (csDesigning in ComponentState)) then
begin
D := GetDate;
FFreeDateFormat := AValue;
SetDate(D); //will update the text
end
else
FFreeDateFormat := AValue;
end;
procedure TDateEdit.SetMaxDate(AValue: TDateTime);
begin
CheckRange(AValue, MinDateTime, MaxDateTime);
if FMaxDate = AValue then Exit;
FMaxDate := AValue;
if IsLimited and not IsNullDate(FDate) and (FDate > FMaxDate) then
SetDate(FMaxDate);
end;
procedure TDateEdit.SetMinDate(AValue: TDateTime);
begin
CheckRange(AValue, MinDateTime, MaxDateTime);
if FMinDate = AValue then Exit;
FMinDate := AValue;
if IsLimited and not IsNullDate(FDate) and (FDate < FMinDate) then
SetDate(FMinDate);
end;
function TDateEdit.IsLimited: Boolean;
begin
Result := (Trunc(FMaxDate)-Trunc(FMinDate) > 0);
end;
function TDateEdit.GetMaxDateStored: Boolean;
begin
Result := not SameValue(FMaxDate, Double(0.0), DTEpsilon);
end;
function TDateEdit.GetMinDateStored: Boolean;
begin
Result := not SameValue(FMinDate, Double(0.0), DTEpsilon);
end;
function TDateEdit.GetDate: TDateTime;
var
ADate: string;
Def: TDateTime;
begin
//debugln(['TDateEdit.GetDate: FDate = ',DateToStr(FDate)]);
if IsNullDate(FDate) and FDefaultToday then
Def := SysUtils.Date
else
Def := FDate;
ADate := Trim(Text);
//if not DirectInput then FDate matches the Text, so no need to parse it
if {(ADate <> '') and} DirectInput then
begin
if (ADate = '') then
begin
if FDefaultToday then
Result := SysUtils.Date
else
Result := NullDate;
end
else
begin
Result := TextToDate(ADate, Def);
FDate := Result;
end;
end
else
Result := Def;
end;
procedure TDateEdit.SetDate(Value: TDateTime);
begin
FUpdatingDate := True;
try
if IsNullDate(Value) then
begin
if DefaultToday then
Value := SysUtils.Date
//else
// Value := NullDate;
end;
if not IsNullDate(Value) then
begin
if IsLimited then
CheckRange(Value, FMinDate, FMaxDate)
else
CheckRange(Value, MinDateTime, MaxDateTime);
end;
FDate := Value;
Text := DateToText(FDate);
finally
FUpdatingDate := False;
end;
end;
procedure TDateEdit.CalendarPopupReturnDate(Sender: TObject;
const ADate: TDateTime);
var
B: Boolean;
D: TDateTime;
begin
try
B := True;
D := ADate;
if Assigned(FOnAcceptDate) then
FOnAcceptDate(Self, D, B);
if B then
Self.Date := D;
except
on E:Exception do
MessageDlg(E.Message, mtError, [mbOK], 0);
end;
end;
procedure TDateEdit.CalendarPopupShowHide(Sender: TObject);
begin
FDroppedDown := (Sender as TForm).Visible;
end;
procedure TDateEdit.SetDateOrder(const AValue: TDateOrder);
begin
if FDateOrder=AValue then exit;
FDateOrder:=AValue;
SetDateMask;
end;
function TDateEdit.DateToText(Value: TDateTime): String;
var
FS: TFormatSettings;
begin
if IsNullDate(Value) then
Result := ''
else
begin
if (FDateOrder = doNone) or (FFixedDateFormat = '') then
begin
FS := DefaultFormatSettings;
if (FFreeDateFormat <> '') then
FS.ShortDateFormat := FFreeDateFormat;
Result := DateToStr(Value, FS)
end
else
Result := FormatDateTime(FFixedDateFormat, Value)
end;
end;
function TDateEdit.IsNullDate(ADate: TDateTime): Boolean;
begin
Result := (Trunc(ADate) = Trunc(NullDate));
end;
class procedure TDateEdit.WSRegisterClass;
begin
inherited WSRegisterClass;
RegisterPropertyToSkip(TDateEdit, 'OKCaption', 'Property streamed in older Lazarus revision','');
RegisterPropertyToSkip(TDateEdit, 'CancelCaption', 'Property streamed in older Lazarus revision','');
end;
{ TTimeEdit }
function TTimeEdit.GetTime: TDateTime;
var
TmpResult: TDateTime;
begin
if DirectInput and TryParseInput(Text, TmpResult) then
FTime := TmpResult;
Result := FTime;
if IsEmptyTime then begin
if FDefaultNow then
Result := TimeOf(Now);
end else begin
if Assigned(FOnCustomTime) then
FOnCustomTime(Self, Result);
end;
end;
function TTimeEdit.GetTimeAMPMString(AIndex: Integer): String;
begin
Result := FTimeAMPMString[AIndex];
end;
function TTimeEdit.GetLayout: Boolean;
begin
Result := FSimpleLayout;
end;
procedure TTimeEdit.SetLayout(AValue: Boolean);
begin
FSimpleLayout := AValue;
end;
procedure TTimeEdit.SetTime(AValue: TDateTime);
begin
Text := FormatDateTime(UsedTimeFormat, AValue, UsedFormatSettings);
FTime := AValue;
IsEmptyTime := False;
end;
procedure TTimeEdit.SetTimeAMPMString(AIndex: Integer; AValue: String);
begin
if FTimeAMPMString[AIndex] <> AValue then
begin
FTimeAMPMString[AIndex] := AValue;
SetTime(FTime);
end;
end;
procedure TTimeEdit.SetTimeFormat(AValue: String);
begin
if (FTimeFormat <> AValue) and ValidTimeFormat(AValue) then
begin
FTimeFormat := AValue;
SetTime(FTime);
end;
end;
procedure TTimeEdit.SetTimeSeparator(AValue: String);
begin
if FTimeSeparator <> AValue then
begin
FTimeSeparator := AValue;
SetTime(FTime);
end;
end;
procedure TTimeEdit.SetEmptyTime;
begin
Text := EmptyStr;
FTime := NullTime;
IsEmptyTime := True;
end;
procedure TTimeEdit.TimePopupReturnTime(Sender: TObject; const ATime: TDateTime);
var
AcceptResult: Boolean;
ReturnedTime: TDateTime;
begin
try
AcceptResult := True;
ReturnedTime := ATime;
if Assigned(FOnAcceptTime) then
FOnAcceptTime(Self, ReturnedTime, AcceptResult);
if AcceptResult then
Self.Time := ReturnedTime;
except
on E:Exception do
MessageDlg(E.Message, mtError, [mbOK], 0);
end;
end;
procedure TTimeEdit.TimePopupShowHide(Sender: TObject);
begin
FDroppedDown := (Sender as TForm).Visible;
end;
procedure TTimeEdit.OpenTimePopup;
var
PopupOrigin: TPoint;
ATime: TDateTime;
begin
ParseInput;
PopupOrigin := ControlToScreen(Point(0, Height));
ATime := GetTime;
if ATime = NullTime then
ATime := SysUtils.Time;
ShowTimePopup(PopupOrigin, ATime, Self.DoubleBuffered,
@TimePopupReturnTime, @TimePopupShowHide, FSimpleLayout, self);
end;
function TTimeEdit.TryParseInput(AInput: String; out ParseResult: TDateTime): Boolean;
var
timeSep: Char;
begin
AInput := Trim(AInput);
timeSep := UsedTimeSeparator;
if (Length(AInput) in [3..4]) and (not AnsiContainsStr(AInput, timeSep)) then begin
Insert(timeSep, AInput, Length(AInput) - 1);
end;
Result := TryStrToTime(AInput, ParseResult, UsedFormatSettings);
end;
procedure TTimeEdit.ParseInput;
var
TmpResult: TDateTime;
begin
if Trim(Text) = EmptyStr then
SetEmptyTime
else if TryParseInput(Self.Text, TmpResult) then
SetTime(TmpResult)
else
SetTime(FTime);
end;
function TTimeEdit.GetDefaultGlyphName: string;
begin
Result := ResBtnTime;
end;
function TTimeEdit.UsedFormatSettings: TFormatSettings;
begin
Result := DefaultFormatSettings;
Result.TimeSeparator := UsedTimeSeparator;
Result.ShortTimeFormat := UsedTimeFormat;
Result.TimeAMString := TimeAMString;
Result.TimePMString := TimePMString;
end;
function TTimeEdit.UsedTimeFormat: String;
begin
if (FTimeFormat = '') or (FTimeFormat = 't') then
Result := DefaultFormatSettings.ShortTimeFormat
else
Result := FTimeFormat;
end;
function TTimeEdit.UsedTimeSeparator: Char;
begin
if FTimeSeparator = '' then
Result := DefaultFormatSettings.TimeSeparator
else
Result := FTimeSeparator[1];
end;
// Since TTimeEdit requires a pure "time format string" this function checks
// whether AFormat contains date parts and returns FALSE in this case.
function TTimeEdit.ValidTimeFormat(AFormat: String): Boolean;
type
TFormatPart = (pH, pM, pN, pS, pZ);
var
p, pEnd: PChar;
parts: set of TFormatPart = [];
quoteChar: Char;
begin
if AFormat = '' then
exit(true);
Result := false;
p := @AFormat[1];
pEnd := p + Length(AFormat);
while p < pEnd do begin
case p^ of
// allowed
'h', 'H':
Include(parts, pH);
'n', 'N':
begin
Include(parts, pN);
if (pM in parts) then exit; // mixing of 'n' and 'm' not valid
end;
's', 'S':
begin
Include(parts, pS);
if parts * [pH, pM, pS] = [pM, pS] then exit; // m:s not valid
end;
'z', 'Z':
begin
Include(parts, pZ);
if parts * [pH, pM, pS, pZ] = [pM, pZ] then exit; // m:z is not valid
end;
'm', 'M':
begin
Include(parts, pM);
if (pN in parts) then exit; // mixing of 'n' and 'm' not valid
if parts = [pM] then exit; // isolated 'm' not allowed
if parts * [pH, pM, pS] = [pM, pS] then exit; // m:s not valid
if parts * [pH, pM, pS, pZ] = [pM, pZ] then exit; // m.z not valid
end;
// ignore quoted parts
'"', '''':
begin
quotechar := p^;
inc(p);
while (p < pEnd) and (p^ <> quoteChar) do
inc(p);
end;
// am/pm
'a', 'A':
begin
if (StrLIComp(p, 'A/P', 3) = 0) then
inc(p, 2)
else
if (StrLIComp(P, 'AMPM', 4) = 0) then
inc(p, 3)
else
if (StrLIComp(P, 'AM/PM', 5) = 0) then
inc(p, 4)
else
exit;
end;
'[', ']':
exit; // interval mode does not fit to the GUI of this control
'd', 'D', 'y', 'Y':
exit; // parts of date format
else
; // all other characters allowed (not necessariy optimal)
end;
inc(p);
end;
Result := true;
end;
procedure TTimeEdit.ButtonClick;
begin
inherited ButtonClick;
OpenTimePopup;
end;
procedure TTimeEdit.EditDblClick;
begin
inherited EditDblClick;
OpenTimePopup;
end;
procedure TTimeEdit.EditEditingDone;
begin
ParseInput;
inherited EditEditingDone;
end;
constructor TTimeEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetEmptyTime;
FSimpleLayout := True;
end;
{ TCalcEdit }
function TCalcEdit.GetAsFloat: Double;
begin
Result := StrToFloatDef(Trim(Text), 0.0);
end;
function TCalcEdit.GetAsInteger: Integer;
begin
Result:=StrToIntDef(Text,0);
end;
function TCalcEdit.GetDefaultGlyphName: string;
begin
Result := ResBtnCalculator;
end;
procedure TCalcEdit.SetAsFloat(const AValue: Double);
begin
Text:=FloatToStr(AValue);
end;
procedure TCalcEdit.SetAsInteger(const AValue: Integer);
begin
Text:=IntToStr(AValue);
end;
function TCalcEdit.TitleStored: boolean;
begin
Result:=FDialogTitle<>rsCalculator;
end;
procedure TCalcEdit.ButtonClick;
begin
inherited ButtonClick;
RunDialog;
//Do this after the dialog, otherwise it just looks silly
if FocusOnButtonClick then FocusAndMaybeSelectAll;
end;
procedure TCalcEdit.RunDialog;
var
D : Double;
B : Boolean;
Dlg: TCalculatorForm;
begin
D:=AsFloat;
Dlg := CreateCalculatorForm(Self,FCalculatorLayout,0);
with Dlg do
try
Caption:=DialogTitle;
Value:=D;
Dlg.Top := FDialogTop;
Dlg.Left := FDialogLeft;
Dlg.Position := FDialogPosition;
if (ShowModal=mrOK) then
begin
D:=Value;
B:=True;
If Assigned(FOnAcceptValue) then
FOnAcceptValue(Self,D,B);
if B then
AsFloat:=D;
end;
finally
Free;
end;
end;
constructor TCalcEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDialogTitle:=rsCalculator;
FDialogPosition := poScreenCenter;
end;
procedure Register;
begin
RegisterComponents('Misc', [TEditButton,TFileNameEdit,TDirectoryEdit,
TDateEdit,TTimeEdit,TCalcEdit]);
end;
end.
Reference in New Issue View Git Blame Copy Permalink