1{ 2 /*************************************************************************** 3 maskedit.pp 4 ----------- 5 Component Library Code 6 7 ***************************************************************************/ 8 9 ***************************************************************************** 10 This file is part of the Lazarus Component Library (LCL) 11 12 See the file COPYING.modifiedLGPL.txt, included in this distribution, 13 for details about the license. 14 ***************************************************************************** 15} 16 17 18{ 19ToDo List: 20 - Better handling of cut/clear/paste messages 21 22Bugs: 23 - The Delphi helpt text says that a '_' in EditMask will insert a blank in the text. 24 However all versions of Delphi up to D2010 treat it as a literal '_' (unless 25 specified in the 3rd field of a multifield EditMask), so I rewrote parts to make it behave like 26 that also. 27 If, in the future, Delphi actually treats '_' as a blank, we'll re-implement it, for that 28 purpose I did not remove the concerning code, but commented it out 29 30Known Utf8 related issues: (Oktober 2012, BB) 31 - Utf8 also has what is called de-composed code-points: 32 For example the "LATIN SMALL LETTER E WITH DIAERESIS" can be represented with a single codepoint 33 (U+00EB), but also by the sequence of codepoints LATIN SMALL LETTER E (U+0065) + COMBINING DIAERESIS (U+0308) 34 The latter form is not handled correctly ATM, but also does not occur much "in the wild" 35 (See discussion at the forum: http://forum.lazarus.freepascal.org/index.php/topic,10530.0.html) 36 - Some valid Utf8 sequences do not represent any visible character. 37 I have not been able to test how this affects the maskedit unit. 38 39 40Different behaviour than Delphi, but by design (October 2009, BB) 41 - In SetText in Delphi, when MaskNoSave is in EditMask, it is possible to set text longer then the mask 42 allowes for. I disallowed that, because it corrupts internal cursor placement etc. 43 - SetEditText is not Delphi compatible. Delphi allows setting any text in the control, leaving the control 44 in an unrecoverable state, where it is impossible to leave the control because the text can never be validated 45 (too short, too long, overwritten maskliterals). The app wil crash as a result of this. 46 I have decided to disallow this: 47 - EditText is truncated, or padded with ClearChar if necessary so that Utf8Length(EditText) = FMaskLength 48 - Restore all MaskLiterals in the text 49} 50 51unit MaskEdit; 52 53{$mode objfpc}{$H+} 54 55interface 56 57uses 58 Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, 59 ExtCtrls, StdCtrls, LMessages, Clipbrd, LCLType, LCLProc, LCLStrConsts, LazUtf8; 60 61const 62 { Mask Type } 63 cMask_SpecialChar = '\'; // after this you can set an arbitrary char 64 cMask_UpperCase = '>'; // after this the chars is in upper case 65 cMask_LowerCase = '<'; // after this the chars is in lower case 66 cMask_Letter = 'l'; // only a letter but not necessary 67 cMask_LetterFixed = 'L'; // only a letter 68 cMask_AlphaNum = 'a'; // an alphanumeric char (['A'..'Z','a..'z','0'..'9']) but not necessary 69 cMask_AlphaNumFixed = 'A'; // an alphanumeric char 70 cMask_AllChars = 'c'; // any Utf8 char but not necessary 71 cMask_AllCharsFixed = 'C'; // any Utf8 char #32 - #255 72 cMask_Number = '9'; // only a number but not necessary 73 cMask_NumberFixed = '0'; // only a number 74 cMask_NumberPlusMin = '#'; // only a number or + or -, but not necessary 75 cMask_HourSeparator = ':'; // automatically put the hour separator char 76 cMask_DateSeparator = '/'; // automatically but the date separator char 77{ cMask_SpaceOnly = '_'; // automatically put a space //not Delphi compatible } 78 cMask_NoLeadingBlanks = '!'; //Trim leading blanks, otherwise trim trailing blanks from the data 79 80 {Delphi compatibility: user can change these at runtime} 81 DefaultBlank: Char = '_'; 82 MaskFieldSeparator: Char = ';'; 83 MaskNoSave: Char = '0'; 84 85type 86 { Type for mask (internal) } 87 tMaskedType = (Char_Start, 88 Char_Number, 89 Char_NumberFixed, 90 Char_NumberPlusMin, 91 Char_Letter, 92 Char_LetterFixed, 93 Char_LetterUpCase, 94 Char_LetterDownCase, 95 Char_LetterFixedUpCase, 96 Char_LetterFixedDownCase, 97 Char_AlphaNum, 98 Char_AlphaNumFixed, 99 Char_AlphaNumUpCase, 100 Char_AlphaNumDownCase, 101 Char_AlphaNumFixedUpCase, 102 Char_AlphaNumFixedDownCase, 103 Char_All, 104 Char_AllFixed, 105 Char_AllUpCase, 106 Char_AllDownCase, 107 Char_AllFixedUpCase, 108 Char_AllFixedDownCase, 109 {Char_Space, //not Delphi compatible, see notes above } 110 Char_HourSeparator, 111 Char_DateSeparator, 112 Char_Stop); 113 114 115 TInternalMask = array[1..255] of TUtf8Char; 116 TMaskeditTrimType = (metTrimLeft, metTrimRight); 117 118 { Exception class } 119type 120 EDBEditError = class(Exception); 121 //Utf8 handling errors 122 EInvalidUtf8 = class(Exception); 123 EInvalidCodePoint = class(EInvalidUtf8); 124 125const 126 SInvalidCodePoint = 'The (hexadecimal) sequence %s is not a valid UTF8 codepoint.'; 127 128 129{ *********************************************************************************************** 130 131 Please leave in this note until it no longer applies! 132 133 FOR ANYONE WHO CARES TO FIX/ENHANCE THIS CODE: 134 135 Since we want total control over anything that is done to the text in the control 136 we have to take into consideration the fact that currently we cannot prevent 137 cutting/pasting/clearing or dragging selected text in the control, these are handled by the OS 138 and text is changed before we can prevent it. 139 Not all widgetsets currently handle the messages for cut/paste/clear. Actually we would 140 like to have a LM_BEFORE_PASTE (etc.) message... 141 If we allow the OS to cut/clear/paste etc. a situation can occur where mask-literals in the 142 control are changed with random chars (and cannot be undone) or text is shorter or larger than 143 the editmask calls for, which again cannot be undone. 144 145 146 So, as a horrible hack I decided to only allow changing of the text if we coded 147 this change ourself. This is done by setting the FChangeAllowed field to True before any 148 write action (in RealSetTextWhileMasked() ). 149 We try to intercept the messages for cut/paste/copy/clear and perform the appropriate 150 actions instead. 151 If this fails, then in TextChanged we check and will see that FChangeAllowed = False 152 and we will undo the changes made. 153 154 To make this undo possible it is necessary to set FCurrentText every time you set 155 the text in the control! 156 This is achieved in RealSetTextWhileMasked() only, so please note: 157 !! It is unsafe to make a call to RealSetText unless done so via RealSetTextWhileMasked() !!! 158 159 (Bart Broersma, januari 2009) 160 161 ************************************************************************************************ } 162 163 164 { TCustomMaskEdit } 165 166 Type 167 168 TCustomMaskEdit = Class(TCustomEdit) 169 private 170 FRealMask : String; // Real mask inserted 171 FMask : TInternalMask; // Actual internal mask 172 FMaskLength : Integer; // Length of internal mask 173 FFirstFreePos : Integer; // First position where user can enter text 174 FMaskSave : Boolean; // Save mask as part of the data 175 FTrimType : TMaskEditTrimType; // Trim leading or trailing spaces in GetText 176 FSpaceChar : Char; // Char for space (default '_') 177 FCurrentText : TCaption; // FCurrentText is our backup. See notes above! 178 FTextOnEnter : String; // Text when user enters the control, used for Reset() 179 FCursorPos : Integer; // Current caret position 180 FChangeAllowed : Boolean; // We do not allow text changes by the OS (cut/clear via context menu) 181 FInitialText : String; // Text set in the formdesigner (must be handled in Loaded) 182 FInitialMask : String; // EditMask set in the formdesigner (must be handled in Loaded) 183 FSettingInitialText: Boolean; 184 FValidationFailed: Boolean; // Flag used in DoEnter 185 FMaskIsPushed : Boolean; 186 FSavedMask : TInternalMask; 187 FSavedMaskLength : Integer; 188 FTextChangedBySetText: Boolean; 189 FInRealSetTextWhileMasked: Boolean; 190 191 procedure ClearInternalMask(out AMask: TInternalMask; out ALengthIndicator: Integer); 192 procedure AddToMask(Value: TUtf8Char); 193 function GetModified: Boolean; 194 procedure SetMask(Value : String); 195 function GetIsMasked : Boolean; 196 procedure SetModified(AValue: Boolean); 197 procedure SetSpaceChar(Value : Char); 198 199 procedure SetCursorPos; 200 procedure SelectNextChar; 201 procedure SelectPrevChar; 202 procedure SelectFirstChar; 203 procedure GotoEnd; 204 procedure JumpToNextDot(Dot: Char); 205 function HasSelection: Boolean; 206 function HasExtSelection: Boolean; 207 208 Function CharToMask(UCh : TUtf8Char) : tMaskedType; 209 Function MaskToChar(Value : tMaskedType) : Char; 210 Function IsMaskChar(Ch : TUtf8Char) : Boolean; 211 Function IsLiteral(Ch: TUtf8Char): Boolean; 212 function TextIsValid(const Value: String): Boolean; 213 function CharMatchesMask(const Ch: TUtf8Char; const Position: Integer): Boolean; 214 function ClearChar(Position : Integer) : TUtf8Char; 215 216 procedure RealSetTextWhileMasked(const Value: TCaption); //See notes above! 217 procedure InsertChar(Ch : TUtf8Char); 218 Function CanInsertChar(Position : Integer; Var Ch : TUtf8Char; IsPasting: Boolean = False) : Boolean; 219 procedure DeleteSelected; 220 procedure DeleteChars(NextChar : Boolean); 221 protected 222 function ApplyMaskToText(Value: TCaption): TCaption; 223 function CanShowEmulatedTextHint: Boolean; override; 224 function DisableMask(const NewText: String): Boolean; 225 function RestoreMask(const NewText: String): Boolean; 226 procedure RealSetText(const AValue: TCaption); override; 227 function RealGetText: TCaption; override; 228 Function GetTextWithoutMask(Value: TCaption) : TCaption; 229 function GetTextWithoutSpaceChar(Value: TCaption) : TCaption; 230 Procedure SetTextApplyMask(Value: TCaption); 231 function GetEditText: string; virtual; 232 procedure SetEditText(const AValue: string); 233 234 procedure GetSel(out _SelStart: Integer; out _SelStop: Integer); 235 procedure SetSel(const _SelStart: Integer; _SelStop: Integer); 236 procedure TextChanged; override; 237 procedure Change; override; 238 procedure SetCharCase(Value: TEditCharCase); 239 function GetCharCase: TEditCharCase; 240 procedure SetMaxLength(Value: Integer); 241 function GetMaxLength: Integer; 242 procedure SetNumbersOnly(Value: Boolean); override; 243 procedure Loaded; override; 244 245 procedure LMPasteFromClip(var Message: TLMessage); message LM_PASTE; 246 procedure LMCutToClip(var Message: TLMessage); message LM_CUT; 247 procedure LMClearSel(var Message: TLMessage); message LM_CLEAR; 248 249 function EditCanModify: Boolean; virtual; 250 procedure Reset; virtual; 251 procedure DoEnter; override; 252 procedure DoExit; override; 253 procedure KeyDown(var Key: Word; Shift: TShiftState); override; 254 procedure HandleKeyPress(var Key: TUtf8Char); 255 procedure KeyPress(var Key: Char); override; 256 procedure Utf8KeyPress(var UTF8Key: TUTF8Char); override; 257 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; 258 259 procedure CheckCursor; 260 property EditText: string read GetEditText write SetEditText; 261 property IsMasked: Boolean read GetIsMasked; 262 property SpaceChar: Char read FSpaceChar write SetSpaceChar; 263 property MaxLength: Integer read GetMaxLength write SetMaxLength; 264 property CharCase: TEditCharCase read GetCharCase write SetCharCase; 265 property EditMask: string read FRealMask write SetMask; 266 public 267 procedure CutToClipBoard; override; 268 procedure PasteFromClipBoard; override; 269 { Required methods } 270 constructor Create(TheOwner : TComponent); override; 271 procedure Clear; 272 procedure ValidateEdit; virtual; 273 property Modified: Boolean read GetModified write SetModified; 274 end; 275 276 { TMaskEdit } 277 278 TMaskEdit = class(TCustomMaskEdit) 279 public 280 property IsMasked; 281 property EditText; 282 published 283 property Align; 284 property Alignment; 285 property Anchors; 286 property AutoSelect; 287 property AutoSize; 288 property BiDiMode; 289 property BorderSpacing; 290 property BorderStyle; 291 property CharCase; 292 property Color; 293 property Constraints; 294 property DragCursor; 295 property DragKind; 296 property DragMode; 297 property Enabled; 298 property Font; 299 property MaxLength; 300 property ParentBiDiMode; 301 property ParentColor; 302 property ParentFont; 303 property ParentShowHint; 304 property PopupMenu; 305 property ReadOnly; 306 property ShowHint; 307 property TabOrder; 308 property TabStop; 309 property Visible; 310 property OnChange; 311 property OnClick; 312 property OnDblClick; 313 property OnDragDrop; 314 property OnDragOver; 315 property OnEditingDone; 316 property OnEndDock; 317 property OnEndDrag; 318 property OnEnter; 319 property OnExit; 320 property OnKeyDown; 321 property OnKeyPress; 322 property OnKeyUp; 323 property OnMouseDown; 324 property OnMouseEnter; 325 property OnMouseLeave; 326 property OnMouseMove; 327 property OnMouseUp; 328 property OnMouseWheel; 329 property OnMouseWheelDown; 330 property OnMouseWheelUp; 331 property OnStartDock; 332 property OnStartDrag; 333 property OnUTF8KeyPress; 334 property EditMask; 335 property Text; 336 property TextHint; 337 property SpaceChar; 338 end; 339 340function FormatMaskText(const AEditMask: string; const Value: string ): string; 341procedure SplitEditMask(AEditMask: String; out AMaskPart: String; out AMaskSave: Boolean; out ASpaceChar: Char); 342 343procedure Register; 344 345implementation 346 347 348//Define this to prevent validation when the control looses focus 349{ $DEFINE MASKEDIT_NOVALIDATEONEXIT} 350 351{$ifdef debug_maskedit} 352// For debugging purposes only 353const 354 MaskCharToChar: array[tMaskedType] of Char = (#0, cMask_Number, cMask_NumberFixed, cMask_NumberPlusMin, 355 cMask_Letter, cMask_LetterFixed, cMask_Letter, cMask_Letter, cMask_LetterFixed, cMask_LetterFixed, 356 cMask_AlphaNum, cMask_AlphaNumFixed, cMask_AlphaNum, cMask_AlphaNum, cMask_AlphaNumFixed, cMask_AlphaNumFixed, 357 cMask_AllChars, cMask_AllCharsFixed, cMask_AllChars, cMask_AllChars, cMask_AllCharsFixed, cMask_AllCharsFixed, 358 (*cMask_SpaceOnly,*) cMask_HourSeparator, cMask_DateSeparator, #0); 359{$endif} 360 361const 362 Period = '.'; 363 Comma = ','; 364 365//Utf8 helper functions 366 367function GetCodePoint(const S: String; const Index: PtrInt): TUTF8Char; 368//equivalent for Result := S[Index], but for Utf8 encoded strings 369var 370 p: PChar; 371 PLen: PtrInt; 372 Res: AnsiString; //intermediate needed for PChar -> String -> ShortString assignement 373begin 374 Result := ''; 375 p := UTF8CodepointStart(PChar(S), Length(S), Index - 1); //zero-based call 376 //determine the length in bytes of this UTF-8 character 377 PLen := UTF8CodepointSize(p); 378 Res := p; 379 //Set correct length for Result (otherwise it returns all chars up to the end of the original string) 380 SetLength(Res,PLen); 381 Result := Res; 382end; 383 384function StringToHex(S: String): String; 385var 386 i: Integer; 387begin 388 Result := ''; 389 for i := 1 to length(S) do Result := Result + '$' + IntToHex(Ord(S[i]),2); 390end; 391 392procedure SetCodePoint(var S: String; const Index: PtrInt; CodePoint: TUTF8Char); 393//equivalent for S[Index] := CodePoint, but for Utf8 encoded strings 394var 395 OldCP: TUTF8Char; 396begin 397 if (Index > Utf8Length(S)) then Exit; 398 if (Utf8Length(CodePoint) <> 1) then Raise EInvalidCodePoint.Create(Format(SInvalidCodepoint,[StringToHex(CodePoint)])); 399 OldCP := GetCodePoint(S, Index); 400 if (OldCP = CodePoint) then Exit; 401 Utf8Delete(S, Index, 1); 402 Utf8Insert(CodePoint, S, Index); 403end; 404 405 406 407function FormatMaskText(const AEditMask: string; const Value: string): string; 408var 409 CME: TCustomMaskEdit; 410begin 411 CME := TCustomMaskEdit.Create(nil); 412 try 413 CME.EditMask := AEditMask; 414 if CME.IsMasked then 415 begin 416 Result := CME.ApplyMaskToText(Value); 417 //Delphi 7 leaves in the mask regardless of the "MaskSave" value in the specified EditMaske 418 //but SpaceChar must be replaced by #32 419 Result := CME.GetTextWithoutSpaceChar(Result); 420 end 421 else 422 Result := Value; 423 finally 424 CME.Free; 425 end; 426end; 427 428procedure SplitEditMask(AEditMask: String; out AMaskPart: String; out AMaskSave: Boolean; out ASpaceChar: Char); 429{ 430 Retrieve the separate fields for a given EditMask: 431 Given an AEditMask of '999.999;0;_' it will return 432 - AMaskPart = '999.999' 433 - AMaskSave = False 434 - ASpaceChar = '_' 435} 436begin 437 { 438 First see if AEditMask is multifield and if we can extract a value for 439 AMaskSave and/or ASpaceChar 440 If so, extract and remove from AMask (so we know that the remaining part of 441 AMask _IS_ the mask to be set) 442 443 A value for SpaceChar is only valid if also a value for MaskSave is specified 444 (as by Delphi specifications), so Mask must be at least 4 characters 445 These must be the last 2 or 4 characters of EditMask (and there must not be 446 an escape character in front!) 447 } 448 //Assume no SpaceChar and no MaskSave is defined in new mask, so first set it to DefaultBlank and True 449 ASpaceChar := DefaultBlank; 450 AMaskSave := True; 451 //MaskFieldseparator, MaskNoSave, SpaceChar and cMask_SpecialChar are defined as Char (=AnsiChar) 452 //so in this case we can use Length (instead of Utf8length) and iterate single chars in the string 453 if (Length(AEditMask) >= 4) and (AEditMask[Length(AEditMask)-1] = MaskFieldSeparator) and 454 (AEditMask[Length(AEditMask)-3] = MaskFieldSeparator) and 455 (AEditMask[Length(AEditMask)-2] <> cMask_SpecialChar) and 456 //Length = 4 is OK (AEditMask = ";1;_" for example), but if Length > 4 there must be no escape charater in front 457 ((Length(AEditMask) = 4) or ((Length(AEditMask) > 4) and (AEditMask[Length(AEditMask)-4] <> cMask_SpecialChar))) then 458 begin 459 ASpaceChar := AEditMask[Length(AEditMask)]; 460 AMaskSave := (AEditMask[Length(AEditMask)-2] <> MaskNosave); 461 System.Delete(AEditMask,Length(AEditMask)-3,4); 462 end 463 //If not both FMaskSave and FSPaceChar are specified, then see if only FMaskSave is specified 464 else if (Length(AEditMask) >= 2) and (AEditMask[Length(AEditMask)-1] = MaskFieldSeparator) and 465 //Length = 2 is OK, but if Length > 2 there must be no escape charater in front 466 ((Length(AEditMask) = 2) or ((Length(AEditMask) > 2) and (AEditMask[Length(AEditMask)-2] <> cMask_SpecialChar))) then 467 begin 468 AMaskSave := (AEditMask[Length(AEditMask)] <> MaskNoSave); 469 //Remove this bit from Mask 470 System.Delete(AEditMask,Length(AEditMask)-1,2); 471 end; 472 //Whatever is left of AEditMask at this point is the MaskPart 473 AMaskPart := AEditMask; 474end; 475 476 477// Create object 478constructor TCustomMaskEdit.Create(TheOwner: TComponent); 479begin 480 FSettingInitialText := False; 481 FTextChangedBySetText := False; 482 FInRealSetTextWhileMasked := False; 483 FRealMask := ''; 484 ClearInternalMask(FMask, FMaskLength); 485 ClearInternalMask(FSavedMask, FSavedMaskLength); 486 FSpaceChar := '_'; 487 FMaskSave := True; 488 FChangeAllowed := False; 489 FTrimType := metTrimRight; 490 Inherited Create(TheOwner); 491 FCurrentText := Inherited RealGetText; 492 FTextOnEnter := Inherited RealGetText; 493 FInitialText := ''; 494 FInitialMask := ''; 495 FValidationFailed := False; 496 FMaskIsPushed := False; 497end; 498 499procedure TCustomMaskEdit.ClearInternalMask(out AMask: TInternalMask; out ALengthIndicator: Integer); 500begin 501 {$PUSH}{$HINTS OFF} 502 FillChar(AMask, SizeOf(TInternalMask), 0); 503 ALengthIndicator := 0; 504 {$POP} 505end; 506 507procedure TCustomMaskEdit.AddToMask(Value: TUtf8Char); 508begin 509 Inc(FMaskLength); 510 FMask[FMaskLength] := Value; 511end; 512 513function TCustomMaskEdit.GetModified: Boolean; 514begin 515 //This will make Modified = False inside OnChange when text is set by code 516 //TCustomEdit.RealSetText sets Modified to False. 517 //We handle all input in RealSetTextWhileMasked (which eventually calls RealSetText), 518 //so inside RealSetTextWhileMasked Modified must be True, 519 //unless we called RealSetTextWhileMasked from SetTextApplyMask, in that case it must be False, 520 //in all other cases just return inherited value 521 if FTextChangedBySetText then 522 Result := False 523 else 524 begin 525 if FInRealSetTextWhileMasked then 526 Result := True 527 else 528 Result := inherited Modified; 529 end; 530end; 531 532// Prepare the real internal Mask 533procedure TCustomMaskEdit.SetMask(Value : String); 534Var 535 S : ShortString; 536 I : Integer; 537 InUp, InDown : Boolean; 538 Special : Boolean; 539 CP : TUtf8Char; 540begin 541 //Setting Mask while loading has unexpected and unwanted side-effects 542 if (csLoading in ComponentState) then 543 begin 544 FInitialMask := Value; 545 Exit; 546 end; 547 if FRealMask <> Value then 548 begin 549 FRealMask := Value; 550 FValidationFailed := False; 551 FMaskIsPushed := False; 552 ClearInternalMask(FMask, FMaskLength); 553 ClearInternalMask(FSavedMask, FSavedMaskLength); 554 555 SplitEditMask(FRealMask, Value, FMaskSave, FSpaceChar); 556 557 // Construct Actual Internal Mask 558 // init 559 FTrimType := metTrimRight; 560 // Init: No UpCase, No LowerCase, No Special Char 561 InUp := False; 562 InDown := False; 563 Special := False; 564 S := Value; 565 for I := 1 To Utf8Length(S) do 566 begin 567 CP := GetCodePoint(S,I); 568 // Must insert a special char 569 if Special then 570 begin 571 AddToMask(CP); 572 Special := False; 573 end 574 else 575 begin 576 // Check the char to insert 577 578 case CP Of 579 cMask_SpecialChar: Special := True; 580 cMask_UpperCase: begin 581 if (I > 1) and (GetCodePoint(S,I-1) = cMask_LowerCase) then 582 begin// encountered <>, so no case checking after this 583 InUp := False; 584 InDown := False 585 end else 586 begin 587 InUp := True; 588 InDown := False; 589 end; 590 end; 591 592 cMask_LowerCase: begin 593 InDown := True; 594 InUp := False; 595 // <> is catched by next cMask_Uppercase 596 end; 597 598 cMask_Letter: begin 599 if InUp 600 then 601 AddToMask(MaskToChar(Char_LetterUpCase)) 602 else 603 if InDown 604 then 605 AddToMask(MaskToChar(Char_LetterDownCase)) 606 else 607 AddToMask(MaskToChar(Char_Letter)) 608 end; 609 610 cMask_LetterFixed: begin 611 if InUp 612 then 613 AddToMask(MaskToChar(Char_LetterFixedUpCase)) 614 else 615 if InDown 616 then 617 AddToMask(MaskToChar(Char_LetterFixedDownCase)) 618 else 619 AddToMask(MaskToChar(Char_LetterFixed)) 620 end; 621 622 cMask_AlphaNum: begin 623 if InUp 624 then 625 AddToMask(MaskToChar(Char_AlphaNumUpcase)) 626 else 627 if InDown 628 then 629 AddToMask(MaskToChar(Char_AlphaNumDownCase)) 630 else 631 AddToMask(MaskToChar(Char_AlphaNum)) 632 end; 633 634 cMask_AlphaNumFixed: begin 635 if InUp 636 then 637 AddToMask(MaskToChar(Char_AlphaNumFixedUpcase)) 638 else 639 if InDown 640 then 641 AddToMask(MaskToChar(Char_AlphaNumFixedDownCase)) 642 else 643 AddToMask(MaskToChar(Char_AlphaNumFixed)) 644 end; 645 646 cMask_AllChars: begin 647 if InUp 648 then 649 AddToMask(MaskToChar(Char_AllUpCase)) 650 else 651 if InDown 652 then 653 AddToMask(MaskToChar(Char_AllDownCase)) 654 else 655 AddToMask(MaskToChar(Char_All)) 656 end; 657 658 cMask_AllCharsFixed: begin 659 if InUp 660 then 661 AddToMask(MaskToChar(Char_AllFixedUpCase)) 662 else 663 if InDown 664 then 665 AddToMask(MaskToChar(Char_AllFixedDownCase)) 666 else 667 AddToMask(MaskToChar(Char_AllFixed)) 668 end; 669 670 cMask_Number: AddToMask(MaskToChar(Char_Number)); 671 672 cMask_NumberFixed: AddToMask(MaskToChar(Char_NumberFixed)); 673 674 cMask_NumberPlusMin: AddToMask(MaskToChar(Char_NumberPlusMin)); 675 676 cMask_HourSeparator: AddToMask(MaskToChar(Char_HourSeparator)); 677 678 cMask_DateSeparator: AddToMask(MaskToChar(Char_DateSeparator)); 679 680 {cMask_SpaceOnly: AddToMask(MaskToChar(Char_Space)); //not Delphi compatible, see remarks above} 681 682 cMask_NoLeadingBlanks: 683 begin 684 FTrimType := metTrimLeft; 685 end; 686 687 else 688 begin 689 //It's a MaskLiteral 690 AddToMask(CP); 691 end; 692 end; 693 end; 694 end; 695 FFirstFreePos := 1; 696 //Determine first position where text can be entered (needed for DeleteChars() 697 while (FFirstFreePos <= FMaskLength) and IsLiteral(FMask[FFirstFreePos]) do Inc(FFirstFreePos); 698 if (FMaskLength > 0) then 699 begin 700 SetCharCase(ecNormal); 701 SetNumbersOnly(False); 702 end; 703 //SetMaxLegth must be before Clear, otherwise Clear uses old MaxLength value! 704 SetMaxLength(FMaskLength); 705 Clear; 706 FTextOnEnter := inherited RealGetText; 707 end; 708end; 709 710 711// Return if mask is selected 712function TCustomMaskEdit.GetIsMasked : Boolean; 713begin 714 Result := (FMaskLength > 0); 715end; 716 717procedure TCustomMaskEdit.SetModified(AValue: Boolean); 718begin 719 inherited Modified := AValue; 720end; 721 722 723// Set the current Space Char 724procedure TCustomMaskEdit.SetSpaceChar(Value : Char); 725Var 726 S : String; 727 I : Integer; 728 OldValue: TUtf8Char; 729Begin 730 if (Value <> FSpaceChar) And 731 ((Not IsMaskChar(Value)) {or (CharToMask(Value) = Char_Space)}) then 732 begin 733 OldValue := FSpaceChar; 734 FSpaceChar := Value; 735 if IsMasked then 736 begin 737 S := inherited RealGetText; 738 for I := 1 to Utf8Length(S) do 739 begin 740 if (GetCodePoint(S,i) = OldValue) and (not IsLiteral(FMask[i])) then SetCodePoint(S,i,FSpaceChar); 741 //also update FTextOnEnter to reflect new SpaceChar! 742 if (GetCodePoint(FTextOnEnter,i) = OldValue) and (not IsLiteral(FMask[i])) then SetCodePoint(FTextOnEnter,i,FSpaceChar); 743 end; 744 //FCurrentText := S; 745 RealSetTextWhileMasked(S); 746 CheckCursor; 747 end; 748 end; 749end; 750 751 752 753 754// Set the cursor position and select the char in the control 755procedure TCustomMaskEdit.SetCursorPos; 756begin 757 //no need to do this when in designmode, it actually looks silly if we do 758 if not (csDesigning in ComponentState) then 759 begin 760 if FCursorPos < 0 then FCursorPos := 0 761 else if FCursorPos > FMaskLength then FCursorPos := FMaskLength; 762 if (FCursorPos + 1 > FMaskLength) or not Focused then 763 SetSel(FCursorPos, FCursorPos) 764 else 765 SetSel(FCursorPos, FCursorPos + 1); 766 end; 767end; 768 769//Move to next char, skip any mask-literals 770procedure TCustomMaskEdit.SelectNextChar; 771begin 772 if (FCursorPos + 1) > FMaskLength then Exit; 773 Inc(FCursorPos); 774 While (FCursorPos + 1 < FMaskLength) and (IsLiteral(FMask[FCursorPos + 1])) do 775 begin 776 Inc(FCursorPos); 777 end; 778 if IsLiteral(FMask[FCursorPos + 1]) then Inc(FCursorPos); 779 SetCursorPos; 780end; 781 782//Move to previous char, skip any mask-literals 783procedure TCustomMaskEdit.SelectPrevChar; 784var 785 P: LongInt; 786 AStart: Integer; 787 AStop: Integer; 788begin 789 GetSel(AStart, AStop); 790 if (FCursorPos = 0) and (AStop - AStart <= 1) then Exit; 791 P := FCursorPos; 792 Dec(FCursorPos); 793 While (FCursorPos > 0) and IsLiteral(FMask[FCursorPos + 1]) do 794 begin 795 Dec(FCursorPos); 796 end; 797 if (FCursorPos = 0) and (P <> 0) and IsLiteral(FMask[FCursorPos + 1]) then FCursorPos := P; 798 SetCursorPos; 799end; 800 801 802procedure TCustomMaskEdit.SelectFirstChar; 803begin 804 FCursorPos := 0; 805 SetCursorPos; 806end; 807 808procedure TCustomMaskEdit.GotoEnd; 809begin 810 FCursorPos := FMaskLength; 811 SetCursorPos; 812end; 813 814//Jump to next period or comma if possible, otherwise do nothing 815procedure TCustomMaskEdit.JumpToNextDot(Dot: Char); 816{ 817 Jumping occurs only if 818 - Dot must be in the mask 819 - There is a Dot after the current cursorposition 820 - If the mask contains both periods and comma's, only the first one 821 is jumpable 822 - There is no literal after the next dot 823 - The next dot is not the last character in the mask 824} 825 function MaskPos(Sub: TUtf8Char; Start: Integer): Integer; 826 var 827 i: Integer; 828 begin 829 Result := 0; 830 for i := Start to FMaskLength do 831 begin 832 if (FMask[i] = Sub) then 833 begin 834 Result := i; 835 exit; 836 end; 837 end; 838 end; 839 840var 841 HasNextDot, HasCommaAndPeriod, CanJump: Boolean; 842 P, P2: Integer; 843begin 844 if not (Dot in [Period, Comma]) then Exit; 845 P := MaskPos(Dot, FCursorPos + 1); 846 HasNextDot := P > 0; 847 If (Dot = Period) then 848 begin 849 P2 := MaskPos(Comma, 1); 850 HasCommaAndPeriod := HasNextDot and (P2 >0) 851 end 852 else 853 begin 854 P2 := MaskPos(Period, 1); 855 HasCommaAndPeriod := HasNextDot and (P2 >0); 856 end; 857 if HasCommaAndPeriod then 858 begin 859 //When mask has both period and comma only the first occurence is jumpable 860 if P2 < P then HasNextDot := False; 861 end; 862 CanJump := HasNextDot and (P < FMaskLength) and (not IsLiteral(FMask[P+1])); 863 if CanJump then 864 begin 865 FCursorPos := P; 866 SetCursorPos; 867 end; 868end; 869 870function TCustomMaskEdit.HasSelection: Boolean; 871begin 872 Result := (GetSelLength() > 0); 873end; 874 875//Return True if Selection > 1, this influences the handling of Backspace 876function TCustomMaskEdit.HasExtSelection: Boolean; 877begin 878 Result := (GetSelLength() > 1); 879end; 880 881 882// Get the current selection 883procedure TCustomMaskEdit.GetSel(out _SelStart: Integer; out _SelStop: Integer); 884begin 885 _SelStart:= GetSelStart(); 886 _SelStop:= _SelStart + GetSelLength(); 887end; 888 889// Set the current selection 890procedure TCustomMaskEdit.SetSel(const _SelStart: Integer; _SelStop: Integer); 891begin 892 //in GTK if SelLength <> 0 then setting SelLength also changes SelStart 893 SetSelLength(0); 894 SetSelStart(_SelStart); 895 SetSelLength(_SelStop - _SelStart); 896end; 897 898 899// Transform a single char in a MaskType 900function TCustomMaskEdit.CharToMask(UCh: TUtf8Char): tMaskedType; 901var 902 Ch: Char; 903Begin 904 Result := Char_Start; 905 if (Length(UCh) <> 1) then exit; 906 Ch := UCh[1]; 907 if (Ord(Ch) > Ord(Char_Start)) and 908 (Ord(Ch) < Ord(Char_Stop) ) 909 then 910 Result := tMaskedType(Ord(Ch)); 911End; 912 913 914// Trasform a single MaskType into a char 915function TCustomMaskEdit.MaskToChar(Value: tMaskedType): Char; 916Begin 917 Result := Char(Ord(Value)); 918End; 919 920 921// Return if the char passed is a valid MaskType char 922function TCustomMaskEdit.IsMaskChar(Ch: TUtf8Char): Boolean; 923Begin 924 Result := (CharToMask(Ch) <> Char_Start); 925End; 926 927 928//Return if the char passed is a literal (so it cannot be altered) 929function TCustomMaskEdit.IsLiteral(Ch: TUtf8Char): Boolean; 930begin 931 Result := (not IsMaskChar(Ch)) or 932 (IsMaskChar(Ch) and (CharToMask(Ch) in [Char_HourSeparator, Char_DateSeparator{, Char_Space}])) 933end; 934 935 936//Return if Value matches the EditMask 937function TCustomMaskEdit.TextIsValid(const Value: String): Boolean; 938var 939 i: Integer; 940begin 941 Result := False; 942 if (Utf8Length(Value) <> FMaskLength) then 943 begin 944 //DebugLn(' Utf8Length(Value) = ',DbgS(Utf8Length(Value)),' FMaskLength = ',DbgS(FMaskLength)); 945 Exit; //Actually should never happen?? 946 end; 947 for i := 1 to FMaskLength do 948 begin 949 if not CharMatchesMask(GetCodePoint(Value, i), i) then Exit; 950 end; 951 Result := True; 952end; 953 954 955function TCustomMaskEdit.CharMatchesMask(const Ch: TUtf8Char; const Position: Integer): Boolean; 956var 957 Current: tMaskedType; 958 Ok: Boolean; 959begin 960 Result := False; 961 if (Position < 1) or (Position > FMaskLength) then Exit; 962 Current := CharToMask(FMask[Position]); 963 case Current Of 964 Char_Number : OK := (Length(Ch) = 1) and (Ch[1] In ['0'..'9',#32]); 965 Char_NumberFixed : OK := (Length(Ch) = 1) and (Ch[1] In ['0'..'9']); 966 Char_NumberPlusMin : OK := (Length(Ch) = 1) and (Ch[1] in ['0'..'9','+','-',#32]); 967 Char_Letter : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z',#32]); 968 Char_LetterFixed : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z']); 969 Char_LetterUpCase : OK := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z',#32]); 970 Char_LetterDownCase : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z',#32]); 971 Char_LetterFixedUpCase : OK := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z']); 972 Char_LetterFixedDownCase : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z']); 973 Char_AlphaNum : OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9',#32]); 974 Char_AlphaNumFixed : OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9']); 975 Char_AlphaNumUpCase : OK := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9',#32]); 976 Char_AlphaNumDownCase : OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9',#32]); 977 Char_AlphaNumFixedUpCase : OK := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9']); 978 Char_AlphaNumFixedDowncase:OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9']); 979 //ToDo: make this UTF8 compatible, for now 980 //limit this to lower ASCII set 981 Char_All : OK := True; //Ch in [#32..#126]; //True; 982 Char_AllFixed : OK := True; //Ch in [#32..#126]; //True; 983 Char_AllUpCase : OK := True; //Ch in [#32..#126]; // (Utf8UpperCase(Ch) = Ch); ??????? 984 Char_AllDownCase : OK := True; //Ch in [#32..#126]; // (Utf8LowerCase(Ch) = Ch); ??????? 985 Char_AllFixedUpCase : OK := True; //Ch in [#32..#126]; // (Utf8UpperCase(Ch) = Ch); ??????? 986 Char_AllFixedDownCase : OK := True; //Ch in [#32..#126]; // (Utf8LowerCase(Ch) = Ch); ??????? 987 {Char_Space : OK := (Length(Ch) = 1) and (Ch in [' ', '_']); //not Delphi compatible, see notes above} 988 Char_HourSeparator : OK := (Ch = DefaultFormatSettings.TimeSeparator); 989 Char_DateSeparator : OK := (Ch = DefaultFormatSettings.DateSeparator); 990 else//it's a literal 991 begin 992 OK := (Ch = FMask[Position]); 993 end; 994 end;//case 995 //DebugLn('Position = ',DbgS(Position),' Current = ',MaskCharToChar[Current],' Ch = "',Ch,'" Ok = ',DbgS(Ok)); 996 Result := Ok; 997end; 998 999 1000//Set text in the control with FChangeAllowed flag set appropriately 1001procedure TCustomMaskEdit.RealSetTextWhileMasked(const Value: TCaption); 1002begin 1003 if (Value <> inherited RealGetText) then 1004 begin 1005 FInRealSetTextWhileMasked := True; 1006 FChangeAllowed := True; 1007 FCurrentText := Value; 1008 //protect resetting FChangeAllowed := False against unhandled exceptions in user's 1009 //OnChange, otherwise risk leaving the control in an "unsafe" state regarding text changes 1010 try 1011 Inherited RealSetText(Value); 1012 finally 1013 FChangeAllowed := False; 1014 FInRealSetTextWhileMasked := False; 1015 end;//finally 1016 end; 1017end; 1018 1019// Save current mask, then disable mask 1020// This gives developers the possibility to set any text in the control _without_ messing up the control 1021// Wether or not the function succeeds: NewText will be set as the new text of the control 1022// No need to save FMaskSave and FTrimtype, they are only set in SetMask, which sets MaskIsPushed := False 1023function TCustomMaskEdit.DisableMask(const NewText: String): Boolean; 1024begin 1025 if IsMasked and (not FMaskIsPushed) then 1026 begin 1027 ClearInternalMask(FSavedMask, FSavedMaskLength); 1028 System.Move(FMask[1], FSavedMask[1], SizeOf(TInternalMask)); 1029 FSavedMaskLength := FMaskLength; 1030 ClearInternalMask(FMask, FMaskLength); 1031 FMaskIsPushed := True; 1032 SetMaxLength(0); 1033 Result := True; 1034 end 1035 else 1036 begin 1037 Result := False; 1038 end; 1039 Text := NewText; 1040end; 1041 1042// Restore a saved mask 1043function TCustomMaskEdit.RestoreMask(const NewText: String): Boolean; 1044begin 1045 if FMaskIsPushed and (not IsMasked) then 1046 begin 1047 FMaskIsPushed := False; 1048 SetCharCase(ecNormal); 1049 ClearInternalMask(FMask, FMaskLength); 1050 System.Move(FSavedMask[1], FMask[1], SizeOf(TInternalMask)); 1051 FMaskLength := FSavedMaskLength; 1052 ClearInternalMask(FSavedMask, FSavedMaskLength); 1053 SetMaxLength(FMaskLength); 1054 FTextOnEnter := inherited RealGetText; 1055 Result := True; 1056 end 1057 else 1058 begin 1059 Result := False; 1060 end; 1061 // if NewText = old Text AND the control is now masked, 1062 // then "Text := NewText" will do nothing, 1063 // and NO mask will appear, so Clear first ... 1064 if IsMasked then Clear; 1065 Text := NewText; 1066end; 1067 1068procedure TCustomMaskEdit.RealSetText(const AValue: TCaption); 1069begin 1070 //Setting Text while loading has unwanted side-effects 1071 if (csLoading in ComponentState) {and (not FSettingInitialText)} then 1072 begin 1073 FInitialText := AValue; 1074 Exit; 1075 end; 1076 if not IsMasked then 1077 inherited RealSetText(AValue) 1078 else 1079 SetTextApplyMask(AValue); 1080end; 1081 1082function TCustomMaskEdit.RealGetText: TCaption; 1083begin 1084 Result := inherited RealGetText; //don't call GetEditText here (issue #0026924) 1085 if IsMasked then 1086 Result := GetTextWithoutMask(Result); 1087end; 1088 1089// Set the actual Text 1090procedure TCustomMaskEdit.SetTextApplyMask(Value: TCaption); 1091var 1092 S: TCaption; 1093Begin 1094 if IsMasked then 1095 begin 1096 try 1097 FTextChangedBySetText := True; 1098 if (Value = '') then 1099 begin 1100 Clear; 1101 Exit; 1102 end; 1103 S := ApplyMaskToText(Value); 1104 RealSetTextWhileMasked(S); 1105 finally 1106 FTextChangedBySetText := False; 1107 end; //try..finally 1108 end//Ismasked 1109 else 1110 begin//not IsMasked 1111 RealSetTextWhileMasked(Value); 1112 end; 1113End; 1114 1115 1116function TCustomMaskEdit.GetEditText: string; 1117begin 1118 Result := Inherited RealGetText; 1119end; 1120 1121 1122 1123procedure TCustomMaskEdit.SetEditText(const AValue: string); 1124//Note: This is not Delphi compatible, but by design 1125//Delphi lets you just set EditText of any length, which is extremely dangerous! 1126var 1127 S: String; 1128 i: Integer; 1129 {$if fpc_fullversion < 30202} 1130 OldS: String; 1131 ULen: PtrInt; 1132 ClearCh: TUTF8Char; 1133 {$endif} 1134begin 1135 if (not IsMasked) then 1136 begin 1137 Inherited RealsetText(AValue); 1138 end 1139 else 1140 begin 1141 //Make sure we don't copy more or less text into the control than FMask allows for 1142 S := Utf8Copy(AValue, 1, FMaskLength); 1143 //Restore all MaskLiterals, or we will potentially leave the control 1144 //in an unrecoverable state, eventually crashing the app 1145 for i := 1 to Utf8Length(S) do 1146 if IsLiteral(FMask[i]) then SetCodePoint(S,i,ClearChar(i)); 1147 //Pad resulting string with ClearChar if text is too short 1148 {$if fpc_fullversion >= 30202} 1149 while Utf8Length(S) < FMaskLength do S := S + ClearChar(Utf8Length(S)+1); 1150 {$else} 1151 //workaround for fpc issue #0038337 1152 //Utf8Length(S) corrupts S, so concatenation with ClearChar() fails, leading to an endless loop. 1153 //See issue #0038505 1154 while Utf8Length(S) < FMaskLength do 1155 begin 1156 OldS := S; 1157 ULen := Utf8Length(S); 1158 ClearCh := ClearChar(Ulen+1); 1159 //DbgOut(['TCustomMaskEdit.SetEditText: S="',S,'", Utf8Length(S)=',ULen,', FMaskLength=',FMaskLength,', ClearChar(',Ulen+1,')=',ClearCh]); 1160 S := OldS + ClearCh; 1161 //debugln(' --> S:',S); 1162 end; 1163 {$endif} 1164 RealSetTextWhileMasked(S); 1165 end; 1166end; 1167 1168 1169// Clear (virtually) a single Utf8 char in position Position 1170function TCustomMaskEdit.ClearChar(Position : Integer) : TUtf8Char; 1171begin 1172 Result := FMask[Position]; 1173 //For Delphi compatibilty, only literals remain, all others will be blanked 1174 case CharToMask(FMask[Position]) Of 1175 Char_Number, 1176 Char_NumberFixed, 1177 Char_NumberPlusMin, 1178 Char_Letter, 1179 Char_LetterFixed, 1180 Char_LetterUpCase, 1181 Char_LetterDownCase, 1182 Char_LetterFixedUpCase, 1183 Char_LetterFixedDownCase, 1184 Char_AlphaNum, 1185 Char_AlphaNumFixed, 1186 Char_AlphaNumUpCase, 1187 Char_AlphaNumDownCase, 1188 Char_AlphaNumFixedUpcase, 1189 Char_AlphaNuMFixedDownCase, 1190 Char_All, 1191 Char_AllFixed, 1192 Char_AllUpCase, 1193 Char_AllDownCase, 1194 Char_AllFixedUpCase, 1195 Char_AllFixedDownCase : Result := FSpaceChar; 1196 {Char_Space : Result := #32; //FSpaceChar?; //not Delphi compatible, see notes above} 1197 Char_HourSeparator : Result := DefaultFormatSettings.TimeSeparator; 1198 Char_DateSeparator : Result := DefaultFormatSettings.DateSeparator; 1199 end; 1200end; 1201 1202 1203 1204//Insert a single Utf8 char at the current position of the cursor 1205procedure TCustomMaskEdit.InsertChar(Ch : TUtf8Char); 1206Var 1207 S: String; 1208 i, SelectionStart, SelectionStop: Integer; 1209begin 1210 if CanInsertChar(FCursorPos + 1, Ch) then 1211 begin 1212 S := inherited RealGetText; 1213 if HasSelection then 1214 begin 1215 //replace slection with blank chars 1216 //don't do this via DeleteChars(True), since it will do an unneccesary 1217 //update of the control and 2 TextChanged's are triggerd for every char we enter 1218 GetSel(SelectionStart, SelectionStop); 1219 for i := SelectionStart + 1 to SelectionStop do SetCodePoint(S, i, ClearChar(i)); 1220 end; 1221 SetCodePoint(S, FCursorPos + 1, Ch); 1222 RealSetTextWhileMasked(S); 1223 SelectNextChar; 1224 end 1225 else 1226 //If we have a selection > 1 (and cannot insert) then Delete the selected text: Delphi compatibility 1227 if HasExtSelection then DeleteSelected; 1228end; 1229 1230 1231//Check if a Utf8 char can be inserted at position Position, also do case conversion if necessary 1232function TCustomMaskEdit.CanInsertChar(Position: Integer; var Ch: TUtf8Char; 1233 IsPasting: Boolean = False): Boolean; 1234Var 1235 Current : tMaskedType; 1236Begin 1237 Current := CharToMask(FMask[Position]); 1238 Result := False; 1239 1240 // If in UpCase convert the input char 1241 if (Current = Char_LetterUpCase ) Or 1242 (Current = Char_LetterFixedUpCase) Or 1243 (Current = Char_AllUpCase ) Or 1244 (Current = Char_AllFixedUpCase ) or 1245 (Current = Char_AlphaNumUpcase ) or 1246 (Current = Char_AlphaNumFixedUpCase) 1247 then 1248 Ch := Utf8UpperCase(Ch); 1249 1250 // If in LowerCase convert the input char 1251 if (Current = Char_LetterDownCase ) Or 1252 (Current = Char_LetterFixedDownCase) Or 1253 (Current = Char_AllDownCase ) Or 1254 (Current = Char_AllFixedDownCase ) or 1255 (Current = Char_AlphaNumDownCase ) or 1256 (Current = Char_AlphaNumFixedDownCase ) 1257 then 1258 Ch := Utf8LowerCase(Ch); 1259 1260 // Check the input (check the valid range) 1261 case Current Of 1262 Char_Number : Result := (Length(Ch) = 1) and (Ch[1] In ['0'..'9']); 1263 Char_NumberFixed : Result := (Length(Ch) = 1) and (Ch[1] In ['0'..'9']); 1264 Char_NumberPlusMin : Result := (Length(Ch) = 1) and (Ch[1] in ['0'..'9','+','-',#32]); //yes Delphi allows a space here 1265 Char_Letter : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z']); 1266 Char_LetterFixed : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z']); 1267 Char_LetterUpCase : Result := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z']); 1268 Char_LetterDownCase : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z']); 1269 Char_LetterFixedUpCase : Result := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z']); 1270 Char_LetterFixedDownCase : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z']); 1271 Char_AlphaNum : Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9']); 1272 Char_AlphaNumFixed : Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9']); 1273 Char_AlphaNumUpCase : Result := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9']); 1274 Char_AlphaNumDownCase : Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9']); 1275 Char_AlphaNumFixedUpCase : Result := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9']); 1276 Char_AlphaNumFixedDowncase:Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9']); 1277 Char_All : Result := True; 1278 Char_AllFixed : Result := True; 1279 Char_AllUpCase : Result := True; 1280 Char_AllDownCase : Result := True; 1281 Char_AllFixedUpCase : Result := True; 1282 Char_AllFixedDownCase : Result := True; 1283 {Char_Space : Result := Ch in [' ', '_']; //not Delphi compatible, see notes above} 1284 Char_HourSeparator : Result := (Ch = DefaultFormatSettings.TimeSeparator); 1285 Char_DateSeparator : Result := (Ch = DefaultFormatSettings.DateSeparator); 1286 end; 1287 //while typing a space iis not allowed in these cases, whilst pasting Delphi allows it nevertheless 1288 if not Result and IsPasting and (Ch = #32) and 1289 (Current in [Char_Number, Char_Letter, Char_LetterUpCase, Char_LetterDownCase, 1290 Char_AlphaNum, Char_AlphaNumUpCase, Char_AlphaNumDownCase]) then 1291 Result := True; 1292 1293end; 1294 1295 1296// Delete selected chars 1297procedure TCustomMaskEdit.DeleteSelected; 1298Var 1299 SelectionStart, SelectionStop, I : Integer; 1300 S: String; 1301begin 1302 if not HasSelection then Exit; 1303 GetSel(SelectionStart, SelectionStop); 1304 S := inherited RealGetText; 1305 for i := SelectionStart + 1 to SelectionStop do SetCodePoint(S, i,ClearChar(i)); 1306 RealSetTextWhileMasked(S); 1307 SetCursorPos; 1308end; 1309 1310 1311// Delete a single char from position 1312procedure TCustomMaskEdit.DeleteChars(NextChar : Boolean); 1313begin 1314 if NextChar then 1315 begin//VK_DELETE 1316 if HasSelection then DeleteSelected 1317 else 1318 begin 1319 //cannot delete beyond length of string 1320 if FCursorPos < FMaskLength then 1321 begin 1322 //This will select the appropriate char in the control 1323 SetCursorPos; 1324 DeleteSelected; 1325 end; 1326 end; 1327 end 1328 else 1329 begin//VK_BACK 1330 //if selected text > 1 char then delete selection 1331 if HasExtSelection then DeleteSelected 1332 else 1333 begin 1334 //cannot backspace if we are at beginning of string, or if all chars in front are MaskLiterals 1335 if FCursorPos > FFirstFreePos - 1 then 1336 begin 1337 //This will select the previous character 1338 //If there are MaskLiterals just in front of the current position, they will be skipped 1339 //and the character in front of them will be deleted (Delphi compatibility) 1340 SelectPrevChar; 1341 DeleteSelected; 1342 end; 1343 end; 1344 end; 1345end; 1346 1347function TCustomMaskEdit.ApplyMaskToText(Value: TCaption): TCaption; 1348{ This tries to mimic Delphi behaviour (D3): 1349 - if mask contains no literals text is set, if necessary padded with blanks, 1350 LTR or RTL depending on FTrimType 1351 - if mask contains literals then we search for matching literals in text and 1352 process each "segment" between matching maskliterals, trimming or padding 1353 LTR or RTL depending on FTrimType, until there is no more matching maskliteral 1354 Some examples to clarify: 1355 EditMask Text to be set Result 1356 99 1 1_ 1357 !99 1 _1 1358 cc-cc 1-2 1_-2_ 1359 !cc-cc 1-2 _1-_2 1360 cc-cc@cc 1-2@3 1_-2_@3_ 1361 12@3 12-__@__ 1362 cc-cc@cc 123-456@789 12-45@78 1363 !cc-cc@cc 123-456@789 23-56@89 1364 This feauture seems to be invented for easy use of dates: 1365 1366 99/99/00 23/1/2009 23/1_/20 <- if your locale DateSeparator = '/' 1367 !99/99/00 23/1/2009 23/_1/09 <- if your locale DateSeparator = '/' 1368 1369 - The resulting text will always have length = FMaskLength 1370 - The text that is set, does not need to validate 1371} 1372//Helper functions 1373 Function FindNextMaskLiteral(const StartAt: Integer; out FoundAt: Integer; out ALiteral: TUtf8Char): Boolean; 1374 var i: Integer; 1375 begin 1376 Result := False; 1377 for i := StartAt to FMaskLength do 1378 begin 1379 if IsLiteral(FMask[i]) then 1380 begin 1381 FoundAt := i; 1382 ALiteral := ClearChar(i); 1383 Result := True; 1384 Exit; 1385 end; 1386 end; 1387 end; 1388 Function FindMatchingLiteral(const Value: String; const ALiteral: TUtf8Char; out FoundAt: Integer): Boolean; 1389 begin 1390 FoundAt := Utf8Pos(ALiteral, Value); 1391 Result := (FoundAt > 0); 1392 end; 1393 1394Var 1395 S : String; 1396 I, J : Integer; 1397 mPrevLit, mNextLit : Integer; //Position of Previous and Next literal in FMask 1398 vNextLit : Integer; //Position of next matching literal in Value 1399 HasNextLiteral, 1400 HasMatchingLiteral, 1401 Stop : Boolean; 1402 Literal : TUtf8Char; 1403 Sub : String; 1404begin 1405 //First setup a "blank" string that contains all literals in the mask 1406 if not IsMasked then 1407 begin 1408 Result := Value; 1409 Exit; 1410 end; 1411 S := ''; 1412 for I := 1 To FMaskLength do S := S + ClearChar(I); 1413 1414 if FMaskSave then 1415 begin 1416 mPrevLit := 0; 1417 Stop := False; 1418 HasNextLiteral := FindNextMaskLiteral(mPrevLit+1, mNextLit, Literal); 1419 //if FMask starts with a literal, then the first CodePoint of Value must be that literal 1420 if HasNextLiteral and (mNextLit = 1) and (GetCodePoint(Value, 1) <> Literal) then Stop := True; 1421 //debugln('HasNextLiteral = ',dbgs(hasnextliteral),', Stop = ',dbgs(stop)); 1422 While not Stop do 1423 begin 1424 if HasNextLiteral then 1425 begin 1426 HasMatchingLiteral := FindMatchingLiteral(Value, Literal, vNextLit); 1427 //debugln('mPrevLit = ',dbgs(mprevlit),' mNextLit = ',dbgs(mnextlit)); 1428 //debugln('HasMatchingLiteral = ',dbgs(hasmatchingliteral)); 1429 if HasMatchingLiteral then 1430 begin 1431 //debugln('vNextLit = ',dbgs(vnextlit)); 1432 Sub := Utf8Copy(Value, 1, vNextLit - 1); //Copy up to, but not including matching literal 1433 Utf8Delete(Value, 1, vNextLit); //Remove this bit from Value (including matching literal) 1434 if (Utf8Length(Value) = 0) then Stop := True; 1435 //debugln('Sub = "',Sub,'", Value = "',Value,'"'); 1436 end 1437 else 1438 begin//HasMatchingLiteral = False 1439 Stop := True; 1440 Sub := Value; 1441 Value := ''; 1442 //debugln('Sub = "',Sub,'", Value = "',Value,'"'); 1443 end; 1444 //fill S between vPrevLit + 1 and vNextLit - 1, LTR or RTL depending on FTrimType 1445 if (FTrimType = metTrimRight) then 1446 begin 1447 j := 1; 1448 for i := (mPrevLit + 1) to (mNextLit - 1) do 1449 begin 1450 if (J > Utf8Length(Sub)) then Break; 1451 if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetcodePoint(S,i,GetCodePoint(Sub,j)); 1452 Inc(j); 1453 end; 1454 end 1455 else 1456 begin//FTrimType = metTrimLeft 1457 j := Utf8Length(Sub); 1458 for i := (mNextLit - 1) downto (mPrevLit + 1) do 1459 begin 1460 if (j < 1) then Break; 1461 if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Sub,j)); 1462 Dec(j); 1463 end; 1464 end; 1465 //debugln('S = ',S); 1466 end 1467 else 1468 begin//HasNextLiteral = False 1469 //debugln('No more MaskLiterals at this point'); 1470 //debugln('mPrevLit = ',dbgs(mprevlit)); 1471 Stop := True; 1472 Sub := Value; 1473 Value := ''; 1474 //debugln('Sub = "',Sub,'", Value = "',Value,'"'); 1475 //fill S from vPrevLit + 1 until end of FMask, LTR or RTL depending on FTrimType 1476 if (FTrimType = metTrimRight) then 1477 begin 1478 j := 1; 1479 for i := (mPrevLit + 1) to FMaskLength do 1480 begin 1481 //debugln(' i = ',dbgs(i),' j = ',dbgs(j)); 1482 if (j > Utf8Length(Sub)) then Break; 1483 if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Sub,j)); 1484 //debugln(' Sub[j] = "',Sub[j],'" -> S = ',S); 1485 Inc(j); 1486 end; 1487 end 1488 else 1489 begin//FTrimType = metTrimLeft 1490 j := Utf8Length(Sub); 1491 for i := FMaskLength downto (mPrevLit + 1) do 1492 begin 1493 //debugln(' i = ',dbgs(i),' j = ',dbgs(j)); 1494 if (j < 1) then Break; 1495 if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Sub,j)); 1496 //debugln(' Sub[j] = "',Sub[j],'" -> S = ',S); 1497 Dec(j); 1498 end; 1499 end; 1500 //debugln('S = ',S); 1501 end; 1502 //debugln('Stop = ',dbgs(stop)); 1503 if not Stop then 1504 begin 1505 mPrevLit := mNextLit; 1506 HasNextLiteral := FindNextMaskLiteral(mPrevLit + 1, mNextLit, Literal); 1507 end; 1508 end;//while not Stop 1509 end//FMaskSave = True 1510 else 1511 begin//FMaskSave = False 1512 if FTrimType = metTrimRight then 1513 begin 1514 //fill text from left to rigth, skipping MaskLiterals 1515 j := 1; 1516 for i := 1 to FMaskLength do 1517 begin 1518 if not IsLiteral(FMask[i]) then 1519 begin 1520 if (GetCodePoint(Value,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Value,j)); 1521 Inc(j); 1522 if j > Utf8Length(Value) then Break; 1523 end; 1524 end; 1525 end 1526 else 1527 begin 1528 //fill text from right to left, skipping MaskLiterals 1529 j := Utf8Length(Value); 1530 for i := FMaskLength downto 1 do 1531 begin 1532 if not IsLiteral(FMask[i]) then 1533 begin 1534 if (GetCodePoint(Value,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Value,j)); 1535 Dec(j); 1536 if j < 1 then Break; 1537 end; 1538 end; 1539 end; 1540 end;//FMaskSave = False 1541 Result := S; 1542end; 1543 1544function TCustomMaskEdit.CanShowEmulatedTextHint: Boolean; 1545begin 1546 if IsMasked then 1547 Result := False 1548 else 1549 Result := inherited CanShowEmulatedTextHint; 1550end; 1551 1552 1553 1554// Get the actual Text 1555function TCustomMaskEdit.GetTextWithoutMask(Value: TCaption): TCaption; 1556{ 1557 Replace al FSPaceChars with #32 1558 If FMaskSave = False then do trimming of spaces and remove all maskliterals 1559} 1560var 1561 S: String; 1562 i: Integer; 1563Begin 1564 S := StringReplace(Value, FSpaceChar, #32, [rfReplaceAll]); 1565 //FSpaceChar can be used as a literal in the mask, so put it back 1566 for i := 1 to FMaskLength do 1567 begin 1568 if IsLiteral(FMask[i]) and (FMask[i] = FSpaceChar) then 1569 begin 1570 SetCodePoint(S, i, FSpaceChar); 1571 end; 1572 end; 1573 if not FMaskSave then 1574 begin 1575 for i := 1 to FMaskLength do 1576 begin 1577 if IsLiteral(FMask[i]) then SetCodePoint(S, i, #1); //We know this char can never be in Text, so this is safe 1578 end; 1579 S := StringReplace(S, #1, '', [rfReplaceAll]); 1580 //Trimming only occurs if FMaskSave = False 1581 case FTrimType of 1582 metTrimLeft : S := TrimLeft(S); 1583 metTrimRight: S := TrimRight(S); 1584 end;//case 1585 end; 1586 Result := S; 1587End; 1588 1589{ 1590 Replace al FSPaceChars with #32 1591 Leave all mask literals in place 1592 Needed by FormatMaskText 1593} 1594function TCustomMaskEdit.GetTextWithoutSpaceChar(Value: TCaption): TCaption; 1595var 1596 i: Integer; 1597Begin 1598 Result := StringReplace(Value, FSpaceChar, #32, [rfReplaceAll]); 1599 //FSpaceChar can be used as a literal in the mask, so put it back 1600 for i := 1 to FMaskLength do 1601 begin 1602 if IsLiteral(FMask[i]) and (FMask[i] = FSpaceChar) then 1603 begin 1604 SetCodePoint(Result, i, FSpaceChar); 1605 end; 1606 end; 1607end; 1608 1609 1610// Respond to Text Changed message 1611procedure TCustomMaskEdit.TextChanged; 1612{ Purpose: to avoid messing up the control by 1613 - cut/paste/clear via OS context menu 1614 (we try to catch these messages and handle them, 1615 but this is not garantueed to work) 1616 - dragging selected text in the control with the mouse 1617 If one of these happens, then the internal logic of cursorpositioning, 1618 inserting characters is messed up. 1619 So, we simply restore the text from our backup: FCurrenText 1620} 1621begin 1622 if (not IsMasked) or FChangeAllowed then 1623 begin 1624 Inherited TextChanged; 1625 end 1626 else 1627 begin//Undo changes: restore with value of FCurrentText 1628 //we do not call inherited TextChanged here, because the following RealSetTextWhileMasked 1629 //will trigger TextChanged with FChangeAllowed = True and inherited TextChanged is called then 1630 RealSetTextWhileMasked(FCurrentText); 1631 //Reset cursor to last known position 1632 SetCursorPos; 1633 end; 1634end; 1635 1636procedure TCustomMaskEdit.Change; 1637begin 1638 //suppress OnChange when setting initiall values. 1639 if not FSettingInitialText then inherited Change; 1640end; 1641 1642procedure TCustomMaskEdit.SetCharCase(Value: TEditCharCase); 1643begin 1644 if IsMasked then 1645 begin 1646 if (GetCharCase <> ecNormal) then inherited CharCase := ecNormal; 1647 end 1648 else 1649 begin 1650 inherited CharCase := Value; 1651 end; 1652end; 1653 1654function TCustomMaskEdit.GetCharCase: TEditCharCase; 1655begin 1656 Result := inherited CharCase; 1657end; 1658 1659procedure TCustomMaskEdit.SetMaxLength(Value: Integer); 1660begin 1661 if IsMasked then 1662 begin 1663 inherited MaxLength := FMaskLength; 1664 end 1665 else 1666 begin 1667 inherited MaxLength := Value; 1668 end; 1669end; 1670 1671function TCustomMaskEdit.GetMaxLength: Integer; 1672begin 1673 Result := inherited Maxlength; 1674end; 1675 1676procedure TCustomMaskEdit.SetNumbersOnly(Value: Boolean); 1677begin 1678 if not IsMasked then 1679 inherited SetNumbersOnly(Value) 1680 else 1681 //NumersOnly interferes with masking 1682 inherited SetNumbersOnly(False); 1683end; 1684 1685procedure TCustomMaskEdit.Loaded; 1686begin 1687 inherited Loaded; 1688 FSettingInitialText := True; 1689 if (FInitialMask <> '') then SetMask(FInitialMask); 1690 if (FInitialText <> '') then SetTextApplyMask(FInitialText); 1691 FSettingInitialText := False; 1692end; 1693 1694 1695// Respond to Paste message 1696procedure TCustomMaskEdit.LMPasteFromClip(var Message: TLMessage); 1697begin 1698 if (not IsMasked) or (ReadOnly) then 1699 begin 1700 Inherited ; 1701 Exit; 1702 end; 1703 //We handle this message ourself 1704 Message.Result := 0; 1705 PasteFromClipBoard; 1706end; 1707 1708 1709 1710// Respond to Cut message 1711procedure TCustomMaskEdit.LMCutToClip(var Message: TLMessage); 1712begin 1713 if not IsMasked then 1714 begin 1715 inherited; 1716 Exit; 1717 end; 1718 //We handle this message ourself 1719 Message.Result := 0; 1720 CutToClipBoard; 1721end; 1722 1723 1724// Respond to Clear message 1725procedure TCustomMaskEdit.LMClearSel(var Message: TLMessage); 1726begin 1727 //DebugLn('TCustomMaskEdit.LMClearSel'); 1728 if not IsMasked then 1729 begin 1730 inherited; 1731 Exit; 1732 end; 1733 //We handle this message ourself 1734 Message.Result := 0; 1735 DeleteSelected; 1736end; 1737 1738function TCustomMaskEdit.EditCanModify: Boolean; 1739begin 1740 Result := True; 1741end; 1742 1743 1744 1745procedure TCustomMaskEdit.Reset; 1746//Implements an Undo mechanisme from the moment of entering the control 1747begin 1748 if IsMasked and (not ReadOnly) then 1749 begin 1750 RealSetTextWhileMasked(FTextOnEnter); 1751 end; 1752end; 1753 1754//Moved from CMEnter message handler 1755procedure TCustomMaskEdit.DoEnter; 1756begin 1757 inherited DoEnter; 1758 if IsMasked then 1759 begin 1760 //debugln('TCustomMaskEdit.DoEnter: FValidationFailed = ',DbgS(FValidationFailed)); 1761 FCursorPos := GetSelStart; 1762 //Only save FTextOnEnter if validation did not fail in last DoExit that occurred 1763 if not FValidationFailed then 1764 FTextOnEnter := inherited RealGetText 1765 else 1766 FValidationFailed := False; 1767 Modified := False; 1768 if (AutoSelect and not (csLButtonDown in ControlState)) then 1769 begin 1770 SelectAll; 1771 FCursorPos := GetSelStart; 1772 end 1773 else 1774 begin 1775 if ((FCursorPos = 0) and (IsLiteral(FMask[1]))) then 1776 //On entering select first editable char 1777 SelectNextChar 1778 else 1779 SetCursorPos; 1780 end; 1781 end; 1782end; 1783 1784 1785 1786procedure TCustomMaskEdit.DoExit; 1787begin 1788 //debugln('TCustomMaskEdit.DoExit: FValidationFailed = ',DbgS(FValidationFailed)); 1789 //First give OnExit a change to prevent a EDBEditError 1790 inherited DoExit; 1791 {$IFNDEF MASKEDIT_NOVALIDATEONEXIT} 1792 //Do not validate if FValidationFailed, or risk raising an exception while the previous exception was 1793 //not handled, resulting in an application crash 1794 if IsMasked and (FTextOnEnter <> inherited RealGetText) then 1795 begin 1796 //assume failure 1797 try 1798 //debugln('TCustomMaskedit.DoExit: try ValidateEdit'); 1799 if (not FValidationFailed) then 1800 begin 1801 ValidateEdit; 1802 FValidationFailed := False; 1803 end ; 1804 finally 1805 //also check if control can be focussed, otherwise risk an exception while 1806 //handling an exception, issue #0030482 1807 if FValidationFailed and CanSetFocus then 1808 begin 1809 //debugln('TCustomMaskedit.DoExit: Validation failed'); 1810 SetFocus; 1811 SelectAll; 1812 end; 1813 end; 1814 end; 1815 {$ENDIF} 1816end; 1817 1818 1819 1820// Single key down procedure 1821procedure TCustomMaskEdit.KeyDown(var Key: Word; Shift: TShiftState); 1822begin 1823 Inherited KeyDown(Key, Shift); 1824 // Not masked -> old procedure 1825 if not IsMasked then 1826 begin 1827 Exit; 1828 end; 1829 FCursorPos := GetSelStart; 1830 // shift and arrowkey -> old procedure 1831 if (ssShift in Shift) then 1832 begin 1833 if (Key = VK_LEFT) or (Key = VK_RIGHT) or 1834 (Key = VK_HOME) or (Key = VK_END) then 1835 begin 1836 Exit; 1837 end; 1838 end; 1839 //Escape Key 1840 if (Key = VK_ESCAPE) and (Shift = []) then 1841 begin 1842 if ((inherited RealGetText) <> FTextOnEnter) then 1843 begin 1844 Reset; 1845 Key := 0; 1846 Exit; 1847 end; 1848 end; 1849 //Handle clipboard and delete/backspace keys 1850 if (Key = VK_DELETE) then 1851 begin 1852 if not ReadOnly then 1853 begin 1854 if (Shift = [ssShift]) then 1855 begin//Cut 1856 CutToClipBoard; 1857 end 1858 else if (Shift = [ssModifier]) then 1859 begin//Clear 1860 DeleteSelected; 1861 end 1862 else if (Shift = []) then 1863 begin//Plain Delete 1864 //DeleteChars also works if SelLength = 0 1865 DeleteChars(True); 1866 end; 1867 Key := 0; 1868 Exit; 1869 end; 1870 end; 1871 if (Key = VK_BACK) then 1872 begin 1873 if not ReadOnly then 1874 begin 1875 if (Shift = [ssCtrl]) then 1876 begin//Clear 1877 DeleteSelected; 1878 end 1879 else 1880 if (Shift = [ssShift]) then 1881 begin 1882 CutToClipBoard; 1883 end 1884 else 1885 if (Shift = []) then 1886 begin 1887 DeleteChars(False); 1888 end; 1889 Key := 0; 1890 Exit; 1891 end; 1892 end; 1893 if (Key = VK_INSERT) then 1894 begin//Copy or Paste 1895 if (Shift = [ssShift]) then 1896 begin//Paste 1897 if not ReadOnly then 1898 begin 1899 PasteFromClipBoard; 1900 end; 1901 end 1902 else if (Shift = [ssModifier]) then 1903 begin//Copy 1904 CopyToClipBoard; 1905 end; 1906 Key := 0; 1907 Exit; 1908 end; 1909 if (Key = VK_C) and (Shift = [ssModifier]) then 1910 begin//Copy 1911 CopyToClipBoard; 1912 Key := 0; 1913 Exit; 1914 end; 1915 if (Key = VK_X) and (Shift = [ssModifier]) then 1916 begin//Cut 1917 if not ReadOnly then 1918 begin 1919 CutToClipBoard; 1920 Key := 0; 1921 Exit; 1922 end; 1923 end; 1924 if (Key = VK_V) and (Shift = [ssModifier]) then 1925 begin//Paste 1926 if not ReadOnly then 1927 begin 1928 PasteFromClipBoard; 1929 Key := 0; 1930 Exit; 1931 end; 1932 end; 1933 1934 // Cursor movement 1935 //ATM we handle Ctrl+ArrowKey as if it were just ArrowKey 1936 if (Key = VK_LEFT) then 1937 begin 1938 SelectPrevChar; 1939 Key := 0; 1940 Exit; 1941 end; 1942 if (Key = VK_RIGHT) then 1943 begin 1944 SelectNextChar; 1945 Key := 0; 1946 Exit; 1947 end; 1948 if (Key = VK_HOME) then 1949 begin 1950 SelectFirstChar; 1951 Key := 0; 1952 Exit; 1953 end; 1954 if (Key = VK_END) then 1955 begin 1956 GotoEnd; 1957 Key := 0; 1958 Exit; 1959 end; 1960 // Cursor Up/Down -> not valid 1961 if (Key = VK_UP) or (Key = VK_DOWN) then 1962 begin 1963 Key := 0; 1964 Exit; 1965 end; 1966end; 1967 1968 1969//Handle all keys from KeyPress and Utf8KeyPress here 1970procedure TCustomMaskEdit.HandleKeyPress(var Key: TUtf8Char); 1971begin 1972 if (not IsMasked) or ReadOnly then 1973 begin 1974 Exit; 1975 end; 1976 FCursorPos := GetSelStart; 1977 //If the cursor is on a MaskLiteral then go to the next writable position if a key is pressed (Delphi compatibility) 1978 if IsLiteral(FMask[FCursorPos + 1]) then 1979 begin 1980 SelectNextChar; 1981 Key := EmptyStr; 1982 end 1983 else 1984 // Insert a char 1985 if not ((Length(Key) = 1) and (Key[1] in [#0..#31])) then 1986 begin 1987 if ((Key = Period) or (Key = Comma)) and not (CanInsertChar(FCursorPos + 1, Key)) then 1988 begin//Try to jump to next period or comma, if at all possible 1989 JumpToNextDot(Key[1]); 1990 end 1991 else 1992 begin//any other key 1993 InsertChar(Key); 1994 end; 1995 //We really need to "eat" all keys we handle ourselves 1996 //(or widgetset will insert char second time) 1997 Key:= EmptyStr; 1998 end; 1999end; 2000 2001 2002procedure TCustomMaskEdit.KeyPress(var Key: Char); 2003var 2004 Utf8Key: TUtf8Char; 2005begin 2006 inherited KeyPress(Key); 2007 Utf8Key := Key; 2008 //All keys are handled in HandleKeyPress, which sets Utf8Key to '' 2009 HandleKeyPress(Utf8Key); 2010 if (Length(Utf8Key) = 0) then Key := #0; 2011end; 2012 2013procedure TCustomMaskEdit.Utf8KeyPress(var UTF8Key: TUTF8Char); 2014begin 2015 inherited Utf8KeyPress(UTF8Key); 2016 //All keys are handled in HandleKeyPress, which sets Utf8Key to '' 2017 //In Utf8KeyPress do this only for Utf8 sequences, otherwise KeyPress is never called 2018 //because after this Utf8Key = '' 2019 if (Length(Utf8Key) > 1) then HandleKeyPress(Utf8Key); 2020end; 2021 2022 2023//Moved form LMMButtonUp message handler 2024procedure TCustomMaskEdit.MouseUp(Button: TMouseButton; Shift: TShiftState; X, 2025 Y: Integer); 2026begin 2027 inherited MouseUp(Button, Shift, X, Y); 2028 if IsMasked then 2029 begin 2030 FCursorPos := GetSelStart; 2031 if not HasSelection then SetCursorPos; 2032 end; 2033end; 2034 2035procedure TCustomMaskEdit.CheckCursor; 2036begin 2037 if IsMasked then 2038 SetCursorPos; 2039end; 2040 2041procedure TCustomMaskEdit.CutToClipBoard; 2042begin 2043 if not IsMasked then 2044 begin 2045 inherited CutToClipBoard; 2046 Exit; 2047 end; 2048 CopyToClipBoard; 2049 DeleteSelected; 2050end; 2051 2052procedure TCustomMaskEdit.PasteFromClipBoard; 2053{ 2054 Paste only allowed chars, skip literals in the mask 2055 e.g. if cliptext = '1234' and mask = '00:00' then result will be '12:34' 2056} 2057var 2058 ClipText, S: String; 2059 P, i: LongInt; 2060 CP: TUTF8Char; 2061begin 2062 if not IsMasked then 2063 begin 2064 inherited PasteFromClipBoard; 2065 Exit; 2066 end; 2067 if Clipboard.HasFormat(CF_TEXT) then 2068 begin 2069 //debugln('TCustomMaskEdit.PasteFromClipBoard A'); 2070 ClipText := ClipBoard.AsText; 2071 if (Utf8Length(ClipText) > 0) then 2072 begin 2073 P := FCursorPos + 1; 2074 DeleteSelected; 2075 S := inherited RealGetText; 2076 i := 1; 2077 //debugln('TCustomMaskEdit.PasteFromClipBoard B:'); 2078 //debugln(' P = ',dbgs(p)); 2079 //debugln(' S = ',s); 2080 //debugln(' ClipText = ',ClipText); 2081 while (P <= FMaskLength) and (i <= Utf8Length(ClipText)) do 2082 begin 2083 //Skip any literal 2084 while (P < FMaskLength) and (IsLiteral(FMask[P])) do Inc(P); 2085 //debugln('TCustomMaskEdit.PasteFromClipBoard C: P = ',DbgS(p)); 2086 //Skip any char in ClipText that cannot be inserted at current position 2087 CP := GetCodePoint(ClipText,i); 2088 //Replace all control characters with spaces 2089 if (Length(CP) = 1) and (CP[1] in [#0..#31]) then CP := #32; 2090 while (i < Utf8Length(ClipText)) and (not CanInsertChar(P, CP, True)) do 2091 begin 2092 Inc(i); 2093 CP := GetCodePoint(ClipText,i); 2094 end; 2095 if CanInsertChar(P, CP, True) then 2096 begin 2097 SetCodePoint(S,P,CP); 2098 Inc(P); 2099 Inc(i); 2100 end 2101 else 2102 Break; 2103 end; 2104 RealSetTextWhileMasked(S); 2105 SetCursorPos; 2106 end; 2107 end; 2108end; 2109 2110 2111// Clear the controll 2112procedure TCustomMaskEdit.Clear; 2113Var 2114 S : ShortString; 2115 I : Integer; 2116begin 2117 if IsMasked then 2118 begin 2119 S := ''; 2120 for I := 1 To FMaskLength do S := S + ClearChar(I); 2121 RealSetTextWhileMasked(S); 2122 FCursorPos := 0; 2123 SetCursorPos; 2124 end 2125 else Inherited Clear; 2126end; 2127 2128 2129 2130procedure TCustomMaskEdit.ValidateEdit; 2131var 2132 S: String; 2133 _MaskSave: Boolean; 2134begin 2135 //Only validate if IsMasked 2136 if IsMasked then 2137 begin 2138 { 2139 if FMaskSave = False then literal and spaces are trimmed from Text 2140 and TextIsValid might wrongly return False 2141 We need the text with literals and FSpaceChar translated to #32 2142 } 2143 _MaskSave := FMaskSave; 2144 FMaskSave := True; 2145 S := Text; 2146 FMaskSave := _MaskSave; 2147 if not TextIsValid(S) then 2148 begin 2149 SetCursorPos; 2150 FValidationFailed := True; 2151 Raise EDBEditError.Create(SMaskEditNoMatch); 2152 end; 2153 end; 2154end; 2155 2156 2157{ Component registration procedure } 2158procedure Register; 2159begin 2160 RegisterComponents('Additional',[TMaskEdit]); 2161end; 2162 2163 2164initialization 2165 RegisterPropertyToSkip(TCustomMaskEdit, 'TextHintFontColor','Used in a previous version of Lazarus',''); 2166 RegisterPropertyToSkip(TCustomMaskEdit, 'TextHintFontStyle','Used in a previous version of Lazarus',''); 2167 2168end. 2169