tsmask.pas

企业进销存管理系统

        if Result and ((MaskInput.TextPos <= Length(MaskInput.Text)) or (moFullCompare in Options)) then
        begin
            Result := CheckNextItems(Stack, StackPos, Options, MaskInput, NrOfMatches);
            if (not Result) and Matched and (CurNrOfMatches = NrOfMatches) and
               CanInsertLiteral(OldInput, Options) then
            begin
                MaskInput := OldInput;
                Result := CheckLiterals(Node, MaskInput, Options, Matched);
                if Result and ((MaskInput.TextPos <= Length(MaskInput.Text)) or (moFullCompare in Options)) then
                    Result := CheckNextItems(Stack, StackPos, Options, MaskInput, NrOfMatches);
            end;
        end;
    end
    else if Node.NodeType <> pntGroup then
    begin
        Result := CheckItem(Node, MaskInput, Options);
        if Result and ((MaskInput.TextPos <= Length(MaskInput.Text)) or (moFullCompare in Options)) then
            Result := CheckNextItems(Stack, StackPos, Options, MaskInput, NrOfMatches);
    end
    else
    begin
        Result := CheckSubItems(Stack, StackPos, Node.SubItems, 0, Options,
                                MaskInput, NrOfMatches);
    end;

    if Result then
    begin
        if (not (moCheckUnique in Options)) and (NrOfMatches = 0) then
        begin
            Inc(NrOfMatches);
            MaskInput.MatchedLiterals := MaskInput.Literals;
            MaskInput.InsertChars := Copy(MaskInput.Text, MaskInput.InsertPos, MaskInput.InsertLen);
        end
        else if (moCheckUnique in Options) and
                ((NrOfMatches <= 1) or (MaskInput.MinMatchedLiterals <> '')) then
        begin
            if NrOfMatches = 0 then
            begin
                Result := False;
                NrOfMatches := 1;
                MaskInput.MatchedLiterals := MaskInput.Literals;
                MaskInput.MinMatchedLiterals := MaskInput.Literals;
                MaskInput.InsertChars := Copy(MaskInput.Text, MaskInput.InsertPos, MaskInput.InsertLen);
            end
            else
            begin
                if MaskInput.Literals = MaskInput.MinMatchedLiterals then
                begin
                    Result := False;
                    NrOfMatches := 1;
                    MaskInput.MatchedLiterals := MaskInput.Literals;
                end
                else
                begin
                    MatchLen := GetMatchedLen(MaskInput.MinMatchedLiterals, MaskInput.Literals);
                    if MatchLen <> 0 then
                    begin
                        Result := False;
                        if MaskInput.MatchedLiterals <> MaskInput.MinMatchedLiterals then
                            Inc(NrOfMatches);

                        if MatchLen < Length(MaskInput.MinMatchedLiterals) then
                        begin
                            MaskInput.MinMatchedLiterals := Copy(MaskInput.MinMatchedLiterals, 1, MatchLen);
                        end;

                        if MaskInput.Literals = MaskInput.MinMatchedLiterals then
                        begin
                            NrOfMatches := 1;
                            MaskInput.MatchedLiterals := MaskInput.Literals;
                        end;
                    end
                    else
                    begin
                        Inc(NrOfMatches);
                        MaskInput.MinMatchedLiterals := '';
                    end;
                end;
            end;
        end;
    end;

    if (not Result) then
    begin
        Stack.Pop;
        CopyMaskInput(OldInput, MaskInput);

        if Assigned(Node.NextAlternative) then
        begin
            Result := CheckSubItems(Stack, Parent, Node.NextAlternative, 0,
                                    Options, MaskInput, NrOfMatches);
        end;
    end;
end;

function TtsTextMask.ValidText(const Text: string; FullCompare: Boolean): Boolean;
var
    Stack: TtsParseStack;
    Options: TtsMaskOptions;
    MaskInput: TtsMaskInput;
    NrOfMatches: Integer;
begin
    Result := True;
    if Picture = '' then Picture := tsPicAllChars;
    if not Assigned(PictureList) then Exit;
    if not Assigned(PictureList.StartNode) then Exit;

    Stack := TtsParseStack.Create;
    try
        Options := [];
        if FullCompare then Include(Options, moFullCompare);

        NrOfMatches := 0;
        MaskInput := SetMaskInput(Text, 1, 0, 0);
        Result := CheckSubItems(Stack, 0, PictureList.StartNode, 0, Options,
                                MaskInput, NrOfMatches);
    finally
        Stack.Free;
    end;
end;

function TtsTextMask.CheckInput(Stack: TtsParseStack; MaskInput: TtsMaskInput;
                                Options: TtsMaskOptions; var InsertChars: string): Boolean;
var
    NrOfMatches: Integer;
begin
    Stack.Reset;
    NrOfMatches := 0;
    CheckSubItems(Stack, 0, PictureList.StartNode, 0, Options, MaskInput, NrOfMatches);

    Result := (NrOfMatches = 1);
    if Result then
    begin
        InsertChars := MaskInput.InsertChars;
        if (MaskInput.MatchedLiterals <> '') then
            InsertChars := MaskInput.MatchedLiterals + InsertChars;
    end;
end;

function TtsTextMask.ValidInput(const Text: string; var InsertChars: string; InsertPos: Integer;
                                FullCompare, AutoFill: Boolean): Boolean;
var
    Stack: TtsParseStack;
    CheckText: string;
    MaskInput: TtsMaskInput;
    CmpOptions, Options: TtsMaskOptions;
begin
    Result := True;
    if Picture = '' then Picture := tsPicAllChars;
    if not Assigned(PictureList) then Exit;
    if not Assigned(PictureList.StartNode) then Exit;

    if InsertPos <= 0 then InsertPos := 1;
    if InsertPos > Length(Text) then InsertPos := Length(Text) + 1;

    CmpOptions := [];
    if FullCompare then Include(CmpOptions, moFullCompare);
    CheckText := Copy(Text, 1, InsertPos - 1) + InsertChars;
    MaskInput := SetMaskInput(CheckText, 1, InsertPos, Length(InsertChars));

    Stack := TtsParseStack.Create;
    try
        Options := CmpOptions;
        Result := CheckInput(Stack, MaskInput, Options, InsertChars);

        if not Result then
        begin
            Options := CmpOptions + [moConvertInput];
            Result := CheckInput(Stack, MaskInput, Options, InsertChars);
        end;

        if (not Result) and AutoFill then
        begin
            Options := CmpOptions + [moInsertLiteral, moCheckUnique];
            Result := CheckInput(Stack, MaskInput, Options, InsertChars);
        end;

        if (not Result) and (AutoFill) then
        begin
            Options := CmpOptions + [moInsertLiteral, moConvertInput, moCheckUnique];
            Result := CheckInput(Stack, MaskInput, Options, InsertChars);
        end;
    finally
        Stack.Free;
    end;
end;

{TtsMask}

constructor TtsMask.Create(Collection: TCollection);
var
    Parent: TComponent;
begin
    inherited;
    FTextMask := TtsTextMask.Create(Self);
    FAutoFill := [Low(TtsMaskCheck)..High(TtsMaskCheck)];
    FEvaluate := [Low(TtsMaskCheck)..High(TtsMaskCheck)];

    FUpdateCount := 0;
    FPicture := '';
    FTextCase := TtsTextCase.Create(Self);

    Parent := ParentComponent;
    if Assigned(Parent) then
    begin
        if Parent is TtsMaskDefs then
            OnParseError := TtsMaskDefs(Parent).DoParseError;
    end;
end;

destructor TtsMask.Destroy;
begin
    FTextMask.Free;
    FTextCase.Free;
    inherited;
end;

procedure TtsMask.InvalidOp(Msg: string);
var
    Parent: TComponent;
begin
    Parent := ParentComponent;
    if Parent <> nil then Msg := Parent.Name + ': ' + Msg;
    raise EtsMaskError.Create(Msg)
end;

function TtsMask.ParentComponent: TComponent;
begin
    Result := nil;
    if Collection is TtsMaskCollection then
        Result := TtsMaskCollection(Collection).FMaskDefs;
end;

procedure TtsMask.BeginUpdate;
begin
    Inc(FUpdateCount);
end;

procedure TtsMask.EndUpdate;
begin
    Dec(FUpdateCount);
    Changed;
end;

procedure TtsMask.Assign(Source: TPersistent);
begin
    if Source is TtsMask then
    begin
        BeginUpdate;
        try
            AutoFill := TtsMask(Source).AutoFill;
            Evaluate := TtsMask(Source).Evaluate;
            Name := TtsMask(Source).Name;
            TextCase := TtsMask(Source).TextCase;
            Picture := TtsMask(Source).Picture;
        finally
            EndUpdate;
        end;
    end;
end;

function TtsMask.ValidText(const Text: string; FullCompare: Boolean): Boolean;
begin
    Result := True;
    if (Picture = '') and ((TextCase.CaseType = cstNone) or TextCase.Optional) then Exit;
    Result := TextMask.ValidText(Text, FullCompare);
end;

function TtsMask.ValidInput(const Text: string; var InsertChars: string; InsertPos: Integer;
                            FullCompare, AutoFill: Boolean): Boolean;
begin
    Result := True;
    if (Picture = '') and (TextCase.CaseType = cstNone) then Exit;
    Result := TextMask.ValidInput(Text, InsertChars, InsertPos, FullCompare, AutoFill);
end;

procedure TtsMask.SetAutoFill(Value: TtsMaskChecks);
begin
    if FAutoFill <> Value then
    begin
        FAutoFill := Value;
        Changed;
    end;
end;

procedure TtsMask.SetEvaluate(Value: TtsMaskChecks);
begin
    if FEvaluate <> Value then
    begin
        FEvaluate := Value;
        Changed;
    end;
end;

procedure TtsMask.CheckName(Value: string);
var
    Mask: TtsMask;
begin
    if Assigned(Collection) then
    begin
        if Collection is TtsMaskCollection then
        begin
            Mask := TtsMaskCollection(Collection).Items[Value];
            if Assigned(Mask) and (Mask <> Self) then
                InvalidOp(Format(StsMaskNotUnique, [Value]));
        end;
    end;
end;

procedure TtsMask.SetName(Value: string);
begin
    if FName <> Value then
    begin
        CheckName(Value);
        FName := Value;
        Changed;
    end;
end;

function TtsMask.CheckRaise: Boolean;
var
    State: TComponentState;
begin
    Result := True;
    if Collection is TtsMaskCollection then
    begin
        State := TtsMaskCollection(Collection).FMaskDefs.ComponentState;
        Result := not ((csReading in State) and (csDesigning in State));
    end;
end;

procedure TtsMask.SetPicture(Value: string);
begin
    try
        try
            TextMask.Picture := Value;
        finally
            FPicture := TextMask.Picture;
            Changed;
        end;
    except
        if CheckRaise then raise;
    end;
end;

procedure TtsMask.SetTextCase(Value: TtsTextCase);
begin
    if FTextCase <> Value then
    begin
        BeginUpdate;
        try
            TextCase.Assign(Value);
        finally
            EndUpdate;
        end;
    end;
end;

function TtsMask.GetAutoFill: TtsMaskChecks;
begin
    Result := FAutoFill;
end;

function TtsMask.GetEvaluate: TtsMaskChecks;
begin
    Result := FEvaluate;
end;

function TtsMask.GetName: string;
begin
    Result := FName;
end;

function TtsMask.GetPicture: string;
begin
    Result := FPicture;
end;

function TtsMask.GetTextCase: TtsTextCase;
begin
    Result := FTextCase;
end;

function TtsMask.GetOnChange: TNotifyEvent;
begin
    Result := FOnChange;
end;

procedure TtsMask.SetOnChange(Value: TNotifyEvent);
begin
    FOnChange := Value;
end;

function TtsMask.GetOnParseError: TtsMaskErrorEvent;
begin
    Result := FOnParseError;
end;

procedure TtsMask.SetOnParseError