lazarus-ccr/components/orpheus/ovcsf.pas

2049 lines
53 KiB
ObjectPascal

{*********************************************************}
{* OVCSF.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}
unit ovcsf;
{-Simple field visual component}
interface
uses
{$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF}
Classes, Controls, Graphics, SysUtils,
OvcBase, OvcColor, OvcCaret, OvcConst, OvcData, OvcEF, OvcExcpt,
OvcIntl, OvcMisc, OvcStr;
type
{simple field type names}
TSimpleDataType = (
sftString, sftChar, sftBoolean, sftYesNo,
sftLongInt, sftWord, sftInteger, sftByte, sftShortInt,
sftReal, sftExtended, sftDouble, sftSingle, sftComp);
type
TOvcCustomSimpleField = class(TOvcBaseEntryField)
{.Z+}
protected {private}
{property instance variables}
FSimpleDataType : TSimpleDataType; {data type for this field}
FPictureMask : AnsiChar; {picture mask name}
function sfGetDataType(Value : TSimpleDataType) : Byte;
{-return a Byte value representing the type of this field}
procedure sfResetFieldProperties(FT : TSimpleDataType);
{-reset field properties}
procedure sfSetDefaultRanges;
{-set default range values based on the field type}
protected
procedure CreateWnd;
override;
procedure efEdit(var Msg : TMessage; Cmd : Word);
override;
{-process the specified editing command}
function efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar;
override;
{-return the display string in Dest and a pointer as the result}
procedure efIncDecValue(Wrap : Boolean; Delta : Double);
override;
{-increment field by Delta}
function efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word;
override;
{-transfer data to/from the entry fields}
{virtual property methods}
procedure sfSetDataType(Value : TSimpleDataType);
virtual;
{-set the data type for this field}
procedure sfSetPictureMask(Value: AnsiChar);
virtual;
{-set the picture mask}
public
procedure Assign(Source : TPersistent);
override;
constructor Create(AOwner: TComponent);
override;
function efValidateField : Word;
override;
{-validate contents of field; result is error code or 0}
{.Z-}
{public properties}
property DataType : TSimpleDataType
read FSimpleDataType
write sfSetDataType;
property PictureMask : AnsiChar
read FPictureMask
write sfSetPictureMask;
end;
TOvcSimpleField = class(TOvcCustomSimpleField)
published
{inherited properties}
property DataType; {needs to loaded before most other properties}
{$IFDEF VERSION4}
property Anchors;
property Constraints;
property DragKind;
{$ENDIF}
property AutoSize;
property BorderStyle;
property CaretIns;
property CaretOvr;
property Color;
property ControlCharColor;
property Controller;
property Ctl3D;
property Borders;
property DecimalPlaces;
property DragCursor;
property DragMode;
property EFColors;
property Enabled;
property Font;
property LabelInfo;
property MaxLength;
property Options;
property PadChar;
property ParentColor;
{$IFNDEF LCL}
property ParentCtl3D;
{$ENDIF}
property ParentFont;
property ParentShowHint;
property PasswordChar;
property PictureMask;
property PopupMenu;
property RangeHi stored False;
property RangeLo stored False;
property ShowHint;
property TabOrder;
property TabStop default True;
property Tag;
property TextMargin;
property Uninitialized;
property Visible;
property ZeroDisplay;
property ZeroDisplayValue;
{inherited events}
property AfterEnter;
property AfterExit;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnError;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
property OnMouseWheel;
property OnUserCommand;
property OnUserValidation;
end;
implementation
{*** TOvcCustomSimpleField ***}
procedure TOvcCustomSimpleField.Assign(Source : TPersistent);
var
SF : TOvcCustomSimpleField absolute Source;
begin
if (Source <> nil) and (Source is TOvcCustomSimpleField) then begin
DataType := SF.DataType;
AutoSize := SF.AutoSize;
BorderStyle := SF.BorderStyle;
Color := SF.Color;
ControlCharColor := SF.ControlCharColor;
DecimalPlaces := SF.DecimalPlaces;
EFColors.Error.Assign(SF.EFColors.Error);
EFColors.Highlight.Assign(SF.EFColors.Highlight);
MaxLength := SF.MaxLength;
Options := SF.Options;
PadChar := SF.PadChar;
PasswordChar := SF.PasswordChar;
PictureMask := SF.PictureMask;
RangeHi := SF.RangeHi;
RangeLo := SF.RangeLo;
TextMargin := SF.TextMargin;
Uninitialized := SF.Uninitialized;
ZeroDisplay := SF.ZeroDisplay;
ZeroDisplayValue := SF.ZeroDisplayValue;
end else
inherited Assign(Source);
end;
constructor TOvcCustomSimpleField.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSimpleDataType := sftString;
FPictureMask := pmAnyChar;
efFieldClass := fcSimple;
efDataType := sfGetDataType(FSimpleDataType);
efPicture[0] := pmAnyChar;
efPicture[1] := #0;
end;
procedure TOvcCustomSimpleField.CreateWnd;
var
P : array[0..MaxEditLen+1] of Byte;
begin
{save field data}
if efSaveData then
efTransfer(@P, otf_GetData);
inherited CreateWnd;
sfSetDefaultRanges;
efSetInitialValue;
{if we saved the field data, restore it}
if efSaveData then
efTransfer(@P, otf_SetData);
{set save data flag}
efSaveData := True;
end;
procedure TOvcCustomSimpleField.efEdit(var Msg : TMessage; Cmd : Word);
{-process the specified editing command}
procedure EditSimple(var Msg : TMessage; Cmd : Word);
{-process the specified editing command for String and PChar fields}
label
ExitPoint;
var
SaveHPos : Word;
DelEnd : Word;
Len : Word;
Ch : AnsiChar;
PrevCh : AnsiChar;
MF : ShortInt;
HaveSel : Boolean;
SelExtended : Boolean;
function CharIsOK : Boolean;
{-return true if Ch can be added to the string}
var
PrevCh : AnsiChar;
begin
if efIsNumericType then
if Ch = IntlSupport.DecimalChar then
Ch := pmDecimalPt
else if Ch = pmDecimalPt then
Ch := #0;
if (Ch < ' ') and not (sefLiteral in sefOptions) then begin
CharIsOK := False;
Exit;
end;
if efHPos = 0 then
PrevCh := ' '
else
PrevCh := efEditSt[efHPos-1];
CharIsOK := efCharOK(efPicture[0], Ch, PrevCh, True);
if efIsNumericType and (Ch = pmDecimalPt) then
Ch := IntlSupport.DecimalChar;
end;
function CheckAutoAdvance(SP : Integer) : Boolean;
{-see if we need to auto-advance to next/previous field}
begin
CheckAutoAdvance := False;
if (SP < 0) and
(efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin
efMoveFocusToPrevField;
CheckAutoAdvance := True;
end else if (SP >= MaxLength) then
if (Cmd = ccChar) and
(efoAutoAdvanceChar in Controller.EntryOptions) then begin
efMoveFocusToNextField;
CheckAutoAdvance := True;
end else if (Cmd <> ccChar) and
(efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin
efMoveFocusToNextField;
CheckAutoAdvance := True;
end;
end;
procedure FixSelValues;
var
I : Integer;
begin
if efSelStart > efSelEnd then begin
I := efSelStart;
efSelStart := efSelEnd;
efSelEnd := I;
end;
end;
procedure UpdateSel;
begin
if efSelStart = SaveHPos then
efSelStart := efHPos
else
efSelEnd := efHPos;
FixSelValues;
end;
procedure WordLeftPrim;
begin
Dec(efHPos);
while (efHPos >= 0) and ((efHPos >= Len) or (efEditSt[efHPos] = ' ')) do
Dec(efHPos);
while (efHPos >= 0) and (efEditSt[efHPos] <> ' ') do
Dec(efHPos);
Inc(efHPos);
end;
procedure WordRightPrim;
begin
if efEditSt[efHPos] <> ' ' then
Inc(efHPos);
while (efHPos < Len) and (efEditSt[efHPos] <> ' ') do
Inc(efHPos);
while (efHPos < Len) and (efEditSt[efHPos] = ' ') do
Inc(efHPos);
end;
procedure DeleteSel;
begin
StrStDeletePrim(efEditSt, efSelStart, efSelEnd-efSelStart);
Len := StrLen(efEditSt);
efHPos := efSelStart;
efSelEnd := efHPos;
MF := 10;
end;
procedure PastePrim(P : PAnsiChar);
var
Ch : AnsiChar;
IsNum : Boolean;
begin
if HaveSel then
DeleteSel;
IsNum := efIsNumericType;
while P^ <> #0 do begin
Ch := P^;
if IsNum then
if Ch = IntlSupport.DecimalChar then
Ch := pmDecimalPt
else if (Ch = pmDecimalPt) or (Ch = ' ') then
Ch := #0;
if efCharOK(efPicture[0], Ch, #255, True) then begin
if (Len = MaxLength) and (efHPos < Len) and
(efoInsertPushes in Controller.EntryOptions) then begin
Dec(Len);
efEditSt[Len] := #0;
end;
if (Len < MaxLength) then begin
if efIsNumericType and (Ch = pmDecimalPt) then
Ch := IntlSupport.DecimalChar;
StrChInsertPrim(efEditSt, Ch, efHPos);
Inc(efHPos);
Inc(Len);
end;
MF := 10;
end;
Inc(P);
end;
end;
begin
HaveSel := efSelStart <> efSelEnd;
MF := Ord(HaveSel);
SaveHPos := efHPos;
SelExtended := False;
case Cmd of
ccAccept : {};
ccCtrlChar : Include(sefOptions, sefLiteral);
else
if Cmd <> ccChar then
Exclude(sefOptions, sefLiteral);
end;
Len := StrLen(efEditSt);
Exclude(sefOptions, sefCharOK);
case Cmd of
ccChar :
begin
Ch := AnsiChar(Lo(Msg.wParam));
if (sefAcceptChar in sefOptions) and CharIsOk then begin
Exclude(sefOptions, sefAcceptChar);
Exclude(sefOptions, sefLiteral);
if HaveSel then begin
DeleteSel;
if efHPos = 0 then
PrevCh := ' '
else
PrevCh := efEditSt[efHPos-1];
efCharOK(efPicture[0], Ch, PrevCh, True);
end;
if (sefInsert in sefOptions) then begin
if (Len = MaxLength) and (efHPos < Len) and
(efoInsertPushes in Controller.EntryOptions) then begin
Dec(Len);
efEditSt[Len] := #0;
end;
if (Len < MaxLength) then begin
StrChInsertPrim(efEditSt, Ch, efHPos);
Inc(efHPos);
CheckAutoAdvance(efHPos);
end else if not CheckAutoAdvance(efHPos) then
efConditionalBeep;
end else if (efHPos+1) <= MaxLength then begin
efEditSt[efHPos] := Ch;
if efHPos >= Len then
efEditSt[efHPos+1] := #0;
Inc(efHPos);
CheckAutoAdvance(efHPos);
end else begin
if not CheckAutoAdvance(efHPos) then
efConditionalBeep;
Dec(MF, 10);
end;
Inc(MF, 10);
end else begin
Exclude(sefOptions, sefLiteral);
if sefAcceptChar in sefOptions then
efConditionalBeep
else
goto ExitPoint;
end;
end;
ccMouse :
if Len > 0 then begin
efHPos := efGetMousePos(SmallInt(Msg.lParamLo));
{drag highlight initially if shift key is being pressed}
if (GetKeyState(vk_Shift) < 0) then begin
SelExtended := True;
if HaveSel then begin
if efHPos > efSelStart then
efSelEnd := efHPos
else
efSelStart := efHPos;
end else begin
efSelStart := SaveHPos;
efSelEnd := efHPos;
end;
FixSelValues;
end else begin
SetSelection(efHPos, efHPos);
efPositionCaret(False);
end;
end;
ccMouseMove :
if Len > 0 then begin
efHPos := efGetMousePos(SmallInt(Msg.lParamLo));
UpdateSel;
end;
ccDblClk :
if Len > 0 then begin
efHPos := efGetMousePos(SmallInt(Msg.lParamLo));
WordLeftPrim;
SaveHPos := efHPos;
efSelStart := SaveHPos;
efSelEnd := SaveHPos;
WordRightPrim;
UpdateSel;
end;
{$IFDEF LCL} //LCL form not seeing tab (?), so handle tab command here}
ccTab : efMoveFocusToNextField;
{$ENDIF}
ccLeft :
if efHPos > 0 then
Dec(efHPos)
else
CheckAutoAdvance(-1);
ccRight :
if efHPos < Len then
Inc(efHPos)
else
CheckAutoAdvance(MaxLength);
ccUp :
if (efoAutoAdvanceUpDown in Controller.EntryOptions) then
efMoveFocusToPrevField
else if (efoArrowIncDec in Options) and not (efoReadOnly in Options) then
IncreaseValue(True, 1)
else if efHPos > 0 then
Dec(efHPos)
else
CheckAutoAdvance(-1);
ccDown :
if (efoAutoAdvanceUpDown in Controller.EntryOptions) then
efMoveFocusToNextField
else if (efoArrowIncDec in Options) and not (efoReadOnly in Options) then
DecreaseValue(True, 1)
else if efHPos < Len then
Inc(efHPos)
else
CheckAutoAdvance(MaxLength);
ccWordLeft :
if efHPos > 0 then
WordLeftPrim
else
CheckAutoAdvance(-1);
ccWordRight :
if efHPos < Len then
WordRightPrim
else
CheckAutoAdvance(MaxLength);
ccHome :
efHPos := 0;
ccEnd :
efHPos := Len;
ccExtendLeft :
if efHPos > 0 then begin
Dec(efHPos);
UpdateSel;
end else
MF := -1;
ccExtendRight :
if efHPos < Len then begin
Inc(efHPos);
UpdateSel;
end else
MF := -1;
ccExtendHome :
begin
efHPos := 0;
UpdateSel;
end;
ccExtendEnd :
begin
efHPos := Len;
UpdateSel;
end;
ccExtWordLeft :
if efHPos > 0 then begin
WordLeftPrim;
UpdateSel;
end else
MF := -1;
ccExtWordRight :
if efHPos < Len then begin
WordRightPrim;
UpdateSel;
end else
MF := -1;
ccCut :
if HaveSel then
DeleteSel;
ccCopy : efCopyPrim;
ccPaste :
{for some reason, a paste action within the IDE}
{gets passed to the control. filter it out}
if not (csDesigning in ComponentState) then
PastePrim(PAnsiChar(Msg.lParam));
ccBack :
if HaveSel then
DeleteSel
else if efHPos > 0 then begin
Dec(efHPos);
StrStDeletePrim(efEditSt, efHPos, 1);
MF := 10;
end;
ccDel :
if HaveSel then
DeleteSel
else if efHPos < Len then begin
StrStDeletePrim(efEditSt, efHPos, 1);
MF := 10;
end;
ccDelWord :
if HaveSel then
DeleteSel
else if efHPos < Len then begin
{start deleting at the caret}
DelEnd := efHPos;
{delete all of the current word, if any}
if efEditSt[efHPos] <> ' ' then
while (efEditSt[DelEnd] <> ' ') and (DelEnd < Len) do
Inc(DelEnd);
{delete any spaces prior to the next word, if any}
while (efEditSt[DelEnd] = ' ') and (DelEnd < Len) do
Inc(DelEnd);
StrStDeletePrim(efEditSt, efHPos, DelEnd-efHPos);
MF := 10;
end;
ccDelLine :
if Len > 0 then begin
efEditSt[0] := #0;
efHPos := 0;
MF := 10;
end;
ccDelEol :
if efHPos < Len then begin
efEditSt[efHPos] := #0;
MF := 10;
end;
ccDelBol :
if Len > 0 then begin
StrStDeletePrim(efEditSt, 0, efHPos);
efHPos := 0;
MF := 10;
end;
ccIns :
begin
if sefInsert in sefOptions then
Exclude(sefOptions, sefInsert)
else
Include(sefOptions, sefInsert);
efCaret.InsertMode := (sefInsert in sefOptions);
end;
ccRestore : Restore;
ccAccept :
begin
Include(sefOptions, sefCharOK);
Include(sefOptions, sefAcceptChar);
Exit;
end;
ccDec :
DecreaseValue(True, 1);
ccInc :
IncreaseValue(True, 1);
ccCtrlChar, ccSuppress, ccPartial :
goto ExitPoint;
else
Include(sefOptions, sefCharOK);
goto ExitPoint;
end;
Exclude(sefOptions, sefAcceptChar);
case Cmd of
ccRestore, ccMouseMove, ccDblClk,
ccExtendLeft, ccExtendRight,
ccExtendHome, ccExtendEnd,
ccExtWordLeft, ccExtWordRight :
Inc(MF);
ccMouse :
if SelExtended then
Inc(MF);
ccCut, ccCopy, ccPaste : {};
else
efSelStart := efHPos;
efSelEnd := efHPos;
end;
ExitPoint:
if efPositionCaret(True) then
Inc(MF);
if MF >= 10 then
efFieldModified;
if MF > 0 then
Invalidate;
end;
procedure EditChar(var Msg : TMessage; Cmd : Word);
{-process the specified editing command for Char fields}
label
ExitPoint;
var
MF : Byte;
Ch : AnsiChar;
function CharIsOK : Boolean;
{-return true if Ch can be added to the string}
begin
if (Ch < ' ') and not (sefLiteral in sefOptions) then
CharIsOK := False
else
CharIsOK := efCharOK(efPicture[0], Ch, ' ', True);
end;
function CheckAutoAdvance(SP : Integer) : Boolean;
{-see if we need to auto-advance to next/previous field}
begin
CheckAutoAdvance := False;
if (SP < 0) and
(efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin
efMoveFocusToPrevField;
Result := True;
end else if (SP > 0) then
if (Cmd = ccChar) and
(efoAutoAdvanceChar in Controller.EntryOptions) then begin
efMoveFocusToNextField;
Result := True;
end else if (Cmd <> ccChar) and
(efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin
efMoveFocusToNextField;
Result := True;
end;
end;
procedure PastePrim(P : PAnsiChar);
begin
while P^ <> #0 do begin
Ch := P^;
if efCharOK(efPicture[0], Ch, #255, True) then begin
efEditSt[0] := Ch;
MF := 10;
Exit;
end;
Inc(P);
end;
end;
begin
MF := Ord(efSelStart <> efSelEnd);
case Cmd of
ccAccept : ;
ccCtrlChar :
Include(sefOptions, sefLiteral);
else
efHPos := 0;
if Cmd <> ccChar then
Exclude(sefOptions, sefLiteral);
end;
Exclude(sefOptions, sefCharOK);
case Cmd of
ccChar :
begin
Ch := AnsiChar(Lo(Msg.wParam));
if sefAcceptChar in sefOptions then
if CharIsOk then begin
efEditSt[0] := Ch;
efEditSt[1] := #0;
CheckAutoAdvance(1);
MF := 10;
end else
efConditionalBeep;
{end;}
sefOptions := sefOptions - [sefAcceptChar, sefLiteral];
end;
ccLeft, ccWordLeft :
CheckAutoAdvance(-1);
ccRight, ccWordRight :
CheckAutoAdvance(MaxLength);
ccUp :
if (efoAutoAdvanceUpDown in Controller.EntryOptions) then
efMoveFocusToPrevField
else
CheckAutoAdvance(-1);
ccDown :
if (efoAutoAdvanceUpDown in Controller.EntryOptions) then
efMoveFocusToNextField
else
CheckAutoAdvance(MaxLength);
ccRestore :
Restore;
ccExtendRight, ccExtendEnd, ccExtWordRight :
efSelEnd := 1;
ccMouseMove :
if efGetMousePos(SmallInt(Msg.lParamLo)) > 0 then
efSelEnd := 1
else
efSelEnd := 0;
ccDblClk :
efSelEnd := 1;
ccCopy : efCopyPrim;
ccPaste :
{for some reason, a paste action within the IDE}
{gets passed to the control. filter it out}
if not (csDesigning in ComponentState) then
PastePrim(PAnsiChar(Msg.lParam));
ccAccept :
begin
sefOptions := sefOptions + [sefCharOK, sefAcceptChar];
Exit;
end;
ccMouse, ccExtendLeft, ccExtendHome, ccExtWordLeft : ;
ccDec :
DecreaseValue(True, 1);
ccInc :
IncreaseValue(True, 1);
ccCtrlChar, ccSuppress, ccPartial :
goto ExitPoint;
else
Include(sefOptions, sefCharOK);
goto ExitPoint;
end;
Exclude(sefOptions, sefAcceptChar);
case Cmd of
ccRestore, ccMouseMove, ccDblClk, ccExtendRight,
ccExtendEnd, ccExtWordRight :
Inc(MF);
else
efSelStart := 0;
efSelEnd := 0;
end;
ExitPoint:
if efPositionCaret(True) then
Inc(MF);
if MF >= 10 then
efFieldModified;
if MF > 0 then
Invalidate;
end;
begin {edit}
case FSimpleDataType of
sftString,
sftLongInt, sftWord, sftInteger, sftByte, sftShortInt,
sftReal, sftExtended, sftDouble, sftSingle, sftComp :
EditSimple(Msg, Cmd);
sftChar, sftBoolean, sftYesNo :
EditChar(Msg, Cmd);
end;
end;
function TOvcCustomSimpleField.efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar;
{-return the display string in Dest and a pointer as the result}
var
Len : Word;
begin
Result := inherited efGetDisplayString(Dest, Size);
Len := StrLen(Dest);
if Len = 0 then
Exit;
if Uninitialized and not (sefHaveFocus in sefOptions) then begin
FillChar(Dest[0], Len, ' ');
Exit;
end;
if (efoPasswordMode in Options) then
FillChar(Dest[0], Len, PasswordChar);
if PadChar <> ' ' then begin
FillChar(Dest[Len], MaxLength-Len, PadChar);
Dest[MaxLength] := #0;
end;
end;
procedure TOvcCustomSimpleField.efIncDecValue(Wrap : Boolean; Delta : Double);
{-increment field by Delta}
var
S : TEditString;
procedure IncDecValueChar;
{-increment Char field by Delta}
var
C, CC, CL, CH, MC : AnsiChar;
OK : Boolean;
begin
{get valid range}
CL := efRangeLo.rtChar;
CH := efRangeHi.rtChar;
if CL = CH then begin
CL := #1;
CH := #255;
end;
{get current character}
C := efEditSt[0];
{get mask character}
MC := efPicture[0];
{exit if we're at the range limit and not allowed to wrap}
if (Delta < 0) and (C = CL) then begin
if not Wrap then
Exit;
end else if (Delta > 0) and (C = CH) then
if not Wrap then
Exit;
{find the next/prev allowable character}
OK := False;
repeat
repeat
if Delta = 1 then
Inc(C)
else
Dec(C);
CC := C;
efFixCase(MC, CC, ' ');
until efCharOK(MC, C, ' ', False) and (C = CC);
{check result to see if it's in valid range}
if (C >= CL) and (C <= CH) then
OK := True
else if Wrap then
OK := False
else
Exit;
until OK;
efTransfer(@C, otf_SetData);
efPerformRepaint(True);
end;
procedure IncDecValueBoolean;
var
Ch : AnsiChar;
B : Boolean;
begin
Ch := UpCaseChar(efEditSt[0]);
if Ch = IntlSupport.TrueChar then
Ch := IntlSupport.FalseChar
else
Ch := IntlSupport.TrueChar;
B := Ch = IntlSupport.TrueChar;
efTransfer(@B, otf_SetData);
efPerformRepaint(True);
end;
procedure IncDecValueYesNo;
var
Ch : AnsiChar;
B : Boolean;
begin
Ch := UpCaseChar(efEditSt[0]);
if Ch = IntlSupport.YesChar then
Ch := IntlSupport.NoChar
else
Ch := IntlSupport.YesChar;
B := Ch = IntlSupport.YesChar;
efTransfer(@B, otf_SetData);
efPerformRepaint(True);
end;
procedure IncDecValueLongInt;
var
L : LongInt;
begin
if efStr2Long(efEditSt, L) then begin
if (Delta < 0) and (L <= efRangeLo.rtLong) then
if Wrap then
L := efRangeHi.rtLong
else Exit
else if (Delta > 0) and (L >= efRangeHi.rtLong) then
if Wrap then
L := efRangeLo.rtLong
else Exit
else
Inc(L, Trunc(Delta));
{insure valid value}
if L < efRangeLo.rtLong then
L := efRangeLo.rtLong;
if L > efRangeHi.rtLong then
L := efRangeHi.rtLong;
efTransfer(@L, otf_SetData);
efPerformRepaint(True);
end;
end;
procedure IncDecValueReal;
var
Re : Real;
Code : Integer;
begin
{convert efEditSt to a real}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, Re, Code);
{$ELSE}
Val(String(S), Re, Code);
{$ENDIF}
if Code = 0 then begin
if (Delta < 0) and (Re <= efRangeLo.rtReal) then
if Wrap then
Re := efRangeHi.rtReal
else Exit
else if (Delta > 0) and (Re >= efRangeHi.rtReal) then
if Wrap then
Re := efRangeLo.rtReal
else Exit
else
Re := Re + Delta;
{insure valid value}
if Re < efRangeLo.rtReal then
Re := efRangeLo.rtReal;
if Re > efRangeHi.rtReal then
Re := efRangeHi.rtReal;
efTransfer(@Re, otf_SetData);
efPerformRepaint(True);
end;
end;
procedure IncDecValueExtended;
var
Ex : Extended;
Code : Integer;
begin
{convert efEditSt to an real}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, Ex, Code);
{$ELSE}
Val(String(S), Ex, Code);
{$ENDIF}
if Code = 0 then begin
if (Delta < 0) and (Ex <= efRangeLo.rtExt) then
if Wrap then
Ex := efRangeHi.rtExt
else Exit
else if (Delta > 0) and (Ex >= efRangeHi.rtExt) then
if Wrap then
Ex := efRangeLo.rtExt
else Exit
else
Ex := Ex + Delta;
{insure valid value}
if Ex < efRangeLo.rtExt then
Ex := efRangeLo.rtExt;
if Ex > efRangeHi.rtExt then
Ex := efRangeHi.rtExt;
efTransfer(@Ex, otf_SetData);
efPerformRepaint(True);
end;
end;
procedure IncDecValueDouble;
var
Db : Double;
Code : Integer;
begin
{convert efEditSt to an real}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, Db, Code);
{$ELSE}
Val(String(S), Db, Code);
{$ENDIF}
if Code = 0 then begin
if (Delta < 0) and (Db <= efRangeLo.rtExt) then
if Wrap then
Db := efRangeHi.rtExt
else Exit
else if (Delta > 0) and (Db >= efRangeHi.rtExt) then
if Wrap then
Db := efRangeLo.rtExt
else Exit
else
Db := Db + Delta;
{insure valid value}
if Db < efRangeLo.rtExt then
Db := efRangeLo.rtExt;
if Db > efRangeHi.rtExt then
Db := efRangeHi.rtExt;
efTransfer(@Db, otf_SetData);
efPerformRepaint(True);
end;
end;
procedure IncDecValueSingle;
var
Si : Single;
Code : Integer;
begin
{convert efEditSt to an real}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, Si, Code);
{$ELSE}
Val(String(S), Si, Code);
{$ENDIF}
if Code = 0 then begin
if (Delta < 0) and (Si <= efRangeLo.rtExt) then
if Wrap then
Si := efRangeHi.rtExt
else Exit
else if (Delta > 0) and (Si >= efRangeHi.rtExt) then
if Wrap then
Si := efRangeLo.rtExt
else Exit
else
Si := Si + Delta;
{insure valid value}
if Si < efRangeLo.rtExt then
Si := efRangeLo.rtExt;
if Si > efRangeHi.rtExt then
Si := efRangeHi.rtExt;
efTransfer(@Si, otf_SetData);
efPerformRepaint(True);
end;
end;
procedure IncDecValueComp;
var
{$IFNDEF FPC}
Co : Comp;
{$ELSE}
{$IFDEF CPU86}
Co : Comp;
{$ELSE}
Co : Double;
{$ENDIF}
{$ENDIF}
Code : Integer;
begin
{convert efEditSt to an real}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, Co, Code);
{$ELSE}
Val(String(S), Co, Code);
{$ENDIF}
if Code = 0 then begin
if (Delta < 0) and (Co <= efRangeLo.rtExt) then
if Wrap then
Co := efRangeHi.rtExt
else Exit
else if (Delta > 0) and (Co >= efRangeHi.rtExt) then
if Wrap then
Co := efRangeLo.rtExt
else Exit
else
Co := Co + Delta;
{insure valid value}
if Co < efRangeLo.rtExt then
Co := efRangeLo.rtExt;
if Co > efRangeHi.rtExt then
Co := efRangeHi.rtExt;
efTransfer(@Co, otf_SetData);
efPerformRepaint(True);
end;
end;
begin
if not (sefHaveFocus in sefOptions) then
Exit;
case FSimpleDataType of
sftString : {not supported for this field type};
sftChar : IncDecValueChar;
sftBoolean : IncDecValueBoolean;
sftYesNo : IncDecValueYesNo;
sftLongInt,
sftWord,
sftInteger,
sftByte,
sftShortInt : IncDecValueLongInt;
sftReal : IncDecValueReal;
sftExtended : IncDecValueExtended;
sftDouble : IncDecValueDouble;
sftSingle : IncDecValueSingle;
sftComp : IncDecValueComp;
else
raise EOvcException.Create(GetOrphStr(SCInvalidParamValue));
end;
efPositionCaret(False);
end;
function TOvcCustomSimpleField.efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word;
{-transfer data to/from the entry fields}
var
S : TEditString;
procedure TransferString;
var
I : Integer;
begin
if TransferFlag = otf_GetData then
ShortString(DataPtr^) := StrPas(efEditSt)
else begin
if ShortString(DataPtr^) = '' then
efEditSt[0] := #0
else begin
StrPLCopy(efEditSt, ShortString(DataPtr^), MaxLength);
for I := 0 to Integer(StrLen(efEditSt))-1 do
efFixCase(efNthMaskChar(I), efEditSt[I], #255);
end;
end;
end;
procedure TransferChar;
begin
if TransferFlag = otf_GetData then
AnsiChar(DataPtr^) := efEditSt[0]
else begin
efEditSt[0] := AnsiChar(DataPtr^);
efEditSt[1] := #0;
end;
end;
procedure TransferBoolean;
begin
if TransferFlag = otf_GetData then
Boolean(DataPtr^) := (UpCaseChar(efEditSt[0]) = IntlSupport.TrueChar)
else begin
if Boolean(DataPtr^) then
efEditSt[0] := IntlSupport.TrueChar
else
efEditSt[0] := IntlSupport.FalseChar;
efEditSt[1] := #0;
end;
end;
procedure TransferYesNo;
begin
if TransferFlag = otf_GetData then
Boolean(DataPtr^) := (UpCaseChar(efEditSt[0]) = IntlSupport.YesChar)
else begin
if Boolean(DataPtr^) then
efEditSt[0] := IntlSupport.YesChar
else
efEditSt[0] := IntlSupport.NoChar;
efEditSt[1] := #0;
end;
end;
procedure TransferLongInt;
begin
if TransferFlag = otf_GetData then begin
if not efStr2Long(efEditSt, LongInt(DataPtr^)) then
LongInt(DataPtr^) := 0;
end else
efLong2Str(efEditSt, LongInt(DataPtr^));
end;
procedure TransferWord;
var
L : LongInt;
begin
if TransferFlag = otf_GetData then begin
if efStr2Long(efEditSt, L) then
Word(DataPtr^) := Word(L)
else
Word(DataPtr^) := 0;
end else
efLong2Str(efEditSt, Word(DataPtr^));
end;
procedure TransferInteger;
var
L : LongInt;
begin
if TransferFlag = otf_GetData then begin
if efStr2Long(efEditSt, L) then
SmallInt(DataPtr^) := SmallInt(L)
else
SmallInt(DataPtr^) := 0;
end else
efLong2Str(efEditSt, SmallInt(DataPtr^));
end;
procedure TransferByte;
var
L : LongInt;
begin
if TransferFlag = otf_GetData then begin
if efStr2Long(efEditSt, L) then
Byte(DataPtr^) := Byte(L)
else
Byte(DataPtr^) := 0;
end else
efLong2Str(efEditSt, Byte(DataPtr^));
end;
procedure TransferShortInt;
var
L : LongInt;
begin
if TransferFlag = otf_GetData then begin
if efStr2Long(efEditSt, L) then
ShortInt(DataPtr^) := ShortInt(L)
else
ShortInt(DataPtr^) := 0;
end else
efLong2Str(efEditSt, ShortInt(DataPtr^));
end;
procedure TransferReal;
label
UseExp;
var
Code : Integer;
I : Cardinal;
R : Real;
begin
if TransferFlag = otf_GetData then begin
StrCopy(S, efEditSt);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(PAnsiChar(@S[0]), R, Code);
{$ELSE}
Val(String(PAnsiChar(@S[0])), R, Code);
{$ENDIF}
if Code <> 0 then
R := 0;
Real(DataPtr^) := R;
end else begin
{try to use regular notation}
R := Real(DataPtr^);
if StrScan(efPicture, pmScientific) <> nil then
goto UseExp;
Str(R:0:DecimalPlaces, S);
{trim trailing 0's if appropriate}
if StrScan(S, pmDecimalPt) <> nil then
TrimTrailingZerosPChar(S);
{does it fit?}
if StrLen(S) > MaxLength then begin
{won't fit--use scientific notation}
UseExp:
if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then
Str(R:9+DecimalPlaces, S)
else
Str(R:MaxLength, S);
TrimAllSpacesPChar(S);
TrimEmbeddedZerosPChar(S);
end;
{convert decimal point}
if StrChPos(S, pmDecimalPt, I) then
S[I] := IntlSupport.DecimalChar;
StrLCopy(efEditSt, S, MaxLength);
end;
end;
procedure TransferExtended;
label
UseExp;
var
Code : Integer;
I : Cardinal;
E : Extended;
begin
if TransferFlag = otf_GetData then begin
StrCopy(S, efEditSt);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, E, Code);
{$ELSE}
Val(String(S), E, Code);
{$ENDIF}
if Code <> 0 then
E := 0;
Extended(DataPtr^) := E;
end else begin
{try to use regular notation}
E := Extended(DataPtr^);
if StrScan(efPicture, pmScientific) <> nil then
goto UseExp;
Str(E:0:DecimalPlaces, S);
{trim trailing 0's if appropriate}
if StrScan(S, pmDecimalPt) <> nil then
TrimTrailingZerosPChar(S);
{does it fit?}
if StrLen(S) > MaxLength then begin
{won't fit--use scientific notation}
UseExp:
if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then
Str(E:9+DecimalPlaces, S)
else
Str(E:MaxLength, S);
TrimAllSpacesPChar(S);
TrimEmbeddedZerosPChar(S);
end;
{convert decimal point}
if StrChPos(S, pmDecimalPt, I) then
S[I] := IntlSupport.DecimalChar;
StrLCopy(efEditSt, S, MaxLength);
end;
end;
procedure TransferDouble;
label
UseExp;
var
Code : Integer;
I : Cardinal;
D : Double;
begin
if TransferFlag = otf_GetData then begin
StrCopy(S, efEditSt);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(PAnsiChar(@S[0]), D, Code);
{$ELSE}
Val(String(PAnsiChar(@S[0])), D, Code);
{$ENDIF}
if Code <> 0 then
D := 0;
Double(DataPtr^) := D;
end else begin
{try to use regular notation}
D := Double(DataPtr^);
if StrScan(efPicture, pmScientific) <> nil then
goto UseExp;
Str(D:0:DecimalPlaces, S);
{trim trailing 0's if appropriate}
if StrScan(S, pmDecimalPt) <> nil then
TrimTrailingZerosPChar(S);
{does it fit?}
if StrLen(S) > MaxLength then begin
{won't fit--use scientific notation}
UseExp:
if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then
Str(D:9+DecimalPlaces, S)
else
Str(D:MaxLength, S);
TrimAllSpacesPChar(S);
TrimEmbeddedZerosPChar(S);
end;
{convert decimal point}
if StrChPos(S, pmDecimalPt, I) then
S[I] := IntlSupport.DecimalChar;
StrLCopy(efEditSt, S, MaxLength);
end;
end;
procedure TransferSingle;
label
UseExp;
var
Code : Integer;
I : Cardinal;
G : Single;
begin
if TransferFlag = otf_GetData then begin
StrCopy(S, efEditSt);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, G, Code);
{$ELSE}
Val(String(S), G, Code);
{$ENDIF}
if Code <> 0 then
G := 0;
Single(DataPtr^) := G;
end else begin
{try to use regular notation}
G := Single(DataPtr^);
if StrScan(efPicture, pmScientific) <> nil then
goto UseExp;
Str(G:0:DecimalPlaces, S);
{trim trailing 0's if appropriate}
if StrScan(S, pmDecimalPt) <> nil then
TrimTrailingZerosPChar(S);
{does it fit?}
if StrLen(S) > MaxLength then begin
{won't fit--use scientific notation}
UseExp:
if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then
Str(G:9+DecimalPlaces, S)
else
Str(G:MaxLength, S);
TrimAllSpacesPChar(S);
TrimEmbeddedZerosPChar(S);
end;
{convert decimal point}
if StrChPos(S, pmDecimalPt, I) then
S[I] := IntlSupport.DecimalChar;
StrLCopy(efEditSt, S, MaxLength);
end;
end;
procedure TransferComp;
{-transfer data to or from Comp fields}
label
UseExp;
var
Code : Integer;
{$IFNDEF FPC}
C : Comp;
{$ELSE}
{$IFDEF CPU86}
C : Comp;
{$ELSE}
C : Double;
{$ENDIF}
{$ENDIF}
begin
if TransferFlag = otf_GetData then begin
StrCopy(S, efEditSt);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(PAnsiChar(@S[0]), C, Code);
{$ELSE}
Val(String(PAnsiChar(@S[0])), C, Code);
{$ENDIF}
if Code <> 0 then
C := 0;
{$IFNDEF FPC}
Comp(DataPtr^) := C;
{$ELSE}
{$IFDEF CPU86}
Comp(DataPtr^) := C;
{$ELSE}
Double(DataPtr^) := C;
{$ENDIF}
{$ENDIF}
end else begin
{try to use regular notation}
{$IFNDEF FPC}
C := Comp(DataPtr^);
{$ELSE}
{$IFDEF CPU86}
C := Comp(DataPtr^);
{$ELSE}
C := Double(DataPtr^);
{$ENDIF}
{$ENDIF}
if StrScan(efPicture, pmScientific) <> nil then
goto UseExp;
Str(C:0:DecimalPlaces, S);
{trim trailing 0's if appropriate}
if StrScan(S, pmDecimalPt) <> nil then
TrimTrailingZerosPChar(S);
{does it fit?}
if StrLen(S) > MaxLength then begin
{won't fit--use scientific notation}
UseExp:
Str(C:MaxLength, S);
TrimAllSpacesPChar(S);
TrimEmbeddedZerosPChar(S);
end;
StrLCopy(efEditSt, S, MaxLength);
end;
end;
begin {transfer}
if DataPtr = nil then begin
Result := 0;
Exit;
end;
case FSimpleDataType of
sftString : TransferString;
sftChar : TransferChar;
sftBoolean : TransferBoolean;
sftYesNo : TransferYesNo;
sftLongInt : TransferLongInt;
sftWord : TransferWord;
sftInteger : TransferInteger;
sftByte : TransferByte;
sftShortInt : TransferShortInt;
sftReal : TransferReal;
sftExtended : TransferExtended;
sftDouble : TransferDouble;
sftSingle : TransferSingle;
sftComp : TransferComp;
else
raise EOvcException.Create(GetOrphStr(SCInvalidParamValue));
end;
Result := inherited efTransfer(DataPtr, TransferFlag);
end;
function TOvcCustomSimpleField.efValidateField : Word;
{-validate contents of field; result is error code or 0}
var
S : TEditString;
procedure ValidateString;
var
L : Word;
begin
if sefGettingValue in sefOptions then
Exit;
if efoTrimBlanks in Options then
if sefHaveFocus in sefOptions then begin
L := StrLen(efEditSt);
TrimAllSpacesPChar(efEditSt);
if StrLen(efEditSt) <> L then
Invalidate;
end;
end;
procedure ValidateChar;
begin
if (efRangeLo.rtChar <> efRangeHi.rtChar) and
((efEditSt[0] < efRangeLo.rtChar) or (efEditSt[0] > efRangeHi.rtChar)) then
Result := oeRangeError;
end;
procedure ValidateBoolean;
begin
if (UpCaseChar(efEditSt[0]) <> IntlSupport.TrueChar) and
(UpCaseChar(efEditSt[0]) <> IntlSupport.FalseChar) then
Result := oeRangeError;
end;
procedure ValidateYesNo;
begin
if (UpCaseChar(efEditSt[0]) <> IntlSupport.YesChar) and
(UpCaseChar(efEditSt[0]) <> IntlSupport.NoChar) then
Result := oeRangeError;
end;
procedure ValidateLongInt;
var
L : LongInt;
begin
if not efStr2Long(efEditSt, L) then
Result := oeInvalidNumber
else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
efTransfer(@L, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateWord;
var
L : LongInt;
begin
if not efStr2Long(efEditSt, L) then
Result := oeInvalidNumber
else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
efTransfer(@L, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateInteger;
var
L : LongInt;
I : Integer;
begin
if not efStr2Long(efEditSt, L) then
Result := oeInvalidNumber
else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
I := L;
efTransfer(@I, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateByte;
var
L : LongInt;
B : Byte;
begin
if not efStr2Long(efEditSt, L) then
Result := oeInvalidNumber
else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
B := L;
efTransfer(@B, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateShortInt;
var
L : LongInt;
Si : ShortInt;
begin
if not efStr2Long(efEditSt, L) then
Result := oeInvalidNumber
else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
Si := L;
efTransfer(@Si, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateReal;
var
R : Real;
Code : Integer;
begin
{convert efEditSt to a real}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, R, Code);
{$ELSE}
Val(String(S), R, Code);
{$ENDIF}
{format OK?}
if Code <> 0 then
Result := oeInvalidNumber
else if (R < efRangeLo.rtReal) or (R > efRangeHi.rtReal) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
efTransfer(@R, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateExtended;
var
E : Extended;
Code : Integer;
begin
{convert efEditSt to an extended}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, E, Code);
{$ELSE}
Val(String(S), E, Code);
{$ENDIF}
if Code <> 0 then
Result := oeInvalidNumber
else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
efTransfer(@E, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateDouble;
var
E : Extended;
D : Double;
Code : Integer;
begin
{convert efEditSt to an extended}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, E, Code);
{$ELSE}
Val(String(S), E, Code);
{$ENDIF}
if Code <> 0 then
Result := oeInvalidNumber
else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
D := E;
efTransfer(@D, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateSingle;
var
E : Extended;
Si : Single;
Code : Integer;
begin
{convert efEditSt to an extended}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, E, Code);
{$ELSE}
Val(String(S), E, Code);
{$ENDIF}
if Code <> 0 then
Result := oeInvalidNumber
else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
Si := E;
efTransfer(@Si, otf_SetData);
Invalidate;
end;
end;
end;
procedure ValidateComp;
var
E : Extended;
{$IFNDEF FPC}
C : Comp;
{$ELSE}
{$IFDEF CPU86}
C : Comp;
{$ELSE}
C : Double;
{$ENDIF}
{$ENDIF}
Code : Integer;
begin
{convert efEditSt to an extended}
StrLCopy(S, efEditSt, 80);
FixRealPrim(S, IntlSupport.DecimalChar);
{$IFNDEF FPC}
Val(S, C, Code);
{$ELSE}
Val(String(S), C, Code);
{$ENDIF}
E := C;
if Code <> 0 then
Result := oeInvalidNumber
else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then
Result := oeRangeError
else begin
if sefHaveFocus in sefOptions then
if not (sefGettingValue in sefOptions) then begin
efTransfer(@C, otf_SetData);
Invalidate;
end;
end;
end;
begin
Result := 0;
case FSimpleDataType of
sftString : ValidateString;
sftChar : ValidateChar;
sftBoolean : ValidateBoolean;
sftYesNo : ValidateYesNo;
sftLongInt : ValidateLongInt;
sftWord : ValidateWord;
sftInteger : ValidateInteger;
sftByte : ValidateByte;
sftShortInt : ValidateShortInt;
sftReal : ValidateReal;
sftExtended : ValidateExtended;
sftDouble : ValidateDouble;
sftSingle : ValidateSingle;
sftComp : ValidateComp;
end;
if not (sefUserValidating in sefOptions) then begin
{user may retrieve data from field. flag that we are doing}
{user validation to avoid calling this routine recursively}
Include(sefOptions, sefUserValidating);
DoOnUserValidation(Result);
Exclude(sefOptions, sefUserValidating);
end;
end;
procedure TOvcCustomSimpleField.sfSetDataType(Value : TSimpleDataType);
{-set the data type for this field}
begin
if FSimpleDataType <> Value then begin
FSimpleDataType := Value;
efDataType := sfGetDataType(FSimpleDataType);
Options := Options + [efoCaretToEnd];
efSetDefaultRange(efDataType);
{set defaults for this field type}
sfResetFieldProperties(FSimpleDataType);
if HandleAllocated then begin
{don't save data through create window}
efSaveData := False;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
end;
end;
end;
procedure TOvcCustomSimpleField.sfSetPictureMask(Value: AnsiChar);
{-set the picture mask}
var
Buf : array[0..1] of AnsiChar;
begin
if FPictureMask <> Value then begin
if Value in SimplePictureChars then begin
FPictureMask := Value;
if csDesigning in ComponentState then begin
efPicture[0] := Value;
efPicture[1] := #0;
Repaint;
end else begin
Buf[0] := Value;
Buf[1] := #0;
efChangeMask(Buf);
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
end;
end else
raise EInvalidPictureMask.Create(Value);
end;
end;
function TOvcCustomSimpleField.sfGetDataType(Value : TSimpleDataType) : Byte;
{-return a Byte value representing the type of this field}
begin
case Value of
sftString : Result := fidSimpleString;
sftChar : Result := fidSimpleChar;
sftBoolean : Result := fidSimpleBoolean;
sftYesNo : Result := fidSimpleYesNo;
sftLongInt : Result := fidSimpleLongInt;
sftWord : Result := fidSimpleWord;
sftInteger : Result := fidSimpleInteger;
sftByte : Result := fidSimpleByte;
sftShortInt : Result := fidSimpleShortInt;
sftReal : Result := fidSimpleReal;
sftExtended : Result := fidSimpleExtended;
sftDouble : Result := fidSimpleDouble;
sftSingle : Result := fidSimpleSingle;
sftComp : Result := fidSimpleComp;
else
raise EOvcException.Create(GetOrphStr(SCInvalidParamValue));
end;
end;
procedure TOvcCustomSimpleField.sfResetFieldProperties(FT : TSimpleDataType);
{-reset field properties based on current setings}
procedure Update(Len: Word; Mask: AnsiChar);
begin
MaxLength := Len;
FPictureMask := Mask;
efPicture[0] := Mask;
efPicture[1] := #0;
DecimalPlaces := 0;
end;
begin
case FT of
sftString : Update(15, pmAnyChar);
sftBoolean : Update(1, pmTrueFalse);
sftYesNo : Update(1, pmYesNo);
sftChar : Update(1, pmAnyChar);
sftLongInt : Update(11, pmWhole);
sftWord : Update(5, pmPositive);
sftInteger : Update(6, pmWhole);
sftByte : Update(3, pmPositive);
sftShortInt : Update(4, pmWhole);
sftReal : Update(14, pmDecimal);
sftExtended : Update(14, pmDecimal);
sftDouble : Update(14, pmDecimal);
sftSingle : Update(14, pmDecimal);
sftComp : Update(14, pmWhole);
else
raise EOvcException.Create(GetOrphStr(SCInvalidParamValue));
end;
end;
procedure TOvcCustomSimpleField.sfSetDefaultRanges;
{-set default range values based on the field type}
begin
case FSimpleDataType of
sftChar, sftBoolean, sftYesNo :
if efRangeLo.rtChar = efRangeHi.rtChar then
efSetDefaultRange(efDataType);
sftLongInt, sftWord, sftInteger, sftByte, sftShortInt :
if efRangeLo.rtLong = efRangeHi.rtLong then
efSetDefaultRange(efDataType);
sftReal :
if efRangeLo.rtReal = efRangeHi.rtReal then
efSetDefaultRange(efDataType);
sftExtended, sftDouble, sftSingle, sftComp :
if efRangeLo.rtExt = efRangeHi.rtExt then
efSetDefaultRange(efDataType);
else
efSetDefaultRange(efDataType);
end;
end;
end.