paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-16 20:29:39 +02:00
Code Issues Packages Projects Releases Wiki Activity
f02c53c71c
lazarus/lcl/maskedit.pp

1534 lines
43 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
maskedit.pp
-----------
Component Library Code
***************************************************************************/
*****************************************************************************
* *
* 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. *
* *
*****************************************************************************
}
{
ToDo List:
- Make the EDBEditError errormessage (SMaskEditNoMatch) a Resource string in LCLStrconsts.pas
- Better handling of cut/clear/paste messages
Bugs:
- If you place a TMaskEdit on a form and at designtime set the mask and leave
the text in the control "invalid" (as in: will not validate) and the TMaskEdit
is the ActiveControl of the form, then before the form is displayed an exception will
be raised, because somehow DoExit is executed (which calls ValidateEdit)
A bugreport on this behaviour is in Mantis: #0012877
- UTF8 support for maskcharacters C and c, probably needs major rewrite!!
}
unit MaskEdit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, LMessages, Clipbrd, LCLType, LCLProc;
const
{ Mask Type }
cMask_SpecialChar = '\'; // after this you can set an arbitrary char
cMask_UpperCase = '>'; // after this the chars is in upper case
cMask_LowerCase = '<'; // after this the chars is in lower case
cMask_Letter = 'l'; // only a letter but not necessary
cMask_LetterFixed = 'L'; // only a letter
cMask_AlphaNum = 'a'; // a char from space and #122 but not necessary
cMask_AlphaNumFixed = 'A'; // a char from space and #122
cMask_AllChars = 'c'; // any char #32 - #255 but not necessary (needs fixing for UTF8 characters!!)
cMask_AllCharsFixed = 'C'; // any char #32 - #255 (needs fixing for UTF8 characters!!)
cMask_Number = '9'; // only a number but not necessary
cMask_NumberFixed = '0'; // only a number
cMask_NumberPlusMin = '#'; // only a number or + or -, but not necessary
cMask_HourSeparator = ':'; // automatically put the hour separator char
cMask_DateSeparator = '/'; // automatically but the date separator char
cMask_SpaceOnly = '_'; // automatically put a space
cMask_NoLeadingBlanks = '!'; //Trim leading blanks, otherwise trim trailing blanks from the data
type
{ Type for mask (internal) }
tMaskedType = (Char_Start,
Char_Number,
Char_NumberFixed,
Char_NumberPlusMin,
Char_Letter,
Char_LetterFixed,
Char_LetterUpCase,
Char_LetterDownCase,
Char_LetterFixedUpCase,
Char_LetterFixedDownCase,
Char_AlphaNum,
Char_AlphaNumFixed,
Char_AlphaNumUpCase,
Char_AlphaNumDownCase,
Char_AlphaNumFixedUpCase,
Char_AlphaNumFixedDownCase,
Char_All,
Char_AllFixed,
Char_AllUpCase,
Char_AllDownCase,
Char_AllFixedUpCase,
Char_AllFixedDownCase,
Char_Space,
Char_HourSeparator,
Char_DateSeparator,
Char_Stop);
{ Exception class }
type
EDBEditError = class(Exception);
const
SMaskEditNoMatch = 'The current text does not match the specified mask.';
type
TMaskeditTrimType = (metTrimLeft, metTrimRight);
{ TCustomMaskEdit }
{ ***********************************************************************************************
Please leave in this note until it no longer applies!
FOR ANYONE WHO CARES TO FIX/ENHANCE THIS CODE:
Since we want total control over anything that is done to the text in the control
we have to take into consideration the fact that currently we cannot prevent
cutting/pasting/clearing or dragging selected text in the control, these are handled by the OS
and text is changed before can prevent it.
Not all widgetsets currently handle the messages for cut/paste/clear. Actually we would
like to have a LM_BEFORE_PASTE (etc.) message...
If we allow the OS to cut/clear/paste etc. a situation can occur where mask-literals in the
control are changed with random chars (and cannot be undone) or text is shorter or larger than
the editmask calls for, whic again cannot be undone.
So, as a horrible hack I decided to only allow changing of the text if we coded
this change ourself. This is done by setting the FChangeAllowed field to True before any
write action (in SetInherited Text() ).
We try to intercept the messages for cut/paste/copy/clear and perform the appropriate
actions instead.
If this fails, then in TextChanged we check will see that FChangeAllowed = False
and we will undo the changes made.
To make this undo possible it is necessary to set CurrentText every time you set
the text in the control!
(Bart Broersma, januari 2009)
************************************************************************************************ }
TCustomMaskEdit = Class(TCustomEdit)
private
FRealMask : String; // Real mask inserted
FMask : ShortString; // Acrtual internal mask
FMaskSave : Boolean; // Save mask as part of the data
FTrimType : TMaskEditTrimType; // Trim leading or trailing spaces in GetText
FSpaceChar : Char; // Char for space (default '_')
CurrentText : String; //CurrentText is our backup. See notes above!
FTextOnEnter : String; // Text when user enters the control, used for Reset()
FCursorPos : Integer; // Current caret position
FChangeAllowed: Boolean; // We do not allow text changes by the OS (cut/clear via context menu)
FInitialText : String; // Text set in the formdesigner (must not be handled by SetText)
FInitialMask : String; // EditMask set in the formdesigner
procedure SetMask(Value : String);
function GetIsMasked : Boolean;
procedure SetSpaceChar(Value : Char);
procedure SetCursorPos;
procedure SelectNextChar;
procedure SelectPrevChar;
procedure SelectFirstChar;
procedure GotoEnd;
function HasSelection: Boolean;
function HasExtSelection: Boolean;
procedure GetSel(out _SelStart: Integer; out _SelStop: Integer);
procedure SetSel(const _SelStart: Integer; _SelStop: Integer);
Function CharToMask(Ch : Char) : tMaskedType;
Function MaskToChar(Value : tMaskedType) : Char;
Function IsMaskChar(Ch : Char) : Boolean;
Function IsLiteral(Ch: Char): Boolean;
function TextIsValid(Value: String): Boolean;
function CharMatchesMask(const Ch: Char; const Position: Integer): Boolean;
procedure SetInheritedText(const Value: String); //See notes above!
function ClearChar(Position : Integer) : Char;
procedure InsertChar(Ch : Char);
Function CanInsertChar(Position : Integer; Var Ch : Char) : Boolean;
procedure DeleteSelected;
procedure DeleteChars(NextChar : Boolean);
//Function SearchDeletedText : Boolean;
protected
Function GetText : String;
Procedure SetText(Value : String);
function GetEditText: string; virtual;
procedure SetEditText(const AValue: string);
procedure TextChanged; override;
procedure Loaded; override;
procedure LMPasteFromClip(var Message: TLMessage); message LM_PASTE;
procedure LMCutToClip(var Message: TLMessage); message LM_CUT;
procedure LMClearSel(var Message : TLMessage); message LM_CLEAR;
function EditCanModify: Boolean; virtual;
procedure Reset; virtual;
procedure DoEnter; override;
procedure DoExit; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X, Y: Integer); override;
procedure CheckCursor;
public
procedure CutToClipBoard; override;
procedure PasteFromClipBoard; override;
{ Required methods }
constructor Create(Aowner : TComponent); override;
procedure Clear;
procedure ValidateEdit; virtual;
property EditMask : string read FRealMask write SetMask;
property isMasked : Boolean read GetIsMasked;
property Text : string read GetText write SetText;
property EditText : string read GetEditText write SetEditText;
property SpaceChar : Char read FSpaceChar write SetSpaceChar;
end;
{ TMaskEdit }
TMaskEdit = class(TCustomMaskEdit)
published
property Anchors;
property AutoSelect;
property AutoSize;
property BiDiMode;
property BorderStyle;
property CharCase;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property MaxLength;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property OnUTF8KeyPress;
property EditMask;
property Text;
property SpaceChar;
end;
procedure Register;
implementation
//Define this to prevent validation when the control looses focus
{ $DEFINE NOVALIDATEONEXIT}
{
// For debugging purposes only
const
MaskCharToChar: array[tMaskedType] of Char = (#0, cMask_Number, cMask_NumberFixed, cMask_NumberPlusMin,
cMask_Letter, cMask_LetterFixed, cMask_Letter, cMask_Letter, cMask_LetterFixed, cMask_LetterFixed,
cMask_AlphaNum, cMask_AlphaNumFixed, cMask_AlphaNum, cMask_AlphaNum, cMask_AlphaNumFixed, cMask_AlphaNumFixed,
cMask_AllChars, cMask_AllCharsFixed, cMask_AllChars, cMask_AllChars, cMask_AllCharsFixed, cMask_AllCharsFixed,
cMask_SpaceOnly, cMask_HourSeparator, cMask_DateSeparator, #0);
}
const
MaskSeparator = ';';
{ Component registration procedure }
procedure Register;
begin
RegisterComponents('Additional',[TMaskEdit]);
end;
// Create object
constructor TCustomMaskEdit.Create(Aowner : TComponent);
begin
Inherited Create(Aowner);
FRealMask := '';
FMask := '';
FSpaceChar := '_';
FMaskSave := True;
FChangeAllowed := False;
FTrimType := metTrimRight;
CurrentText := Inherited Text;
FTextOnEnter := Inherited Text;
FInitialText := '';
FInitialMask := '';
end;
// Prepare the real internal Mask
procedure TCustomMaskEdit.SetMask(Value : String);
Var
S : ShortString;
I : Integer;
InUp, InDown : Boolean;
Special : Boolean;
begin
//Setting Mask while loading has unexpected and unwanted side-effects
if (csLoading in ComponentState) then
begin
FInitialMask := Value;
Exit;
end;
if FRealMask <> Value then
begin
FRealMask := Value;
{
First see if Mask is multifield and if we can extract a value for
FMaskSave and/or FSpaceChar
If so, extract and remove from Value (so we know the remaining part of
Value _IS_ the mask to be set
A value for FSpaceChar is only valid if also a value for FMaskSave is specified
(as by Delphi specifications), so Mask must be at least 5 characters
(1 for the mask, 4 for 2 * MaskSeparator and 2 value chars)
These must be the last 2 or 4 characters of EditMask
}
if (Length(Value) >= 5) and (Value[Length(Value)-1] = MaskSeparator) and
(Value[Length(Value)-3] = MaskSeparator) and
(Value[Length(Value)-2] <> cMask_SpecialChar) and
(Value[Length(Value)-4] <> cMask_SpecialChar) then
begin
FSpaceChar := Value[Length(Value)];
FMaskSave := (Value[Length(Value)-2] <> '0');
System.Delete(Value,Length(Value)-3,4);
end
//If not both FMaskSave and FSPaceChar are specified, then see if only FMaskSave is specified
else if (Length(Value) >= 3) and (Value[Length(Value)-1] = MaskSeparator) and
(Value[Length(Value)-2] <> cMask_SpecialChar) then
begin
FMaskSave := (Value[Length(Value)] <> '0');
//Remove this bit from Mask
System.Delete(Value,Length(Value)-1,2);
end;
// Construct Actual Internal Mask
// init
//FMaxChars := 0;
FMask := '';
FTrimType := metTrimRight;
// Init: No UpCase, No LowerCase, No Special Char
InUp := False;
InDown := False;
Special := False;
S := Value;
for I := 1 To Length(S) do
begin
// Must insert a special char
if Special then
begin
FMask := FMask + S[I];
Special := False;
end
else
begin
// Check the char to insert
case S[I] Of
cMask_SpecialChar: Special := True;
cMask_UpperCase: begin
if (I > 1) and (S[I-1] = cMask_LowerCase) then
begin// encountered <>, so no case checking after this
InUp := False;
InDown := False
end else
begin
InUp := True;
InDown := False;
end;
end;
cMask_LowerCase: begin
InDown := True;
InUp := False;
// <> is catched by next cMask_Uppercase
end;
cMask_Letter: begin
if InUp
then
FMask := FMask + MaskToChar(Char_LetterUpCase)
else
if InDown
then
FMask := FMask + MaskToChar(Char_LetterDownCase)
else
FMask := FMask + MaskToChar(Char_Letter)
end;
cMask_LetterFixed: begin
if InUp
then
FMask := FMask + MaskToChar(Char_LetterFixedUpCase)
else
if InDown
then
FMask := FMask + MaskToChar(Char_LetterFixedDownCase)
else
FMask := FMask + MaskToChar(Char_LetterFixed)
end;
cMask_AlphaNum: begin
if InUp
then
FMask := FMask + MaskToChar(Char_AlphaNumUpcase)
else
if InDown
then
FMask := FMask + MaskToChar(Char_AlphaNumDownCase)
else
FMask := FMask + MaskToChar(Char_AlphaNum)
end;
cMask_AlphaNumFixed: begin
if InUp
then
FMask := FMask + MaskToChar(Char_AlphaNumFixedUpcase)
else
if InDown
then
FMask := FMAsk + MaskToChar(Char_AlphaNumFixedDownCase)
else
FMask := FMask + MaskToChar(Char_AlphaNumFixed)
end;
cMask_AllChars: begin
if InUp
then
FMask := FMask + MaskToChar(Char_AllUpCase)
else
if InDown
then
FMask := FMask + MaskToChar(Char_AllDownCase)
else
FMask := FMask + MaskToChar(Char_All)
end;
cMask_AllCharsFixed: begin
if InUp
then
FMask := FMask + MaskToChar(Char_AllFixedUpCase)
else
if InDown
then
FMask := FMask + MaskToChar(Char_AllFixedDownCase)
else
FMask := FMask + MaskToChar(Char_AllFixed)
end;
cMask_Number: FMask := FMask + MaskToChar(Char_Number);
cMask_NumberFixed: FMask := FMask + MaskToChar(Char_NumberFixed);
cMask_NumberPlusMin: FMask := FMask + MaskToChar(Char_NumberPlusMin);
cMask_HourSeparator: FMask := FMask + MaskToChar(Char_HourSeparator);
cMask_DateSeparator: FMask := FMask + MaskToChar(Char_DateSeparator);
cMask_SpaceOnly: FMask := FMask + MaskToChar(Char_Space);
cMask_NoLeadingBlanks:
begin
FTrimType := metTrimLeft;
end;
else begin
FMask := FMask + S[I];
end;
end;
end;
end;
Clear;
end;
end;
// Return if mask is selected
function TCustomMaskEdit.GetIsMasked : Boolean;
begin
Result := (FMask <> '');
end;
// Set the current Space Char
procedure TCustomMaskEdit.SetSpaceChar(Value : Char);
Var
S : ShortString;
I : Integer;
Begin
if (Value <> FSpaceChar) And (Not IsMaskChar(Value)) then
begin
FSpaceChar := Value;
if isMasked then
begin
S := Inherited Text;
for I := 1 to Length(S) do
if (CharToMask(FMask[I]) = Char_Space)
then
S[I] := FSpaceChar;
CurrentText := S;
SetInheritedText(S);
SelectFirstChar;
end;
end;
End;
// Set the cursor position and select the char in the control
procedure TCustomMaskEdit.SetCursorPos;
begin
if FCursorPos < 0 then FCursorPos := 0
else if FCursorPos > Length(FMask) then FCursorPos := Length(FMask);
if FCursorPos + 1 > Length(FMask) then
SetSel(FCursorPos, FCursorPos)
else
SetSel(FCursorPos, FCursorPos + 1);
end;
//Move to next char, skip any mask-literals
procedure TCustomMaskEdit.SelectNextChar;
begin
if (FCursorPos + 1) > Length(FMask) then Exit;
Inc(FCursorPos);
While (FCursorPos + 1 < Length(FMask)) and (IsLiteral(FMask[FCursorPos + 1])) do
begin
Inc(FCursorPos);
end;
if IsLiteral(FMask[FCursorPos + 1]) then Inc(FCursorPos);
SetCursorPos;
end;
//Move to previous char, skip any mask-literals
procedure TCustomMaskEdit.SelectPrevChar;
var
P: LongInt;
begin
if FCursorPos = 0 then Exit;
P := FCursorPos;
Dec(FCursorPos);
While (FCursorPos > 0) and IsLiteral(FMask[FCursorPos + 1]) do
begin
Dec(FCursorPos);
end;
if (FCursorPos = 0) and (P <> 0) and IsLiteral(FMask[FCursorPos + 1]) then FCursorPos := P;
SetCursorPos;
end;
procedure TCustomMaskEdit.SelectFirstChar;
begin
FCursorPos := 0;
SetCursorPos;
end;
procedure TCustomMaskEdit.GotoEnd;
begin
FCursorPos := Length(FMask);
SetCursorPos;
end;
function TCustomMaskEdit.HasSelection: Boolean;
begin
Result := (GetSelLength() > 0);
end;
//Return True if Selection > 1, this influences the handling of Backspace
function TCustomMaskEdit.HasExtSelection: Boolean;
begin
Result := (GetSelLength() > 1);
end;
// Get the current selection
procedure TCustomMaskEdit.GetSel(out _SelStart: Integer; out _SelStop: Integer);
begin
_SelStart:= GetSelStart();
_SelStop:= _SelStart + GetSelLength();
end;
// Set the current selection
procedure TCustomMaskEdit.SetSel(const _SelStart: Integer; _SelStop: Integer);
begin
//in GTK if SelLength <> 0 then setting SelLength also changes SelStart
SetSelLength(0);
SetSelStart(_SelStart);
SetSelLength(_SelStop - _SelStart);
end;
// Transform a single char in a MaskType
Function TCustomMaskEdit.CharToMask(Ch : Char) : tMaskedType;
Begin
Result := Char_Start;
if (Ord(Ch) > Ord(Char_Start)) and
(Ord(Ch) < Ord(Char_Stop) )
then
Result := tMaskedType(Ord(Ch));
End;
// Trasform a single MaskType into a char
Function TCustomMaskEdit.MaskToChar(Value : tMaskedType) : Char;
Begin
Result := Char(Ord(Value));
End;
// Return if the char passed is a valid MaskType char
Function TCustomMaskEdit.IsMaskChar(Ch : Char) : Boolean;
Begin
Result := (CharToMask(Ch) <> Char_Start);
End;
//Return if the char passed is a literal (so it cannot be altered)
function TCustomMaskEdit.IsLiteral(Ch: Char): Boolean;
begin
Result := (not IsMaskChar(Ch)) or
(IsMaskChar(Ch) and (CharToMask(Ch) in [Char_HourSeparator, Char_DateSeparator]))
end;
//Return if Value matches the EditMask
function TCustomMaskEdit.TextIsValid(Value: String): Boolean;
var
i: Integer;
begin
Result := False;
if (Length(Value) <> Length(FMask)) then
begin
//DebugLn(' Length(Value) = ',DbgS(Length(Value)),' Length(FMask) = ',DbgS(Length(FMask)));
Exit; //Actually should never happen??
end;
for i := 1 to Length(FMask) do
begin
if not CharMatchesMask(Value[i], i) then Exit;
end;
Result := True;
end;
function TCustomMaskEdit.CharMatchesMask(const Ch: Char; const Position: Integer): Boolean;
var
Current: tMaskedType;
Ok: Boolean;
begin
Result := False;
if (Position < 1) or (Position > Length(FMask)) then Exit;
Current := CharToMask(FMask[Position]);
case Current Of
Char_Number : OK := Ch In ['0'..'9',#32];
Char_NumberFixed : OK := Ch In ['0'..'9'];
Char_NumberPlusMin : OK := Ch in ['0'..'9','+','-',#32];
Char_Letter : OK := Ch In ['a'..'z', 'A'..'Z',#32];
Char_LetterFixed : OK := Ch In ['a'..'z', 'A'..'Z'];
Char_LetterUpCase : OK := Ch In ['A'..'Z',#32];
Char_LetterDownCase : OK := Ch In ['a'..'z',#32];
Char_LetterFixedUpCase : OK := Ch In ['A'..'Z'];
Char_LetterFixedDownCase : OK := Ch In ['a'..'z'];
Char_AlphaNum : OK := Ch in ['a'..'z', 'A'..'Z', '0'..'9',#32];
Char_AlphaNumFixed : OK := Ch in ['a'..'z', 'A'..'Z', '0'..'9'];
Char_AlphaNumUpCase : OK := Ch in ['A'..'Z', '0'..'9',#32];
Char_AlphaNumDownCase : OK := Ch in ['a'..'z', '0'..'9',#32];
Char_AlphaNumFixedUpCase : OK := Ch in ['A'..'Z', '0'..'9'];
Char_AlphaNumFixedDowncase:OK := Ch in ['a'..'z', '0'..'9'];
//ToDo: make this UTF8 compatible, for now
//limit this to lower ASCII set
Char_All : OK := Ch in [#32..#126]; //True;
Char_AllFixed : OK := Ch in [#32..#126]; //True;
Char_AllUpCase : OK := Ch in [#32..#126]; //True;
Char_AllDownCase : OK := Ch in [#32..#126]; //True;
Char_AllFixedUpCase : OK := Ch in [#32..#126]; //True;
Char_AllFixedDownCase : OK := Ch in [#32..#126]; //True;
Char_Space : OK := Ch in [' ', '_'];
Char_HourSeparator : OK := Ch in [TimeSeparator];
Char_DateSeparator : OK := Ch in [DateSeparator];
else//it's a literal
begin
OK := (Ch = FMask[Position]);
end;
end;//case
//DebugLn('Position = ',DbgS(Position),' Current = ',MaskCharToChar[Current],' Ch = "',Ch,'" Ok = ',DbgS(Ok));
Result := Ok;
end;
//Set text in the control with FChangeAllowed flag set appropriately
procedure TCustomMaskEdit.SetInheritedText(const Value: String);
begin
if Value <> Inherited Text then
begin
FChangeAllowed := True;
Inherited Text := Value;
FChangeAllowed := False;
end;
end;
// Clear (virtually) a single char in position Position
function TCustomMaskEdit.ClearChar(Position : Integer) : Char;
begin
Result := FMask[Position];
//For Delphi compatibilty, only literals remain, all others will be blanked
case CharToMask(FMask[Position]) Of
Char_Number : Result := FSpaceChar;
Char_NumberFixed : Result := FSpaceChar; //'0';
Char_NumberPlusMin : Result := FSpaceChar;
Char_Letter : Result := FSpaceChar;
Char_LetterFixed : Result := FSpaceChar; //'a';
Char_LetterUpCase : Result := FSpaceChar;
Char_LetterDownCase : Result := FSpaceChar;
Char_LetterFixedUpCase : Result := FSpaceChar; //'A';
Char_LetterFixedDownCase : Result := FSpaceChar; //'a';
Char_AlphaNum : Result := FSpaceChar;
Char_AlphaNumFixed : Result := FSpaceChar;
Char_AlphaNumUpCase : Result := FSpaceChar;
Char_AlphaNumDownCase : Result := FSpaceChar;
Char_AlphaNumFixedUpcase : Result := FSpaceChar;
Char_AlphaNuMFixedDownCase: Result := FSpaceChar;
Char_All : Result := FSpaceChar;
Char_AllFixed : Result := FSpaceChar; //'0';
Char_AllUpCase : Result := FSpaceChar;
Char_AllDownCase : Result := FSpaceChar;
Char_AllFixedUpCase : Result := FSpaceChar; //'0';
Char_AllFixedDownCase : Result := FSpaceChar; //'0';
Char_Space : Result := FSpaceChar;
Char_HourSeparator : Result := TimeSeparator;
Char_DateSeparator : Result := DateSeparator;
end;
end;
//Insert a single char at the current position of the cursor
procedure TCustomMaskEdit.InsertChar(Ch : Char);
Var
S : ShortString;
begin
if CanInsertChar(FCursorPos + 1, Ch) then
begin
DeleteChars(True);
S := Inherited Text;
S[FCursorPos + 1] := Ch;
CurrentText := S;
SetInheritedText(S);
SelectNextChar;
end
else
//If we have a selcetion (> 1) then Delete the selected text: Delphi compatibility
if HasExtSelection then DeleteSelected;
end;
Function TCustomMaskEdit.CanInsertChar(Position : Integer; Var Ch : Char) : Boolean;
Var
Current : tMaskedType;
Begin
Current := CharToMask(FMask[Position]);
Result := False;
// If in UpCase convert the input char
if (Current = Char_LetterUpCase ) Or
(Current = Char_LetterFixedUpCase) Or
(Current = Char_AllUpCase ) Or
(Current = Char_AllFixedUpCase ) or
(Current = Char_AlphaNumUpcase ) or
(Current = Char_AlphaNumFixedUpCase)
then
Ch := UpCase(Ch);
// If in LowerCase convert the input char
if (Current = Char_LetterDownCase ) Or
(Current = Char_LetterFixedDownCase) Or
(Current = Char_AllDownCase ) Or
(Current = Char_AllFixedDownCase ) or
(Current = Char_AlphaNumDownCase ) or
(Current = Char_AlphaNumFixedDownCase )
then
Ch := LowerCase(Ch);
// Check the input (check the valid range)
case Current Of
Char_Number : Result := Ch In ['0'..'9'];
Char_NumberFixed : Result := Ch In ['0'..'9'];
Char_NumberPlusMin : Result := Ch in ['0'..'9','+','-'];
Char_Letter : Result := Ch In ['a'..'z', 'A'..'Z'];
Char_LetterFixed : Result := Ch In ['a'..'z', 'A'..'Z'];
Char_LetterUpCase : Result := Ch In ['A'..'Z'];
Char_LetterDownCase : Result := Ch In ['a'..'z'];
Char_LetterFixedUpCase : Result := Ch In ['A'..'Z'];
Char_LetterFixedDownCase : Result := Ch In ['a'..'z'];
Char_AlphaNum : Result := Ch in ['a'..'z', 'A'..'Z', '0'..'9'];
Char_AlphaNumFixed : Result := Ch in ['a'..'z', 'A'..'Z', '0'..'9'];
Char_AlphaNumUpCase : Result := Ch in ['A'..'Z', '0'..'9'];
Char_AlphaNumDownCase : Result := Ch in ['a'..'z', '0'..'9'];
Char_AlphaNumFixedUpCase : Result := Ch in ['A'..'Z', '0'..'9'];
Char_AlphaNumFixedDowncase:Result := Ch in ['a'..'z', '0'..'9'];
//ToDo: make this UTF8 compatible, for now
//limit this to lower ASCII set
Char_All : Result := Ch in [#32..#126]; //True;
Char_AllFixed : Result := Ch in [#32..#126]; //True;
Char_AllUpCase : Result := Ch in [#32..#126]; //True;
Char_AllDownCase : Result := Ch in [#32..#126]; //True;
Char_AllFixedUpCase : Result := Ch in [#32..#126]; //True;
Char_AllFixedDownCase : Result := Ch in [#32..#126]; //True;
Char_Space : Result := Ch in [' ', '_'];
Char_HourSeparator : Result := Ch in [TimeSeparator];
Char_DateSeparator : Result := Ch in [DateSeparator];
end;
end;
// Delete selected chars
procedure TCustomMaskEdit.DeleteSelected;
Var
SelectionStart, SelectionStop, I : Integer;
S : ShortString;
begin
if not HasSelection then Exit;
GetSel(SelectionStart, SelectionStop);
S := Inherited Text;
for i := SelectionStart + 1 to SelectionStop do S[i] := ClearChar(i);
CurrentText := S;
SetInheritedText(S);
SetCursorPos;
end;
// Delete a single char from position
procedure TCustomMaskEdit.DeleteChars(NextChar : Boolean);
begin
if NextChar then
begin//VK_DELETE
if HasSelection then DeleteSelected
else
begin
//cannot delete beyond length of string
if FCursorPos < Length(FMask) then
begin
//This will select the appropriate char in the control
SetCursorPos;
DeleteSelected;
end;
end;
end
else
begin//VK_BACK
//if selected text > 1 char then delete selection
if HasExtSelection then DeleteSelected
else
begin
//cannot backspace if we are at beginning of string
if FCursorPos > 0 then
begin
Dec(FCursorPos);
//This will select the appropriate char in the control
SetCursorPos;
//then delete this char
DeleteSelected;
end;
end;
end;
end;
// Get the actual Text
Function TCustomMaskEdit.GetText : String;
{
Replace al FSPaceChars with #32
If FMaskSave = False the do trimming of spaces and remove all maskliterals
}
var
S: String;
i: Integer;
Begin
if not IsMasked then
begin
Result := InHerited Text;
end
else
begin
S := StringReplace(Inherited Text, FSpaceChar, #32, [rfReplaceAll]);
if not FMaskSave then
begin
for i := 1 to Length(FMask) do
begin
if IsLiteral(FMask[i]) then S[i] := #1; //We know this char can never be in Text, so this is safe
end;
S := StringReplace(S, #1, '', [rfReplaceAll]);
//Trimming only occurs if FMaskSave = False
case FTrimType of
metTrimLeft : S := TrimLeft(S);
metTrimRight: S := TrimRight(S);
end;//case
end;
Result := S;
end;
End;
// Set the actual Text
Procedure TCustomMaskEdit.SetText(Value : String);
{ This mimics Delphi behaviour (D3):
- if mask contains no literals text is set, if necessary padded with blanks
- if mask contains literals then text is set as long as matching literals in the
text to set are avaiable
- Text can not be longer than Length(FMask)
- The text that is set, does not need to match the mask
}
Var
S : ShortString;
I, J : Integer;
MaskHasLiterals: Boolean;
Begin
//Setting Text while loading has unwanted side-effects
if (csLoading in ComponentState) then
begin
FInitialText := Value;
Exit;
end;
if IsMasked then
begin
if (Value = '') then
begin
Clear;
Exit;
end;
MaskHasLiterals := False;
for i := 1 to Length(FMask) do
begin
if IsLiteral(FMask[i]) then
begin
MaskHasLiterals := True;
Break;
end;
end;
if not MaskHasLiterals then
begin
if Length(Value) > Length(FMask) then Value := Copy(Value, 1, Length(FMask));
while (Length(Value) < Length(FMask)) do Value := Value + FSpaceChar;
CurrentText := Value;
SetInheritedText(Value);
Exit;
end;
//First setup a "blank" string that contains all literals in the mask
S := '';
for I := 1 To Length(FMask) do S := S + ClearChar(I);
I := 1;
J := 1;
While (I <= Length(FMask)) and (j <= Length(Value)) do
begin
if not IsLiteral(FMask[I]) then
begin
S[i] := Value[j];
end
else
begin
//search for S[i] in Value
While (S[i] <> Value[j]) and (j < Length(Value)) do Inc(j);
//if not found, make sure we leave the loop
if (S[i] <> Value[j]) then J := Length(Value) + 1;
end;
Inc(i);
Inc(j);
end;
CurrentText := S;
SetInheritedText(S);
end//Ismasked
else
begin//not IsMasked
SetInheritedText(Value);
end;
End;
function TCustomMaskEdit.GetEditText: string;
begin
Result := Inherited Text;
end;
procedure TCustomMaskEdit.SetEditText(const AValue: string);
var
S: String;
begin
if (not IsMasked) then
begin
Inherited Text := AValue;
end
else
begin
//Make sure we don't copy more or less text into the control than FMask allows for
S := Copy(AValue, 1, Length(FMask));
while Length(S) < Length(FMask) do S := S + FSpaceChar;
CurrentText := S;
SetInheritedText(S);
end;
end;
// Respond to Text Changed message
procedure TCustomMaskEdit.TextChanged;
{ Purpose: to avoid messing up the control by
- cut/paste/clear via OS context menu
(we try to catch these messages and hadle them,
but this is not garantueed to work)
- dragging selected text in the control with the mous
If one of these happens, then the internal logic of cursorpositioning,
inserting characters is messed up.
So, we simply restore the text from our backup: CurrenText
}
begin
if not IsMasked then
begin
Inherited TextChanged;
Exit;
end;
if FChangeAllowed then
begin
Inherited TextChanged
end
else
//if not FChangeAllowed then
begin
SetInheritedText(CurrentText);
//Reset cursor to last known position
SetCursorPos;
end;
if (inherited Text = '') then Clear;
end;
procedure TCustomMaskEdit.Loaded;
var
i, j: Integer;
S: String;
begin
inherited Loaded;
if (FInitialMask <> '') then SetMask(FInitialMask);
if IsMasked then
begin
if (FInitialText = '') then
begin
Clear;
Exit;
end;
//First setup a "blank" string that contains all literals in the mask
S := '';
for I := 1 To Length(FMask) do S := S + ClearChar(I);
if Length(FInitialText) > Length(FMask) then FInitialText := Copy(FInitialText, 1, Length(FMask));
while (Length(FInitialText) < Length(FMask)) do
begin
if (not FMaskSave) and (FTrimType = metTrimLeft) then FInitialText := #32 + FInitialText
else FInitialText := FInitialText + #32;
end;
//Now we know FInitalText has same length as FMask
if FMaskSave then
//We simply copy any char from FInitalText that is not a maskliteral
begin
for i := 1 to Length(S) do
begin
if not IsLiteral(FMask[i]) then S[i] := FInitialText[i];
end;
end
else
//Scan FInitalText left to right or right to left and skip all maskliterals
begin
if (FTrimType = metTrimLeft) then
begin
j := Length(S);
for i := Length(S) downto 1 do
begin
if not IsLiteral(FMask[i]) then
begin
S[i] := FInitialText[j];
Dec(j);
end;
end;
end
else
begin
j := 1;
for i := 1 to Length(S) do
begin
if not IsLiteral(FMask[i]) then
begin
S[i] := FInitialText[j];
Inc(j);
end;
end;
end;
end;
S := StringReplace(S, #32, FSpaceChar, [rfReplaceAll]);
CurrentText := S;
SetInheritedText(S);
end//Ismasked
else
begin//not IsMasked
SetInheritedText(FInitialText);
end;
end;
// Respond to Paste message
procedure TCustomMaskEdit.LMPasteFromClip(var Message: TLMessage);
begin
if (not IsMasked) or (ReadOnly) then
begin
Inherited ;
Exit;
end;
//We handle this message ourself
Message.Result := 0;
PasteFromClipBoard;
end;
// Respond to Cut message
procedure TCustomMaskEdit.LMCutToClip(var Message: TLMessage);
begin
if not IsMasked then
begin
inherited;
Exit;
end;
//We handle this message ourself
Message.Result := 0;
CutToClipBoard;
end;
// Respond to Clear message
procedure TCustomMaskEdit.LMClearSel(var Message: TLMessage);
begin
//DebugLn('TCustomMaskEdit.LMClearSel');
if not IsMasked then
begin
inherited;
Exit;
end;
//We handle this message ourself
Message.Result := 0;
DeleteSelected;
end;
function TCustomMaskEdit.EditCanModify: Boolean;
begin
Result := True;
end;
procedure TCustomMaskEdit.Reset;
//Implements an Undo mechanisme from the moment of entering the control
begin
if IsMasked and (not ReadOnly) then
begin
SetinheritedText(FTextOnEnter);
end;
end;
//Moved from CMEnter message handler
procedure TCustomMaskEdit.DoEnter;
begin
inherited DoEnter;
if isMasked then
begin
FCursorPos := GetSelStart;
FTextOnEnter := Inherited Text;
Modified := False;
SetCursorPos;
end;
end;
procedure TCustomMaskEdit.DoExit;
begin
//First give OnExit a change to prevent a EDBEditError
inherited DoExit;
{$IFNDEF NOVALIDATEONEXIT}
if IsMasked and (FTextOnEnter <> Inherited Text) then
begin
ValidateEdit;
end;
{$ENDIF}
end;
// Single key down procedure
procedure TCustomMaskEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
Inherited KeyDown(Key, Shift);
// Not masked -> old procedure
if not IsMasked then
begin
Exit;
end;
FCursorPos := GetSelStart;
// shift and arrowkey -> old procedure
if (ssShift in Shift) then
begin
if (Key = VK_LEFT) or (Key = VK_RIGHT) or
(Key = VK_HOME) or (Key = VK_END) then
begin
Exit;
end;
end;
//Escape Key
if (Key = VK_ESCAPE) and (Shift = []) then
begin
Reset;
Key := 0;
Exit;
end;
//Handle clipboard and delete/backspace keys
if (Key = VK_DELETE) then
begin
if not ReadOnly then
begin
if (Shift = [ssShift]) then
begin//Cut
CutToClipBoard;
end
else if (Shift = [ssCtrl]) then
begin//Clear
DeleteSelected;
end
else if (Shift = []) then
begin//Plain Delete
//DeleteChars also works if SelLength = 0
DeleteChars(True);
end;
Key := 0;
Exit;
end;
end;
if (Key = VK_BACK) then
begin
if not ReadOnly then
begin
if (Shift = [ssCtrl]) then
begin//Clear
DeleteSelected;
end
else
if (Shift = [ssShift]) then
begin
CutToClipBoard;
end
else
if (Shift = []) then
begin
DeleteChars(False);
end;
Key := 0;
Exit;
end;
end;
if (Key = VK_INSERT) then
begin//Copy or Paste
if (Shift = [ssShift]) then
begin//Paste
if not ReadOnly then
begin
PasteFromClipBoard;
end;
end
else if (Shift = [ssCtrl]) then
begin//Copy
CopyToClipBoard;
end;
Key := 0;
Exit;
end;
if (Key = VK_C) and (Shift = [ssCtrl]) then
begin//Copy
CopyToClipBoard;
Key := 0;
Exit;
end;
if (Key = VK_X) and (Shift = [ssCtrl]) then
begin//Cut
if not ReadOnly then
begin
CutToClipBoard;
Key := 0;
Exit;
end;
end;
if (Key = VK_V) and (Shift = [ssCtrl]) then
begin//Paste
if not ReadOnly then
begin
PasteFromClipBoard;
Key := 0;
Exit;
end;
end;
// Cursor movement
//ATM we handle Ctrl+ArrowKey as if it were just ArrowKey
if (Key = VK_LEFT) then
begin
SelectPrevChar;
Key := 0;
Exit;
end;
if (Key = VK_RIGHT) then
begin
SelectNextChar;
Key := 0;
Exit;
end;
if (Key = VK_HOME) then
begin
SelectFirstChar;
Key := 0;
Exit;
end;
if (Key = VK_END) then
begin
GotoEnd;
Key := 0;
Exit;
end;
// Cursor Up/Down -> not valid
if (Key = VK_UP) or (Key = VK_DOWN) then
begin
Key := 0;
Exit;
end;
end;
procedure TCustomMaskEdit.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if (not IsMasked) or ReadOnly then
begin
Exit;
end;
FCursorPos := GetSelStart;
//Moved from KeyDown, which would only handle uppercase chars...
// Insert a char
if (Key In [#32..#255]) then
begin
InsertChar(Key);
//We really need to "eat" all keys we handle ourselves
//(or widgetset will insert char second time)
Key:= #0;
end;
end;
//Moved form LMMButtonUp message handler
procedure TCustomMaskEdit.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if IsMasked then
begin
FCursorPos := GetSelStart;
if not HasSelection then SetCursorPos;
end;
end;
procedure TCustomMaskEdit.CheckCursor;
begin
if IsMasked then
SetCursorPos;
end;
procedure TCustomMaskEdit.CutToClipBoard;
begin
if not IsMasked then
begin
inherited CutToClipBoard;
Exit;
end;
CopyToClipBoard;
DeleteSelected;
end;
procedure TCustomMaskEdit.PasteFromClipBoard;
{
Paste only allowed chars, skip literals in the mask
e.g. if cliptext = '1234' and mask = '00:00' then result will be '12:34'
}
var
ClipText, S: String;
P, i: LongInt;
begin
if not IsMasked then
begin
inherited PasteFromClipBoard;
Exit;
end;
if Clipboard.HasFormat(CF_TEXT) then
begin
ClipText := ClipBoard.AsText;
if (Length(ClipText) > 0) then
begin
P := FCursorPos + 1;
DeleteSelected;
S := Inherited Text;
i := 1;
while (P <= Length(FMask)) do
begin
//Skip any literal
while (P < Length(FMask)) and (IsLiteral(FMask[P])) do Inc(P);
//Skip any char in ClipText that cannot be inserted at current position
while (i < Length(ClipText)) and (not CanInsertChar(P, ClipText[i])) do Inc(i);
if CanInsertChar(P, ClipText[i]) then
begin
S[P] := ClipText[i];
Inc(P);
Inc(i);
end
else
Break;
end;
CurrentText := S;
SetInheritedText(S);
SetCursorPos;
end;
end;
end;
// Clear the controll
procedure TCustomMaskEdit.Clear;
Var
S : ShortString;
I : Integer;
begin
if isMasked then
begin
S := '';
for I := 1 To Length(FMask) do S := S + ClearChar(I);
CurrentText := S;
SetinheritedText(S);
FCursorPos := 0;
SetCursorPos;
end
else Inherited Clear;
end;
procedure TCustomMaskEdit.ValidateEdit;
var
S: String;
_MaskSave: Boolean;
begin
//Only validate if IsMasked
if IsMasked then
begin
{
if FMaskSave = False then literal and spaces are trimmed from Text
and TextIsValid might wrongly return False
We need the text with literals and FSpaceChar translated to #32
}
_MaskSave := FMaskSave;
FMaskSave := True;
S := Text;
FMaskSave := _MaskSave;
if not TextIsValid(S) then
begin
SetFocus;
SetCursorPos;
Raise EDBEditError.Create(SMaskEditNoMatch);
//DebugLn('TCustomMaskEdit.Validate: The current text does not match the the specified mask');
end;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink