paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
c9d65fa82e
lazarus-ccr/components/orpheus/o32flxed.pas

1602 lines
41 KiB
ObjectPascal
Raw Blame History

{*********************************************************}
{* O32FLXED.PAS 4.06 *}
{*********************************************************}
{* ***** BEGIN LICENSE BLOCK ***** *}
{* Version: MPL 1.1 *}
{* *}
{* The contents of this file are subject to the Mozilla Public License *}
{* Version 1.1 (the "License"); you may not use this file except in *}
{* compliance with the License. You may obtain a copy of the License at *}
{* http://www.mozilla.org/MPL/ *}
{* *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
{* for the specific language governing rights and limitations under the *}
{* License. *}
{* *}
{* The Original Code is TurboPower Orpheus *}
{* *}
{* The Initial Developer of the Original Code is TurboPower Software *}
{* *}
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *}
{* TurboPower Software Inc. All Rights Reserved. *}
{* *}
{* Contributor(s): *}
{* *}
{* ***** END LICENSE BLOCK ***** *}
{$I OVC.INC}
{$B-} {Complete Boolean Evaluation}
{$I+} {Input/Output-Checking}
{$P+} {Open Parameters}
{$T-} {Typed @ Operator}
{.W-} {Windows Stack Frame}
{$X+} {Extended Syntax}
{$J+} {Writable constants}
unit o32flxed;
{OvcFlexEdit and support classes - Introduced in Orpheus 4.0}
interface
uses
{$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF}
Classes, Controls, Forms, SysUtils, StdCtrls, Buttons,
OvcData, O32Editf, OvcEF, Graphics, O32SR, O32bordr, O32Vldtr,
O32VlOp1, o32ovldr, {$IFNDEF LCL} o32pvldr, {$ENDIF} o32rxvld, Dialogs;
type
{Forward Declaration}
TO32CustomFlexEdit = class;
TO32PopupAnchor = (paLeft, paRight);
// TO32FlexEditDataType = (feString, feFloat, feInteger, feDateTime, feExtended,
// feStDate, feStTime, feLogical);
TO32FEButton = class(TBitBtn)
public
procedure Click; override;
end;
TO32feButtonClickEvent =
procedure(Sender: TO32CustomFlexEdit; PopupPoint: TPoint) of object;
TFEUserValidationEvent =
procedure(Sender : TObject; var ValidEntry : Boolean) of object;
TFEValidationErrorEvent =
procedure(Sender : TObject; ErrorCode : Word; ErrorMsg : string) of object;
TFlexEditValidatorOptions = class(TValidatorOptions)
published
property InputRequired;
end;
TO32EditLines = class(TPersistent)
protected{private}
FlexEdit : TO32CustomFlexEdit;
FMaxLines : Integer;
FDefaultLines : Integer;
FFocusedLines : Integer;
FMouseOverLines: Integer;
procedure SetDefaultLines(Value: Integer);
procedure SetMaxLines(Value: Integer);
procedure SetFocusedLines(Value: Integer);
procedure SetMouseOverLines(Value: Integer);
public
constructor Create; virtual;
destructor Destroy; override;
published
property MaxLines: Integer read FMaxLines write SetMaxLines
default 3;
property DefaultLines: Integer read FDefaultLines write SetDefaultLines
default 1;
property FocusedLines: Integer read FFocusedLines write SetFocusedLines
default 3;
property MouseOverLines: Integer read FMouseOverLines write SetMouseOverLines
default 3;
end;
TFlexEditStrings = class(TStrings)
protected {private}
FCapacity: Integer;
function Get(Index: Integer): string; override;
function GetCount: Integer; override;
function GetTextStr: string; override;
procedure Put(Index: Integer; const S: string); override;
procedure SetTextStr(const Value: string); override;
procedure SetUpdateState(Updating: Boolean); override;
public
FlexEdit: TCustomEdit;
procedure Clear; override;
procedure SetCapacity(NewCapacity: Integer); override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: string); override;
end;
TO32CustomFlexEdit = class(TO32CustomEdit)
protected {private}
FAlignment : TAlignment;
FBorders : TO32Borders;
FButton : TO32FEButton;
FButtonGlyph : TBitmap;
FCanvas : TControlCanvas;
// FDataType : TO32FlexEditDataType;
FEditLines : TO32EditLines;
FEFColors : TOvcEFColors;
FDisplayedLines : Integer;
FMaxLines : Integer;
FStrings : TFlexEditStrings;
// FPasswordChar : Char;
FPopupAnchor : TO32PopupAnchor;
FShowButton : Boolean;
FWordWrap : Boolean;
FWantReturns : Boolean;
FWantTabs : Boolean;
FMouseInControl : Boolean;
FValidation : TFlexEditValidatorOptions;
FValidator : TO32BaseValidator;
FValidationError : Integer;
FOnButtonClick : TO32feButtonClickEvent;
FOnUserValidation : TFEUserValidationEvent;
FOnValidationError: TFEValidationErrorEvent;
FBeforeValidation : TNotifyEvent;
FAfterValidation : TNotifyEvent;
{Internal Variables}
FSaveEdit : String; {saved copy of edit string}
FCreating : Boolean;
FColor : TColor;
FFontColor : TColor;
FUpdating : Integer;
feValid : Boolean;
{Property Methods}
function GetButtonGlyph : TBitmap;
procedure SetButtonGlyph(Value : TBitmap);
procedure SetShowButton (Value : Boolean);
function GetBoolean : Boolean;
function GetYesNo : Boolean;
function GetDateTime : TDateTime;
function GetDouble : Double;
function GetExtended : Extended;
function GetInteger : Integer;
function GetStrings : TStrings;
function GetVariant : Variant;
function GetText : String;
function GetColor : TColor; virtual;
procedure SetBoolean (Value : Boolean);
procedure SetYesNo (Value : Boolean);
procedure SetDateTime (Value : TDateTime);
// procedure SetDataType (Value : TO32FlexEditDataType);
procedure SetDouble (Value : Double);
procedure SetExtended (Value : Extended);
procedure SetInteger (Value : Integer);
procedure SetStrings (Value : TStrings);
procedure SetVariant (Value : Variant);
procedure SetDisplayedLines(Value : Integer);
procedure SetWordWrap (Value : Boolean);
procedure SetWantReturns (Value : Boolean);
procedure SetWantTabs (Value : Boolean);
procedure SetText (const Value : String);
procedure SetColor (Value : TColor); virtual;
{Message Handlers}
procedure WMGetDlgCode (var Message : TWMGetDlgCode); message WM_GETDLGCODE;
procedure CMMouseEnter (var Message : TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave (var Message : TMessage); message CM_MOUSELEAVE;
{$IFNDEF LCL}
procedure CMGotFocus (var Message : TMessage); message WM_SETFOCUS;
procedure CMLostFocus (var Message : TMessage); message WM_KILLFOCUS;
{$ELSE}
procedure CMGotFocus (var Message : TLMSetFocus); message WM_SETFOCUS;
procedure CMLostFocus (var Message : TLMKillFocus); message WM_KILLFOCUS;
{$ENDIF}
{ - added}
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMNCPaint (var Message : TWMNCPaint); message WM_NCPAINT;
{ - was commented out in 4.02 and re-written in 4.06}
procedure WMPaint (var Message : TWMPaint); message WM_PAINT;
procedure OMValidate (var Message : TMessage); message OM_VALIDATE;
procedure OMRecreateWnd(var Message : TMessage); message OM_RECREATEWND;
{Internal Methods}
procedure KeyPress(var Key: Char); override;
procedure CreateParams(var Params : TCreateParams); override;
procedure SetParent(Value: TWinControl); override;
procedure CreateWnd; override;
{$IFNDEF LCL}
procedure CreateWindowHandle(const Params: TCreateParams); override;
{$ENDIF}
procedure AdjustHeight;
procedure GlyphChanged; dynamic;
procedure Loaded; override;
procedure SetAlignment(Value: TAlignment);
function MultiLineEnabled: Boolean;
function GetButtonWidth : Integer;
function GetButtonEnabled : Boolean; dynamic;
procedure SetMaxLines(Value: Integer);
function ValidateSelf: Boolean; virtual;
procedure SaveEditString;
procedure DoOnChange; virtual;
{$IFDEF LCL}
function ChildClassAllowed(ChildClass: TClass): Boolean; override;
{$ENDIF}
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
procedure ButtonClick; dynamic;
procedure Restore; virtual;
procedure BeginUpdate;
procedure EndUpdate;
{properties}
property Alignment: TAlignment
read FAlignment write SetAlignment default taLeftJustify;
// property DataType: TO32FlexEditDataType
// read FDataType write SetDataType default feString;
property Borders: TO32Borders
read FBorders write FBorders;
property Color: TColor
read GetColor write SetColor default clWindow;
property EfColors: TOvcEfColors
read FEFColors write FEFColors;
property EditLines: TO32EditLines
read FEditLines write FEditLines;
// property PasswordChar: char
// read FPasswordChar write SetPwdChar;
property PopupAnchor : TO32PopupAnchor
read FPopupAnchor write FPopupAnchor;
property ShowButton : Boolean
read FShowButton write SetShowButton;
property Validation: TFlexEditValidatorOptions
read FValidation write FValidation;
property WantReturns: Boolean
read FWantReturns write SetWantReturns default False;
property WantTabs: Boolean
read FWantTabs write SetWantTabs default False;
property WordWrap: Boolean
read FWordWrap write SetWordWrap default False;
property Text: String
read GetText write SetText;
property Strings: TStrings
read GetStrings write SetStrings;
property AsBoolean: Boolean
read GetBoolean write SetBoolean;
property AsYesNo: Boolean
read GetYesNo write SetYesNo;
property AsDateTime: TDateTime
read GetDateTime write SetDateTime;
property AsFloat: Double
read GetDouble write SetDouble;
property AsExtended: Extended
read GetExtended write SetExtended;
property AsInteger: Integer
read GetInteger write SetInteger;
property AsVariant: Variant
read GetVariant write SetVariant;
property ButtonGlyph : TBitmap
read GetButtonGlyph write SetButtonGlyph;
property Canvas :TControlCanvas
read FCanvas;
property OnButtonClick : TO32feButtonClickEvent
read FOnButtonClick write FOnButtonClick;
property OnUserValidation: TFEUserValidationEvent
read FOnUserValidation write FOnUserValidation;
property OnValidationError: TFEValidationErrorEvent
read FOnValidationError write FOnValidationError;
property BeforeValidation : TNotifyEvent
read FBeforeValidation write FBeforeValidation;
property AfterValidation : TNotifyEvent
read FAfterValidation write FAfterValidation;
end;
{O32FlexEdit}
TO32FlexEdit = class(TO32CustomFlexEdit)
published
{$IFDEF VERSION4}
property Alignment;
property Anchors;
{$IFNDEF LCL}
property BiDiMode;
property ParentBiDiMode;
{$ENDIF}
property DragKind;
property DragMode;
property OnEndDock;
property OnStartDock;
{$ENDIF}
property AutoSize default False;
property About;
{$IFNDEF LCL}
property AutoSelect; // Added recently to LCL, but leave out for now
{$ENDIF}
property Borders;
property ButtonGlyph;
property CharCase;
property Color;
property Cursor;
property DragCursor;
property EditLines;
property EfColors;
property Enabled;
property Font;
{$IFNDEF LCL}
property HideSelection;
property ImeMode;
property ImeName;
{$ENDIF}
property LabelInfo;
property MaxLength;
{$IFNDEF LCL}
property OEMConvert;
{$ENDIF}
property ParentFont;
property ParentShowHint;
property PasswordChar;
property PopupAnchor default paLeft;
property PopupMenu;
property ReadOnly;
property ShowButton default False;
property ShowHint;
property TabOrder;
property TabStop;
property Text;
property Validation;
property Visible;
property WantReturns;
property WantTabs;
property WordWrap;
property AfterValidation;
property BeforeValidation;
property OnButtonClick;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
property OnUserValidation;
property OnValidationError;
end;
implementation
// The optional button inside a TO32FlexEdit originally did not work with LCL,
// so excluded all button-related code.
// Note now seems to work with win32 and carbon as of 0.9.28. To enable,
// delete the dot in the two DEFINE's.
// For more information, see Lazarus bug 7097.
{$IFNDEF LCL}
{$DEFINE ButtonOkay}
{$ELSE}
{.$DEFINE ButtonOkay}
{$IFNDEF MSWINDOWS}
{.$DEFINE ButtonNotChild} //Manually reposition relative to edit control
{$ENDIF}
{$ENDIF}
{===== TO32FEButton ==================================================}
procedure TO32FEButton.Click;
begin
TO32FlexEdit(Parent).SetFocus;
TO32FlexEdit(Parent).ButtonClick;
end;
{===== TO32EditLines =================================================}
constructor TO32EditLines.Create;
begin
inherited Create;
FMaxLines := 3{1};
FFocusedLines := 3{1};
FMouseOverLines := 3{1};
FDefaultLines := 1;
end;
{=====}
destructor TO32EditLines.Destroy;
begin
inherited Destroy;
end;
{=====}
procedure TO32EditLines.SetDefaultLines(Value: Integer);
begin
if FDefaultLines <> Value then
FDefaultLines := Value;
if FDefaultLines > FMaxLines then
FDefaultLines := FMaxLines;
end;
{=====}
procedure TO32EditLines.SetMaxLines(Value: Integer);
begin
if FMaxLines <> Value then begin
FMaxLines := Value;
TO32CustomFlexEdit(FlexEdit).SetMaxLines(FMaxLines);
end;
end;
{=====}
procedure TO32EditLines.SetFocusedLines(Value: Integer);
begin
if FFocusedLines <> Value then
FFocusedLines := Value;
if FFocusedLines > FMaxLines then
FFocusedLines := FMaxLines;
end;
{=====}
procedure TO32EditLines.SetMouseOverLines(Value: Integer);
begin
if FMouseOverLines <> Value then
FMouseOverLines := Value;
if FMouseOverLines > FMaxLines then
FMouseOverLines := FMaxLines;
end;
{===== TFlexEditStrings ==============================================}
function TFlexEditStrings.GetCount: Integer;
begin
Result := 0;
if FlexEdit.HandleAllocated then
begin
Result := SendMessage(FlexEdit.Handle, EM_GETLINECOUNT, 0, 0);
if SendMessage(FlexEdit.Handle, EM_LINELENGTH, SendMessage(FlexEdit.Handle,
EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
end;
end;
{=====}
function TFlexEditStrings.Get(Index: Integer): string;
var
Text: array[0..4095] of Char;
begin
Word((@Text)^) := SizeOf(Text);
SetString(Result, Text, SendMessage(FlexEdit.Handle, EM_GETLINE, Index,
Longint(@Text)));
end;
{=====}
procedure TFlexEditStrings.Put(Index: Integer; const S: string);
var
SelStart: Integer;
begin
SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index, 0);
if SelStart >= 0 then
begin
SendMessage(FlexEdit.Handle, EM_SETSEL, SelStart, SelStart +
SendMessage(FlexEdit.Handle, EM_LINELENGTH, SelStart, 0));
SendMessage(FlexEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
end;
end;
{=====}
procedure TFlexEditStrings.Insert(Index: Integer; const S: string);
var
SelStart, LineLen: Integer;
Line: string;
begin
if Count = FCapacity then exit;
if Index >= 0 then
begin
SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index, 0);
if SelStart >= 0 then Line := S + #13#10 else
begin
SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index - 1, 0);
if SelStart < 0 then Exit;
LineLen := SendMessage(FlexEdit.Handle, EM_LINELENGTH, SelStart, 0);
if LineLen = 0 then Exit;
Inc(SelStart, LineLen);
Line := #13#10 + s;
end;
SendMessage(FlexEdit.Handle, EM_SETSEL, SelStart, SelStart);
SendMessage(FlexEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(Line)));
end;
end;
{=====}
procedure TFlexEditStrings.Delete(Index: Integer);
const
Empty: PChar = '';
var
SelStart, SelEnd: Integer;
begin
SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index, 0);
if SelStart >= 0 then
begin
SelEnd := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index + 1, 0);
if SelEnd < 0 then SelEnd := SelStart +
SendMessage(FlexEdit.Handle, EM_LINELENGTH, SelStart, 0);
SendMessage(FlexEdit.Handle, EM_SETSEL, SelStart, SelEnd);
SendMessage(FlexEdit.Handle, EM_REPLACESEL, 0, Longint(Empty));
end;
end;
{=====}
procedure TFlexEditStrings.Clear;
begin
FlexEdit.Clear;
end;
{=====}
procedure TFlexEditStrings.SetUpdateState(Updating: Boolean);
begin
if FlexEdit.HandleAllocated then
begin
SendMessage(FlexEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);
if not Updating then
begin // WM_SETREDRAW causes visibility side effects in memo controls
FlexEdit.Perform(CM_SHOWINGCHANGED,0,0); // This reasserts the visibility we want
FlexEdit.Refresh;
end;
end;
end;
{=====}
function TFlexEditStrings.GetTextStr: string;
begin
Result := FlexEdit.Text;
end;
{=====}
procedure TFlexEditStrings.SetCapacity(NewCapacity: Integer);
begin
{Sets line-limit and destructively removes any lines that exceed the limit.}
if FCapacity <> NewCapacity then begin
FCapacity := NewCapacity;
while Count > FCapacity do Delete(FCapacity);
end;
end;
{=====}
procedure TFlexEditStrings.SetTextStr(const Value: string);
var
NewText: string;
begin
NewText := AdjustLineBreaks(Value);
if (Length(NewText) <> FlexEdit.GetTextLen) or (NewText <> FlexEdit.Text) then
begin
{$IFNDEF LCL}
if SendMessage(FlexEdit.Handle, WM_SETTEXT, 0, Longint(NewText)) = 0 then
raise EInvalidOperation.Create(RSTooManyBytes);
FlexEdit.Perform(CM_TEXTCHANGED, 0, 0);
{$ELSE} //Previous SendMessage always returns 0 (error) with LCL
FlexEdit.SetTextBuf(PAnsiChar(NewText));
{$ENDIF}
end;
end;
{===== TO32CustomFlexEdit ============================================}
constructor TO32CustomFlexEdit.Create(AOwner : TComponent);
begin
FCreating := True;
inherited Create(AOwner);
FWordWrap := False;
FWantReturns := False;
FWantTabs := False;
Width := 185;
AutoSize := False;
{create support classes}
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
feValid := true;
FShowButton := False;
{$IFDEF ButtonOkay}
FButton := TO32FEButton.Create(Self);
FButton.Visible := True;
FButton.Parent := Self;
FButton.Caption := '';
FButton.TabStop := False;
{$IFNDEF LCL}
FButton.Style := bsNew;
{$ENDIF}
{$ENDIF}
FButtonGlyph := TBitmap.Create;
FBorders := TO32Borders.Create(Self);
FEFColors := TOvcEfColors.Create;
FStrings := TFlexEditStrings.Create;
TFlexEditStrings(FStrings).FlexEdit := Self;
FEditLines := TO32EditLines.Create;
TO32EditLines(FEditLines).FlexEdit := self;
{ now set in TO32EditLines.Create:
EditLines.MaxLines := 3;
EditLines.DefaultLines := 1;
EditLines.FocusedLines := 3;
EditLines.MouseOverLines := 3;
}
FDisplayedLines := FEditLines.FDefaultLines;
TFlexEditStrings(FStrings).Capacity := FMaxLines;
FMouseInControl := false;
FSaveEdit := '';
Height := 80;
AdjustHeight;
Validation := TFlexEditValidatorOptions.Create(self);
FColor := Color;
FFontColor := Font.Color;
FCreating := False;
end;
{=====}
destructor TO32CustomFlexEdit.Destroy;
begin
{Free support classes}
{$IFDEF ButtonOkay}
FButton.Free;
{$ENDIF}
FEFColors.Free;
FEditLines.Free;
FStrings.Free;
FButtonGlyph.Free;
FCanvas.Free;
FBorders.Free;
FValidation.Free;
inherited Destroy;
end;
{=====}
procedure TO32CustomFlexEdit.CreateParams(var Params: TCreateParams);
const
Passwords: array[Boolean] of DWORD = (0, ES_PASSWORD);
Alignments: array[Boolean, TAlignment] of DWORD =
((ES_LEFT, ES_RIGHT, ES_CENTER),(ES_RIGHT, ES_LEFT, ES_CENTER));
WordWraps: array[Boolean] of DWORD = (0, ES_AUTOHSCROLL);
begin
inherited CreateParams(Params);
with Params do
begin
{ - begin}
if MultilineEnabled then
Style := Style and not WordWraps[FWordWrap] or ES_MULTILINE
{$IFDEF VERSION4}
{$IFNDEF LCL}
or Alignments[UseRightToLeftAlignment, FAlignment]
{$ELSE}
or Alignments[False, FAlignment]
{$ENDIF}
{$ENDIF}
or WS_CLIPCHILDREN
else
Style := Style and not WordWraps[FWordWrap]
or Passwords[PasswordChar <> #0]
{$IFDEF VERSION4}
{$IFNDEF LCL}
or Alignments[UseRightToLeftAlignment, FAlignment]
{$ELSE}
or Alignments[False, FAlignment]
{$ENDIF}
{$ENDIF}
or WS_CLIPCHILDREN
{ - end}
end;
end;
{=====}
procedure TO32CustomFlexEdit.SetParent(Value: TWinControl);
begin
inherited;
{$IFNDEF VERSION4}
{$IFDEF CBuilder}
HandleNeeded; {BCB3 needs a handle here}
{$ENDIF}
{$ENDIF}
end;
{=====}
procedure TO32CustomFlexEdit.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
if FWantTabs then Message.Result := Message.Result or DLGC_WANTTAB
else Message.Result := Message.Result and not DLGC_WANTTAB;
if not FWantReturns then
Message.Result := Message.Result and not DLGC_WANTALLKEYS;
end;
{=====}
procedure TO32CustomFlexEdit.WMNCPaint(var Message: TWMNCPaint);
var
DC: HDC;
begin
if (FUpdating > 0) then exit;
inherited;
if Borders.Active then begin
DC := GetWindowDC(Handle);
FCanvas.Handle := DC;
try
FBorders.DrawBorders(FCanvas, Color);
finally
FCanvas.Handle := 0;
ReleaseDC( Handle, DC );
end;
Message.Result := 0;
end;
end;
{=====}
{WMPaint had been completely commented out in 4.02. It is now }
{ re introduced as follows.... }
{ - Re-written}
procedure TO32CustomFlexEdit.WMPaint(var Message: TWMPaint);
begin
{ known limitation, The ancestor is overriding the font color when the }
{ control is disabled }
if not Enabled then begin
inherited Color := efColors.Disabled.BackColor;
Font.Color := efColors.Disabled.TextColor;
end else begin
if feValid then begin
inherited Color := FColor;
Font.Color := FFontColor;
end else if Validation.SoftValidation then begin
inherited Color := EFColors.Error.BackColor;
Font.Color := EFColors.Error.TextColor;
end;
end;
inherited;
end;
{ - Not necessary }
(*
procedure TO32CustomFlexEdit.WMPaint(var Message: TWMPaint);
var
Rct: TRect;
Str: string;
DC: HDC;
PS: TPaintStruct;
begin
if (FUpdating > 0) then exit;
if ((FAlignment = taLeftJustify ) or Focused)
and not (csPaintCopy in ControlState)
then inherited
else begin
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
FCanvas.Handle := DC;
try
if (FAlignment = taRightJustify) then begin
FCanvas.Font := Font;
with FCanvas do begin
Rct := ClientRect;
Brush.Color := Color;
Str := Text;
TextRect(Rct, Rct.Right - TextWidth(Str) - 2, 2, Str);
end;
end;
finally
FCanvas.Handle := 0;
if Message.DC = 0 then EndPaint( Handle, PS );
end;
end;
end;
{=====}
*)
procedure TO32CustomFlexEdit.OMValidate (var Message : TMessage);
begin
if not ValidateSelf then begin
if Assigned(FOnValidationError) then
// TurboPower bug: With vtUser, FValidator is nil here.
// FOnValidationError(Self, FValidator.ErrorCode, 'Invalid input');
FOnValidationError(Self, FValidationError, 'Invalid input'); //Fixed
Message.Result := FValidationError;
if (Validation.ValidationEvent = veOnChange) then begin
Validation.BeginUpdate;
Restore;
Validation.EndUpdate;
end;
end else begin
Message.Result := 0;
end;
end;
{=====}
function TO32CustomFlexEdit.ValidateSelf: Boolean;
begin
result := true;
if (FUpdating > 0) then exit;
case Validation.ValidationType of
vtNone: begin
{User can specify that the field be non-empty even if he is specifying no
custom validation}
if Validation.InputRequired and (Text = '') then
result := false;
exit;
end;
vtUser: begin
if (Text = '') then begin
if Validation.InputRequired then
result := false
else
result := true;
end; { else } //Commented out; otherwise our validation handler never
// gets called if Text is blank - TurboPower bug?.
if Assigned(FOnUserValidation) then
FOnUserValidation(Self, result);
if not Result then
FValidationError := 1;
end; {vtUser}
vtValidator: begin
if (text = '') then begin
if Validation.InputRequired then begin
{Fail Validation for an empty, required field}
result := false;
FValidationError := 1;
end else begin
{Pass validation for a non-required, empty field}
result := true;
FValidationError := 0;
end;
end
else if Validation.Mask = '' then begin
result := true;
FValidationError := 0;
exit;
end
else if FValidation.ValidatorClass = nil then begin
result := false;
raise(Exception.Create('Error: Unknown validator Class.'));
end
else begin
FValidator := FValidation.ValidatorClass.Create(Self);
try
FValidator.Mask := Validation.Mask;
FValidator.Input := Text;
if Assigned(FBeforeValidation) then
FBeforeValidation(self);
result := FValidator.IsValid;
FValidationError := FValidator.ErrorCode;
if Assigned(FAfterValidation) then
FAfterValidation(self);
finally
FValidator.Free;
end; {try}
end; {if}
end; {VtValidator}
end; {case}
{ - begin}
feValid := result;
if result then
SaveEditString
else
if Validation.BeepOnError then
MessageBeep(0);
{ Invalidate; } { !!.04 - Commented out - Causes flicker } {!!!!}
{ - end}
end;
{=====}
procedure TO32CustomFlexEdit.OMRecreateWnd(var Message : TMessage);
begin
if (FUpdating > 0) then exit;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
end;
{=====}
procedure TO32CustomFlexEdit.CMMouseEnter(var Message : TMessage);
begin
inherited;
if Enabled and MultiLineEnabled and (not FMouseInControl)
and (not Focused) then begin
if FDisplayedLines <> FEditLines.FMouseOverLines then begin
SetDisplayedLines(FEditLines.FMouseOverLines);
AdjustHeight;
end;
end;
FMouseInControl := True;
end;
{=====}
procedure TO32CustomFlexEdit.CMMouseLeave(var Message : TMessage);
begin
inherited;
{$IFDEF ButtonOkay}
if FButton.Focused then exit;
{$ENDIF}
if Enabled and FMouseInControl and MultiLineEnabled then begin
if (Focused) then begin
if FDisplayedLines <> FEditLines.FocusedLines then
SetDisplayedLines(FEditLines.FocusedLines);
end else begin
if FDisplayedLines <> FEditLines.DefaultLines then
SetDisplayedLines(FEditLines.DefaultLines);
end;
AdjustHeight;
end;
FMouseInControl := False;
end;
{=====}
{$IFNDEF LCL}
procedure TO32CustomFlexEdit.CMGotFocus(var Message : TMessage);
{$ELSE}
procedure TO32CustomFlexEdit.CMGotFocus(var Message : TLMSetFocus);
{$ENDIF}
begin
inherited;
if Enabled and MultiLineEnabled then begin
if FDisplayedLines <> FEditLines.FocusedLines then begin
SetDisplayedLines(FEditLines.FocusedLines);
AdjustHeight;
end;
end;
{$IFNDEF LCL} // AutoSelect is False by default in LCL TEdit
if AutoSelect then
SelectAll;
{$ENDIF}
SaveEditString;
end;
{=====}
{$IFNDEF LCL}
procedure TO32CustomFlexEdit.CMLostFocus(var Message : TMessage);
{$ELSE}
procedure TO32CustomFlexEdit.CMLostFocus(var Message : TLMKillFocus);
{$ENDIF}
begin
inherited;
if Enabled and MultiLineEnabled then begin
if FMouseInControl then begin
if FDisplayedLines <> FEditLines.MouseOverLines then
SetDisplayedLines(FEditLines.MouseOverLines);
end else begin
if FDisplayedLines <> FEditLines.DefaultLines then
SetDisplayedLines(FEditLines.DefaultLines);
end;
AdjustHeight;
end;
end;
{=====}
{ - added}
procedure TO32CustomFlexEdit.CMFontChanged(var Message: TMessage);
begin
inherited;
AdjustHeight;
end;
{=====}
function TO32CustomFlexEdit.GetText: String;
begin
result := FStrings.Text;
end;
{=====}
procedure TO32CustomFlexEdit.SetText(const Value: String);
var
buffer: String;
i : Integer;
begin
buffer := Value;
if buffer <> '' then begin
if not MultiLineEnabled then
{strip out cr and lf's}
// for i := Length(buffer) downto 0 do <== TurboPower bug!
for i := Length(buffer) downto 1 do
if (buffer[i] = #13) or (buffer[i] = #10) then begin
Delete(buffer, i, 1);
if ((buffer[i - 1] <> ' ') and (buffer[i - 1] <> #10)
and (buffer[i - 1] <> #13))and (buffer[i] <> ' ') then
Insert(' ', buffer, i);
end;
end;
FStrings.Text := buffer;
SetTextBuf(PAnsiChar(buffer));
if Borders.Active then Borders.RedrawControl;
end;
{=====}
function TO32CustomFlexEdit.GetColor: TColor;
begin
Result := inherited Color;
end;
{=====}
procedure TO32CustomFlexEdit.SetColor( Value: TColor );
begin
if Color <> Value then begin
inherited Color := Value;
FColor := Value;
if Borders.Active then Borders.RedrawControl;
end;
end;
{=====}
procedure TO32CustomFlexEdit.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if (Key = Char(VK_RETURN)) then
if not FWantReturns then
Key := #0
else begin
if TFlexEditStrings(FStrings).Count >= FMaxLines then
Key := #0;
end;
end;
{=====}
procedure TO32CustomFlexEdit.CreateWnd;
begin
if (FUpdating > 0) then exit;
inherited CreateWnd;
{force button placement}
SetBounds(Left, Top, Width, Height);
{$IFDEF ButtonOkay}
FButton.Enabled := GetButtonEnabled;
{$ENDIF}
AdjustHeight;
if Validation <> nil then
Validation.AttachTo(Self);
end;
{$IFNDEF LCL} //With LCL, will never be called since not in ancestor
procedure TO32CustomFlexEdit.CreateWindowHandle(const Params: TCreateParams);
begin
if (FUpdating > 0) then exit;
if not HandleAllocated then begin
if (csDesigning in ComponentState) then
inherited
else begin
with Params do
WindowHandle := CreateWindowEx(ExStyle, WinClassName, '', Style,
X, Y, Width, Height, WndParent, 0, WindowClass.HInstance,
Param);
SendMessage(WindowHandle, WM_SETTEXT, 0, Longint(Caption));
end;
end;
end;
{$ENDIF}
{=====}
procedure TO32CustomFlexEdit.AdjustHeight;
var
DC: HDC;
SaveFont: HFont;
I: Integer;
SysMetrics, Metrics: TTextMetric;
Str: String;
begin
if (FUpdating > 0) then exit;
if FCreating then exit;
DC := GetDC(0);
GetTextMetrics(DC, SysMetrics);
SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, Metrics);
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
if NewStyleControls then
begin
if Ctl3D then I := 8 else I := 6;
I := GetSystemMetrics(SM_CYBORDER) * I;
end else
begin
I := SysMetrics.tmHeight;
if I > Metrics.tmHeight then I := Metrics.tmHeight;
I := I div 4 + GetSystemMetrics(SM_CYBORDER) * 4;
end;
Height := (Metrics.tmHeight * FDisplayedLines) + I;
if Borders.Active and not FCreating then begin
Str := Text;
Borders.RedrawControl;
Text := Str;
end;
end;
{=====}
function TO32CustomFlexEdit.GetButtonEnabled : Boolean;
begin
result := (not ReadOnly);
end;
{=====}
procedure TO32CustomFlexEdit.SetMaxLines(Value: Integer);
var
buffer: String;
begin
if Value <> FMaxLines then begin
FMaxLines := Value;
TFlexEditStrings(FStrings).Capacity := FMaxLines;
buffer := FStrings.Text;
if buffer <> '' then
while (buffer[Length(buffer)] = #13) or (buffer[Length(buffer)] = #10) do
Delete(buffer, Length(buffer), 1);
FStrings.Text := buffer;
end;
end;
{=====}
procedure TO32CustomFlexEdit.SaveEditString;
begin
if (Text <> FSaveEdit) then
FSaveEdit := Text;
end;
{=====}
procedure TO32CustomFlexEdit.DoOnChange;
begin
if Assigned(OnChange) then
OnChange(Self);
end;
{=====}
function TO32CustomFlexEdit.GetButtonWidth : Integer;
begin
if FShowButton then begin
Result := GetSystemMetrics(SM_CXHSCROLL);
if Assigned(FButtonGlyph) and not FButtonGlyph.Empty then
if FButtonGlyph.Width + 4 > Result then
Result := FButtonGlyph.Width + 4;
end else
Result := 0;
end;
{=====}
function TO32CustomFlexEdit.GetButtonGlyph : TBitmap;
begin
if not Assigned(FButtonGlyph) then
FButtonGlyph := TBitmap.Create;
Result := FButtonGlyph
end;
{=====}
procedure TO32CustomFlexEdit.GlyphChanged;
begin
end;
{=====}
procedure TO32CustomFlexEdit.Loaded;
begin
inherited Loaded;
{$IFDEF ButtonOkay}
if Assigned(FButtonGlyph) then
FButton.Glyph.Assign(FButtonGlyph);
{$ENDIF}
end;
{=====}
{ - rewritten to solve the "Text disappearing at alignment change" bug. }
procedure TO32CustomFlexEdit.SetAlignment(Value: TAlignment);
var
Str: string;
begin
{$IFDEF LCL}
if Value <> taLeftJustify then
Exit; {taCenter and taRightJustify not supported and crash IDE, so ignore}
{$ENDIF}
if FAlignment <> Value then
begin
Str := Text;
FAlignment := Value;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
Text := Str;
end;
end;
{=====}
function TO32CustomFlexEdit.MultiLineEnabled: Boolean;
begin
{ The control is only multi-line able if either WordWrap or WantReturns is }
{ set and Password char is not being used }
result := (FWantReturns or FWordWrap) and (PasswordChar = #0);
end;
{=====}
procedure TO32CustomFlexEdit.ButtonClick;
var
P: TPoint;
begin
if (Assigned(FOnButtonClick)) then begin
{Get the screen coordinates of the bottom-left or bottom-right corner of
the control.}
if PopupAnchor = paLeft then
P := Point(Left, Top + Height)
else
P := Point(Left + Width, Top + Height);
{Call the user defined event handler, passing the desired popup point}
FOnButtonClick(Self, P);
end;
end;
{=====}
procedure TO32CustomFlexEdit.Restore;
{-restore the previous contents of the FlexEdit}
var
CursorPos: Integer;
begin
BeginUpdate;
CursorPos := SelStart;
Text := FSaveEdit;
Repaint;
DoOnChange;
SelStart := CursorPos;
EndUpdate;
end;
{=====}
procedure TO32CustomFlexEdit.BeginUpdate;
begin
Inc(FUpdating);
Validation.BeginUpdate;
end;
{=====}
procedure TO32CustomFlexEdit.EndUpdate;
begin
Dec(FUpdating);
Validation.EndUpdate;
if (FUpdating < 0) then
FUpdating := 0;
end;
{=====}
procedure TO32CustomFlexEdit.SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
var
CHgt : Integer;
begin
if (FUpdating > 0) then exit;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
if not HandleAllocated then
Exit;
{$IFDEF ButtonOkay}
if not FShowButton then begin
FButton.Height := 0;
FButton.Width := 0;
Exit;
end;
CHgt := ClientHeight;
if BorderStyle = bsNone then begin
FButton.Height := CHgt;
FButton.Width := GetButtonWidth;
FButton.Left := Width - FButton.Width;
FButton.Top := 0;
end else if Ctl3D then begin
FButton.Height := CHgt;
FButton.Width := GetButtonWidth;
FButton.Left := Width - FButton.Width - 4;
FButton.Top := 0;
end else begin
FButton.Height := CHgt - 2;
FButton.Width := GetButtonWidth;
{$IFNDEF ButtonNotChild}
FButton.Left := Width - FButton.Width - 1;
FButton.Top := 1;
{$ELSE}
FButton.Left := Left + Width - FButton.Width - 1;
FButton.Top := Top + 1;
{$ENDIF}
end;
{$ENDIF}
end;
{=====}
procedure TO32CustomFlexEdit.SetButtonGlyph(Value : TBitmap);
begin
if not Assigned(FButtonGlyph) then
FButtonGlyph := TBitmap.Create;
if not Assigned(Value) then begin
FButtonGlyph.Free;
FButtonGlyph := TBitmap.Create;
end else
FButtonGlyph.Assign(Value);
GlyphChanged;
{$IFDEF ButtonOkay}
FButton.Glyph.Assign(FButtonGlyph);
{$ENDIF}
SetBounds(Left, Top, Width, Height);
end;
{=====}
procedure TO32CustomFlexEdit.SetShowButton(Value : Boolean);
begin
if Value <> FShowButton then begin
FShowButton := Value;
{force resize and redisplay of button}
SetBounds(Left, Top, Width, Height);
end;
end;
{=====}
function TO32CustomFlexEdit.GetBoolean: Boolean;
begin
result := (AnsiUpperCase(Text) = AnsiUppercase(RSTrue));
end;
{=====}
function TO32CustomFlexEdit.GetYesNo: Boolean;
begin
result := (AnsiUpperCase(Text) = AnsiUppercase(RSYes));
end;
{=====}
function TO32CustomFlexEdit.GetDateTime: TDateTime;
begin
try
result := StrToDateTime(Text);
except
result := 0;
end;
end;
{=====}
function TO32CustomFlexEdit.GetDouble: Double;
begin
try
result := StrToFloat(Text);
except
result := -1;
end;
end;
{=====}
function TO32CustomFlexEdit.GetExtended: Extended;
begin
{Note: StrToFloat returns an Extended}
try
result := StrToFloat(Text);
except
result := -1;
end;
end;
{=====}
function TO32CustomFlexEdit.GetInteger: Integer;
begin
result := StrToIntDef(Text, -1);
end;
{=====}
function TO32CustomFlexEdit.GetStrings: TStrings;
begin
result := TStrings(FStrings);
end;
{=====}
function TO32CustomFlexEdit.GetVariant: Variant;
begin
result := Text;
end;
{=====}
procedure TO32CustomFlexEdit.SetBoolean(Value: Boolean);
begin
if Value then
Text := 'True'
else
Text := 'False';
end;
{=====}
procedure TO32CustomFlexEdit.SetYesNo(Value: Boolean);
begin
if Value then
Text := 'Yes'
else
Text := 'No';
end;
{=====}
procedure TO32CustomFlexEdit.SetDateTime(Value: TDateTime);
begin
Text := DateTimeToStr(Value);
end;
{=====}
(*
procedure TO32CustomFlexEdit.SetDataType(Value : TO32FlexEditDataType);
begin
{ TODO : Implement }
end;
{=====}
*)
procedure TO32CustomFlexEdit.SetDouble(Value: Double);
begin
Text := FloatToStr(Value);
end;
{=====}
procedure TO32CustomFlexEdit.SetExtended(Value: Extended);
begin
Text := FloatToStr(Value);
end;
{=====}
procedure TO32CustomFlexEdit.SetInteger(Value: Integer);
begin
Text := IntToStr(Value);
end;
{=====}
procedure TO32CustomFlexEdit.SetStrings(Value: TStrings);
begin
FStrings.Assign(Value);
Invalidate;
end;
{=====}
procedure TO32CustomFlexEdit.SetVariant(Value: Variant);
begin
try
Text := Value;
except
Text := '';
end;
end;
{=====}
procedure TO32CustomFlexEdit.SetDisplayedLines(Value: Integer);
var
buffer: String;
begin
if Value <> FDisplayedLines then begin
buffer := Text;
FDisplayedLines := Value;
AdjustHeight;
Text:= Buffer;
end;
end;
{=====}
procedure TO32CustomFlexEdit.SetWordWrap(Value: Boolean);
var
buffer: String;
begin
if Value <> FWordWrap then
begin
buffer := Text;
FWordWrap := Value;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
Text:= buffer;
end;
end;
{=====}
procedure TO32CustomFlexEdit.SetWantReturns (Value : Boolean);
var
buffer: String;
begin
if Value <> FWantReturns then
begin
buffer := Text;
FWantReturns := Value;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
Text:= buffer;
end;
end;
{=====}
procedure TO32CustomFlexEdit.SetWantTabs(Value : Boolean);
var
buffer: String;
begin
if Value <> FWantTabs then
begin
buffer := Text;
FWantTabs := Value;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
Text:= buffer;
end;
end;
{$IFDEF LCL}
// Eliminates LCL "[Type1] can not have [Type2] as child" runtime message,
// but button still doesn't work with all widgetsets. See Lazarus bug 7097.
function TO32CustomFlexEdit.ChildClassAllowed(ChildClass: TClass): Boolean;
begin
Result := True;
end;
{$ENDIF}
end.
Reference in New Issue View Git Blame Copy Permalink