qrexpr.pas

delphi7报表打印控件源码 可以设计报表

{ TQREvElement }

constructor TQREvElement.Create;
begin
  inherited Create;
  FIsAggreg := false;
end;

function TQREvElement.Value(FiFo : TQRFiFo) : TQREvResult;
begin
end;

procedure TQREvElement.Reset;
begin
end;

{ TQREvElementOperator }

type
  TQREvElementOperator = class(TQREvElement)
  private
    FOpCode :  TQREvOperator;
    procedure ConverTQREvResults(var Res1 : TQREvResult; var Res2 : TQREvResult);
  public
    constructor CreateOperator(OpCode : TQREvOperator);
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
  end;

function ErrorCreate(Value : string) : TQREvResult;
begin
  Result.Kind := resError;
  Result.strResult := Value;
end;

constructor TQREvElementOperator.CreateOperator(OpCode : TQREvOperator);
begin
  inherited Create;
  FOpCode := OpCode;
end;

procedure TQREvElementOperator.ConverTQREvResults(var Res1 : TQREvResult; var Res2 : TQREvResult);
begin
  if (Res1.Kind <> resError) and (Res2.Kind <> resError) then
    if Res1.Kind <> Res2.Kind then
    begin
      if ((Res1.Kind = resInt) and (Res2.Kind = resDouble)) then
      begin
        Res1.Kind := resDouble;
        Res1.dblResult := Res1.intResult;
      end else
        if ((Res1.Kind = resDouble) and (Res2.Kind = resInt)) then
        begin
          Res2.Kind := resDouble;
          Res2.dblResult := Res2.intResult;
        end else
        begin
          Res1.StrResult := QREvResultToString(Res1);
          Res1.Kind := resString;
          Res2.StrResult := QREvResultToString(Res2);
          Res2.Kind := resString;
        end;
    end
end;

function TQREvElementOperator.Value(FiFo : TQRFiFo) : TQREvResult;
var
  Res1,
  Res2 : TQREvResult;
begin
  Res1 := TQREvElement(FiFo.Get).Value(FiFo);
  Res2 := TQREvElement(FiFo.Get).Value(FiFo);
  ConverTQREvResults(Res1, Res2);
  Result.Kind := Res1.Kind;
  if Res2.Kind = resError then
    Result.Kind := res2.Kind;
  if result.Kind <> resError then
    case FOpCode of
      opPlus: case result.Kind of
                resInt:    result.intResult := Res1.intResult + Res2.intResult;
                resDouble: result.dblResult := Res1.dblResult + Res2.dblResult;
                resString: result.strResult := Res1.strResult + Res2.strResult;
                resBool:   result := ErrorCreate(Format(SqrExpCannotOperator, [SqrExpAdd, SqrExpBoolean]));
              end;
      opMinus:  case result.Kind of
                  resInt:    result.intResult := Res1.intResult - Res2.intResult;
                  resDouble: result.dblResult := Res1.dblResult - Res2.dblResult;
                  resString: result := ErrorCreate(Format(SqrExpCannotOperator, [SqrExpSubtract, SqrExpString]));
                  resBool:   result := ErrorCreate(Format(SqrExpCannotOperator, [SqrExpSubtract, SqrExpBoolean]));
                end;
      opMul: case result.Kind of
               resInt:    result.intResult := Res1.intResult * Res2.intResult;
               resDouble: result.dblResult := Res1.dblResult * Res2.dblResult;
               resString: result := ErrorCreate(Format(SqrExpCannotOperator, [SqrExpMultiply, SqrExpString]));
               resBool:   result := ErrorCreate(Format(SqrExpCannotOperator, [SqrExpMultiply, SqrExpBoolean]));
             end;
      opDiv: case result.Kind of
               resInt:    if Res2.intResult <> 0 then
                          begin
                            result.dblResult := Res1.intResult / Res2.intResult;
                            result.Kind := resDouble;
                          end else
                            result := ErrorCreate(SqrExpDivideByZero);
               resDouble: if Res2.dblResult <> 0 then
                            result.dblResult := Res1.dblResult / Res2.dblResult
                          else
                            result := ErrorCreate(SqrExpDivideByZero);
               resString: result := ErrorCreate(Format(SqrExpCannotOperator, [SqrExpDivide, SqrExpString]));
               resBool:   result := ErrorCreate(Format(SqrExpCannotOperator, [SqrExpDivide, SqrExpBoolean]));
             end;
      opGreater: begin
                   result.Kind := resBool;
                   case Res1.Kind of
                     resInt:    result.booResult := Res1.intResult > Res2.intResult;
                     resDouble: result.booResult := Res1.dblResult > Res2.dblResult;
                     resString: result.booResult := Res1.strResult > Res2.strResult;
                     resBool:   result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['>', SqrExpBoolean]));
                   end;
                 end;
      opGreaterOrEqual: begin
                result.Kind := resBool;
                case Res1.Kind of
                  resInt:    result.booResult := Res1.intResult >= Res2.intResult;
                  resDouble: result.booResult := Res1.dblResult >= Res2.dblResult;
                  resString: result.booResult := Res1.strResult >= Res2.strResult;
                  resBool:   result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['>=', SqrExpBoolean]));
                end;
             end;
      opLess: begin
                result.Kind := resBool;
                case Res1.Kind of
                  resInt:    result.booResult := Res1.intResult < Res2.intResult;
                  resDouble: result.booResult := Res1.dblResult < Res2.dblResult;
                  resString: result.booResult := Res1.strResult < Res2.strResult;
                  resBool:   result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['<', SqrExpBoolean]));
                end;
              end;
      opLessOrEqual: begin
                 result.Kind := resBool;
                 case Res1.Kind of
                   resInt:    result.booResult := Res1.intResult <= Res2.intResult;
                   resDouble: result.booResult := Res1.dblResult <= Res2.dblResult;
                   resString: result.booResult := Res1.strResult <= Res2.strResult;
                   resBool:   result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['<=', SqrExpBoolean]));
                 end;
               end;
      opEqual: begin
                 result.Kind := resBool;
                 case Res1.Kind of
                   resInt:    result.booResult := Res1.intResult = Res2.intResult;
                   resDouble: result.booResult := Res1.dblResult = Res2.dblResult;
                   resString: result.booResult := Res1.strResult = Res2.strResult;
                   resBool:   result.booResult := Res1.booResult = Res2.booResult;
                 end;
               end;
      opUnequal: begin
                   result.Kind := resBool;
                   case Res1.Kind of
                     resInt:    result.booResult := Res1.intResult <> Res2.intResult;
                     resDouble: result.booResult := Res1.dblResult <> Res2.dblResult;
                     resString: result.booResult := Res1.strResult <> Res2.strResult;
                     resBool:   result.booResult := Res1.booResult <> Res2.booResult;
                   end;
                 end;
      opOr: begin
              result.Kind := Res1.Kind;
              case Res1.Kind of
                resInt:    result.intResult := Res1.intResult or Res2.intResult;
                resDouble: result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['OR', SqrExpNumeric]));
                resString: Result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['OR', SqrExpString]));
                resBool:   result.booResult := Res1.booResult or Res2.booResult;
              end;
            end;
      opAnd: begin
               result.Kind := Res1.Kind;
               case Res1.Kind of
                 resInt:    result.intResult := Res1.intResult and Res2.intResult;
                 resDouble: result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['AND', SqrExpNumeric]));
                 resString: Result := ErrorCreate(Format(SqrExpOperatorNotCompatible, ['AND', SqrExpString]));
                 resBool:   result.booResult := Res1.booResult and Res2.booResult;
               end;
             end;
    end else
      if Res1.Kind = resError then
        Result := Res1
      else
        Result := Res2;
end;

{ TQREvElementConstant }

type
  TQREvElementConstant = class(TQREvElement)
  private
    FValue : TQREvResult;
  public
    constructor CreateConstant(Value : TQREvResult);
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
  end;

constructor TQREvElementConstant.CreateConstant(Value : TQREvresult);
begin
  inherited Create;
  FValue := Value;
end;

function TQREvElementConstant.Value(FiFo : TQRFiFo): TQREvResult;
begin
  Result := FValue;
end;

{ TQREvElementString }

type
  TQREvElementString = class(TQREvElement)
  private
    FValue : string;
  public
    constructor CreateString(Value : string);
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
  end;

constructor TQREvElementString.CreateString(Value : string);
begin
  inherited Create;
  FValue := Value;
end;

function TQREvElementString.Value(FiFo : TQRFiFo) : TQREvResult;
begin
  result.Kind := resString;
  result.StrResult := FValue;
end;

{ TQREvElementFunction }

constructor TQREvElementFunction.Create;
begin
  inherited Create;
  ArgList := TList.Create;
end;

destructor TQREvElementFunction.Destroy;
begin
  ArgList.Free;
  inherited Destroy;
end;

procedure TQREvElementFunction.GetArguments(FiFo : TQRFiFo);
var
  aArgument : TQREvElement;
  AResult : TQREvResultClass;
begin
  repeat
    aArgument := TQREvElement(FiFo.Get);
    if not (aArgument is TQREvElementArgumentEnd) then
    begin
      aResult := TQREvResultClass.Create;
      aResult.EvResult := aArgument.Value(FiFo);
      ArgList.Add(aResult);
    end;
  until aArgument is TQREvElementArgumentEnd;
end;

procedure TQREvElementFunction.FreeArguments;
var
  I : integer;
begin
  for I := 0 to ArgList.Count - 1 do
    TQREvElement(ArgList.Items[I]).Free;
  ArgList.Clear;
end;

function TQREvElementFunction.Argument(Index : integer): TQREvResult;
begin
  if Index <= ArgList.Count then
    Result := TQREvResultClass(ArgList[Index]).EvResult;
end;

function TQREvElementFunction.Value(FiFo : TQRFiFo) : TQREvResult;
begin
  GetArguments(FiFo);
  if FiFo.Aggreg then
    Aggregate;
  Result := Calculate;
  FreeArguments;
end;

function TQREvElementFunction.ArgumentOK(Value : TQREvElement) : boolean;
begin
  Result := not (Value is TQREvElementArgumentEnd) and not (Value is TQREvElementError);
end;

procedure TQREvElementFunction.Aggregate;
begin
end;

function TQREvElementFunction.Calculate : TQREvResult;
begin
  Result.Kind := resError;
end;

function TQREvElementFunction.FunctionName : string;
begin
  Result := '';
end;

function TQREvElementFunction.FunctionDescription : string;
begin
  Result := FunctionName;
end;

function TQREvElementFunction.FunctionVendor : string;
begin
  Result := SqrQusoft;
end;

function TQREvElementFunction.FunctionArguments : string;
begin
  Result := '';
end;

{ TQREvElementDataField }

constructor TQREvElementDataField.CreateField(aField : TField);
begin
  inherited Create;
  FDataSet := aField.DataSet;
  FFieldNo := aField.Index;
  FField := aField;
end;

function TQREvElementDataField.Value(FiFo : TQRFiFo) : TQREvResult;
begin
  if FDataSet.DefaultFields then
    FField := FDataSet.Fields[FFieldNo];
  if FField is TStringField then
  begin
    result.Kind := resString;
    result.strResult := TStringField(FField).Value;
  end else
    if (FField is TIntegerField) or
       (FField is TSmallIntField) or
       (FField is TWordField) then
    begin
      result.Kind := resInt;
      result.intResult := FField.AsInteger;
    end else
      if (FField is TFloatField)  or
         (FField is TCurrencyField) or
         (FField is TBCDField) then
      begin
        result.Kind := resDouble;
        result.dblResult := TFloatField(FField).AsFloat;
      end else
        if FField is TBooleanField then
        begin
          result.Kind := resBool;
          result.BooResult := TBooleanField(FField).Value;
        end else
          if FField is TDateField then
          begin
            result.Kind := resString;
            result.strResult := TDateField(FField).AsString;
          end else
            if FField is TDateTimeField then
            begin
              result.Kind := resString;
              result.strResult := TDateField(FField).AsString;
            end else
              result := ErrorCreate(Format(SqrExpUnknownFieldType, [FField.FieldName]));
end;

constructor TQREvElementError.Create(ErrorMessage : string);
begin
  FErrorMessage := ErrorMessage;
end;

function TQREvElementError.Value(FiFo : TQRFiFo) : TQREvResult;
begin
  Result.Kind := resError;
  Result.strResult := FErrorMessage;
end;

function Flip(aString : string; a, b : char) : string;
var
  ParLevel : integer;
  isString : boolean;
  I : integer;
  aChar : string;
begin
  ParLevel := 0;
  IsString := false;
  I := 1;
  while I <= Length(aString) do
  begin
    aChar := aString[I];
    if aChar = '''' then
      IsString := not IsString
    else
      if not isString then
      begin
        if aChar = '(' then
          inc(ParLevel)
        else
          if aChar = ')' then
            dec(ParLevel)
          else
            if ParLevel = 0 then
              if aChar = a then
                aString[I] := b
              else
                if aChar = b then
                  aString[I] := a;
     end;
     inc(I);
   end;
   result := aString;
end;

{ TQREvaluator }

constructor TQREvaluator.Create;
begin
  Prepared := false;
  Environment := nil;
  FDatasets := nil;
  OwnDatasets := nil;
end;

destructor TQREvaluator.Destroy;
begin
  if Prepared then Unprepare;
  if (FDatasets <> nil) and (FDataSets = OwnDatasets) then
    FDatasets.Free;
  inherited Destroy;
end;

procedure TQREvaluator.SetDatasets(Value : TList);
begin
  if (FDatasets <> nil) and (FDatasets <> Value) and (FDatasets = OwnDatasets) then
    FDatasets.Free;
  FDatasets := Value;
end;

function TQREvaluator.GetDatasets : TList;
begin
  if FDatasets = nil then
  begin
    FDatasets := TList.Create;
    OwnDatasets := FDatasets;
  end;
  Result := FDatasets;
end;

procedure TQREvaluator.TrimString(var strString : string);
var
  intStart,
  intEnd : integer;
begin
  intStart := 1;