crgrid.pas

医院信息管理系统 后台采用ORACLE

  i: integer;
  St: string;
begin
  Result := 0;
  if Str = '' then
    Exit;
  Result := 1;
  i := Pos(Delim, Str);
  St := Str;
  while i > 0 do begin
    Inc(Result);
    St[i] := #255;
    i := Pos(Delim, St);
  end;
end;

function GetCaptionLevel(const Str: string; Level: integer; Delim: char): string;
var
  i,j: integer;
  St: string;
begin
  j := 0;
  Result := '';
  if Str = '' then
    Exit;
  i := Pos(Delim, Str);
  St := Str;
  while (Level > 0) and (I > 0) do begin
    Dec(Level);
    St[i] := #255;
    if Level <= -2 then begin
      Result := Copy(St, j + 1, i - 1);
      exit;
    end;
    j := i;
    i := Pos(Delim, St);
  end;
  if Level <= 0 then begin
    if i = 0 then
      i := Length(St) + j
    else
      Dec(i);
    Result := Copy(Str, j + 1, i - j);
    exit;
  end;
end;

{ TCRColumn }

function TCRColumn.GetSortOrder: TSortOrder;
var
  SortColInfo: PSortColInfo;
  NumSort: integer;
begin
  if not CanBeSorted then begin
    Result := soNone;
    exit;
  end;
  SortColInfo := TCRDBGrid(Grid).FindSortColInfo(Index, NumSort);

  if SortColInfo <> nil then
    if SortColInfo.Desc then
      Result := soDesc
    else
      Result := soAsc
  else
    Result := soNone;
end;

procedure TCRColumn.SetSortOrder(Value: TSortOrder);
var
  SortColInfo: PSortColInfo;
  NumSort: integer;
begin
  if not CanBeSorted then
    Exit;

  SortColInfo := TCRDBGrid(Grid).FindSortColInfo(Index, NumSort);
  if SortColInfo <> nil then begin
    case Value of
      soNone: begin
        if NumSort > 0 then
          Dec(NumSort);
        Dispose(TCRDBGrid(Grid).FSortInfo[NumSort]);
        TCRDBGrid(Grid).FSortInfo.Delete(NumSort)
      end;
      soAsc:
        SortColInfo.Desc := False;
      soDesc:
        SortColInfo.Desc := True;
    end;
    TCRDBGrid(Grid).Reorder;
  end
  else
    if Value <> soNone then begin
      New(SortColInfo);
      SortColInfo.Index := Index;
      SortColInfo.Desc := Value = soDesc;
      TCRDBGrid(Grid).FSortInfo.Add(SortColInfo);
      TCRDBGrid(Grid).Reorder;
    end;
end;

function TCRColumn.GetSortSequence: integer;
begin
  TCRDBGrid(Grid).FindSortColInfo(Index, Result);
end;

procedure TCRColumn.SetFilterExpression(const Value: string);
begin
    FFilterExpression := Value;
end;

procedure TCRColumn.SetSortSequence(Value: integer);
begin
end;

function TCRColumn.GetTotalString: string;
begin
  if Assigned(Field) and (Field.DataSet.Active) then
    if (FSummaryMode = smNone) then
      Result := ''
    else
      if FTotalLoaded then
          Result := FTotalString
      else
          LoadTotal
  else
    Result := '';
end;

procedure TCRColumn.ResetTotal;
begin
    FTotalLoaded := False;
end;

procedure TCRColumn.LoadTotal;
begin
  if Assigned (Field) then begin
    TCRDBGrid(Grid).LoadTotals;
    if Assigned (Field) then
    case Field.DataType of
      ftSmallint, ftInteger, ftWord, ftLargeint:
        if SummaryMode = smAvr then
          FTotalString := FloatToStrF(FTotalFloat, FFloatFormat, FFloatPrecision, FFloatDigits)
        else
          FTotalString := IntToStr(FTotalInt);
      ftFloat, ftCurrency:
        FTotalString := FloatToStrF(FTotalFloat, FFloatFormat, FFloatPrecision, FFloatDigits);
    else
      FTotalString := ''
    end
  end;
end;

procedure TCRColumn.SetSummaryMode(Value: TSummaryMode);
begin
  if Value <> smNone then
    if Assigned(Field) then
      if not (Field.DataType in [ftSmallint, ftInteger, ftWord, ftLargeint, ftFloat, ftCurrency]) then
        Value := smNone;
  if FSummaryMode <> Value then begin
    FSummaryMode := Value;
    ResetTotal;
    if Assigned(Grid) then
      Grid.Invalidate;
  end;
end;

procedure TCRColumn.SetTotal;
begin
  FTotalLoaded := True;
  if Assigned (Field) then
    case Field.DataType of
      ftSmallint, ftInteger, ftWord, ftLargeint:
        if SummaryMode = smAvr then
          FTotalString := FloatToStrF(FTotalFloat,FFloatFormat,FFloatPrecision,FFloatDigits)
        else
          FTotalString := IntToStr(FTotalInt);
      ftFloat, ftCurrency:
        FTotalString := FloatToStrF(FTotalFloat,FFloatFormat,FFloatPrecision,FFloatDigits);
    else
      FTotalString := '';
    end
end;

procedure TCRColumn.SetFloatDigits(const Value: integer);
begin
  FFloatDigits := Value;
  if Assigned (Field) then begin
    case Field.DataType of
      ftSmallint, ftInteger, ftWord, ftLargeint:
        if SummaryMode = smAvr then
          FTotalString := FloatToStrF(FTotalFloat,FFloatFormat,FFloatPrecision,FFloatDigits);
      ftFloat, ftCurrency:
        FTotalString := FloatToStrF(FTotalFloat,FFloatFormat,FFloatPrecision,FFloatDigits);
    end;
    if Assigned(Grid)then
      Grid.Invalidate;
  end;
end;

procedure TCRColumn.SetFloatFormat(const Value: TFloatFormat);
begin
  FFloatFormat := Value;
  if Assigned(Field) then begin
    case Field.DataType of
      ftSmallint, ftInteger, ftWord, ftLargeint:
        if SummaryMode = smAvr then
          FTotalString := FloatToStrF(FTotalFloat, FFloatFormat, FFloatPrecision, FFloatDigits);
      ftFloat, ftCurrency:
        FTotalString := FloatToStrF(FTotalFloat, FFloatFormat, FFloatPrecision, FFloatDigits);
    end;
    if Assigned(Grid) then
      Grid.Invalidate;
  end;
end;

procedure TCRColumn.SetFloatPrecision(const Value: integer);
begin
  FFloatPrecision := Value;
  if Assigned(Field) then begin
    case Field.DataType of
      ftSmallint, ftInteger, ftWord, ftLargeint:
        if SummaryMode = smAvr then
          FTotalString := FloatToStrF(FTotalFloat, FFloatFormat, FFloatPrecision, FFloatDigits);
      ftFloat, ftCurrency:
        FTotalString := FloatToStrF(FTotalFloat, FFloatFormat, FFloatPrecision, FFloatDigits);
    end;
    if Assigned(Grid) then
      Grid.Invalidate;
  end;
end;

procedure TCRColumn.Assign(Source: TPersistent);
begin
  if Source is TCRColumn then begin
    if Assigned(Collection) then
      Collection.BeginUpdate;
    inherited Assign(Source);
    try
      FSummaryMode := TCRColumn(Source).FSummaryMode;
      FMinWidth := TCRColumn(Source).FMinWidth;
      FTotalString := TCRColumn(Source).FTotalString;
      FTotalLoaded := TCRColumn(Source).FTotalLoaded;
      FSummaryMode := TCRColumn(Source).FSummaryMode;
      FTotalFloat := TCRColumn(Source).FTotalFloat;
      FTotalInt := TCRColumn(Source).FTotalInt;
      FFloatDigits := TCRColumn(Source).FFloatDigits;
      FFloatPrecision := TCRColumn(Source).FFloatPrecision;
      FFloatFormat := TCRColumn(Source).FFloatFormat;
    finally
      if Assigned(Collection) then
        Collection.EndUpdate;
    end;
  end
  else
    inherited Assign(Source);
end;

function TCRColumn.CanBeSorted: boolean;
begin
  if Assigned(Field) then
    Result := (Field.FieldKind = fkData) and not (Field.DataType in [ftFmtMemo,
      ftMemo{$IFNDEF VER4}, ftOraClob {$ENDIF}])
  else
    Result := False;
end;

function TCRColumn.GetFilterExpression(const RawFilter: string): string;

  function GetSignString(var ConstStr: string): string;
  var
    Buf: string;
  begin
    Result := '';
    ConstStr := '';
    Buf := Trim(RawFilter);
    if Buf = '' then
      Exit;

    case Buf[1] of
      '=': begin
        Result := '=';
        ConstStr := Copy(Buf, 2, Length(Buf) - 1);
      end;
      '<', '>': begin
        if (Length(Buf) >= 2) and ((Buf[2] = '=') or (Buf[2] = '>')) then begin
          Result := Copy(Buf, 1, 2);
          ConstStr := Copy(Buf, 3, Length(Buf) - 2);
        end
        else begin
          Result := Buf[1];
          ConstStr := Copy(Buf, 2, Length(Buf) - 1);
        end;
      end;
      else
      begin
        Result := '=';
        ConstStr := Copy(Buf, 1, Length(Buf));
      end;
    end;
    ConstStr := TrimLeft(ConstStr);
  end;

var
  Sign, ConstStr: string;
  i: integer;
begin
  Result := '';
  if RawFilter = '' then
    Exit;
  if Assigned (Field) then begin
    Sign := GetSignString(ConstStr);
    if (Sign = '') or (ConstStr = '') then
      Exit;
    case Field.DataType of
      ftSmallint, ftInteger, ftWord, ftLargeint:
        StrToInt(ConstStr); // test for exception
      ftFloat, ftCurrency:
        StrToFloat(ConstStr); // test for exception
      ftDate: begin
        StrToDate(ConstStr); // test for exception
        ConstStr := '''' + ConstStr + '''';
      end;
      ftDateTime: begin
        StrToDateTime(ConstStr); // test for exception
        ConstStr := '''' + ConstStr + '''';
      end;
      ftTime: begin
        StrToTime(ConstStr); // test for exception
        ConstStr := '''' + ConstStr + '''';
      end;
      ftString,ftWideString: begin
        if not (dgeLocalFilter in TCRDBGrid(Grid).OptionsEx)
        and ((Sign = '=') or (Sign = '<>')) then begin
          for i := 1 to Length(ConstStr) do
            if ConstStr[i] = '*' then
              ConstStr[i] := '%';
          if Sign = '=' then
            Sign := ' LIKE '
          else
            Sign := ' NOT LIKE ';
        end;
        Result := Field.FieldName + Sign + AnsiQuotedStr(ConstStr,'''');
        Exit;
      end;
    end;
  end;
  Result := Field.FieldName + Sign + ConstStr;
end;

procedure TCRColumn.ChangedTitle(Rebild: boolean);
begin
  if Rebild then
    if Assigned(Grid) then
      TCRDBGrid(Grid).LayoutChanged;
end;

function TCRColumn.CreateTitle: TColumnTitle;
begin
  Result := TCRColumnTitle.Create(Self);
end;

constructor TCRColumn.Create(Collection: TCollection);
begin
  inherited;
  FMinWidth := 30;
end;

procedure TCRColumn.SetTableSpacePercent(const Value: double);
begin
  if FTableSpacePercent <> Value then begin
    FTableSpacePercent := Value;
    if Assigned(grid) then
      TCRDBGrid(grid).ResizeColumns(Index);
  end;
end;

procedure TCRColumn.SetWidth(const Value: integer);
begin
  if Value > FMinWidth then
    inherited Width := Value
  else
    inherited Width := FMinWidth
  //if assigned(grid) then
  //  FTableSpaceProcent := Width / TCRDBGrid(grid).GetGridSize;
end;

function TCRColumn.GetWidth: integer;
begin
  result := inherited Width;
end;

{$IFDEF VER5P}
type
  _TReader = class(TReader)
  end;

// for compatible with old resource
procedure TCRColumn.DefineProperties(Filer: TFiler);
begin
  inherited;
  if Filer is TReader then
    Filer.DefineProperty(_TReader(Filer).PropName, ReadData, nil, false);
end;

// for compatible with old resource
procedure TCRColumn.ReadData(Reader: TReader);
var
  SavePosition: integer;
begin
  Reader.SkipValue;
  SavePosition := Reader.Position;
  if CompareText(Reader.ReadStr, 'SortOrder') = 0 then begin
    Reader.SkipValue;
  end else
  begin
    Reader.Position := SavePosition;
  end;
end;
{$ENDIF}