dbgridehimpexp.pas

自己做的用delphi开发的学生成绩管理系统。

      for k := ListOfHeadTreeNodeList.Count - 1 downto 1 do
      begin
        Put('\trowd');
        PutL('\trgaph40');

        w := 0;
        for i := 0 to ColumnsList.Count - 1 do
        begin
          CalcSpan(ColumnsList, ListOfHeadTreeNodeList, k, i, ColSpan, RowSpan);
          AddExclBorders(i, k, ColSpan, RowSpan);
          CalcBorders(i, k);

          WriteCellBorder(LeftBorder, TopBorder, BottomBorder, RightBorder);
          Inc(w, Trunc(ColumnsList[i].Width / fLogPelsX * 1440)); // in twips
          Put('\clshdng10000\clcfpat' + IntToStr(GetColorIndex((DBGridEh.FixedColor))));
          PutL('\cellx' + IntToStr(w));
        end;

        PutL('{\trrh0');

        for i := 0 to ColumnsList.Count - 1 do
        begin
          if THeadTreeNode(TList(ListOfHeadTreeNodeList.Items[k]).Items[i]) <> nil then
          begin
            Text := THeadTreeNode(TList(ListOfHeadTreeNodeList.Items[k]).Items[i]).Text;
            Put('\pard\intbl{' + GetAlignment(taCenter) + '\sb' + Space + '\sa' + Space);
          end else
          begin
            Text := '';
            Put('\pard\intbl{' + GetAlignment(taCenter));
          end;

          PutText(DBGridEh.TitleFont, Text, DBGridEh.FixedColor);
          PutL('\cell}');
        end;
        PutL('\pard\intbl\row}');
      end;

      //Bottomest titles
      Put('\trowd');
      PutL('\trgaph40');

      w := 0;
      for i := 0 to ColumnsList.Count - 1 do
      begin
        CalcSpan(ColumnsList, ListOfHeadTreeNodeList, 0, i, ColSpan, RowSpan);
        AddExclBorders(i, 0, ColSpan, RowSpan);
        CalcBorders(i, 0);

        WriteCellBorder(LeftBorder, TopBorder, BottomBorder, RightBorder);

        Inc(w, Trunc(ColumnsList[i].Width / fLogPelsX * 1440)); // in twips
        Put('\clshdng10000\clcfpat' + IntToStr(GetColorIndex((ColumnsList[i].Title.Color))));
        PutL('\cellx' + IntToStr(w));
      end;

      PutL('{\trrh0');

      for i := 0 to ColumnsList.Count - 1 do
      begin
        if THeadTreeNode(TList(ListOfHeadTreeNodeList.Items[0]).Items[i]) <> nil then
        begin
          Text := THeadTreeNode(TList(ListOfHeadTreeNodeList.Items[0]).Items[i]).Text;
          Put('\pard\intbl{' + GetAlignment(taCenter) + '\sb' + Space + '\sa' + Space);
        end else
        begin
          Text := '';
          Put('\pard\intbl{' + GetAlignment(taCenter));
        end;
        CalcSpan(ColumnsList, ListOfHeadTreeNodeList, 0, i, ColSpan, RowSpan);

        PutText(ColumnsList[i].Title.Font, Text, ColumnsList[i].Title.Color);
        PutL('\cell}');

      end;
      PutL('\pard\intbl\row}');

    finally
      for i := 0 to ListOfHeadTreeNodeList.Count - 1 do
        TList(ListOfHeadTreeNodeList.Items[i]).Free;
      ListOfHeadTreeNodeList.Free;
      FreeMem(FPTitleExpArr);

      ExclLeftBorders.Free;
      ExclTopBorders.Free;
      ExclBottomBorders.Free;
      ExclRightBorders.Free;
    end;
  end else
  begin
    Put('\trowd');
    PutL('\trgaph40');

    w := 0;
    for i := 0 to ColumnsList.Count - 1 do
    begin
      WriteCellBorder(True, True, True, True);
      Inc(w, Trunc(ColumnsList[i].Width / fLogPelsX * 1440)); // in twips
      Put('\clshdng10000\clcfpat' + IntToStr(GetColorIndex((ColumnsList[i].Title.Color))));
      PutL('\cellx' + IntToStr(w));
    end;

    PutL('{\trrh0');

    for i := 0 to ColumnsList.Count - 1 do
    begin
      if DBGridEh.Flat then Space := '12' else Space := '24';
      Put('\pard\intbl{' + GetAlignment(ColumnsList[i].Title.Alignment) + '\sb' + Space + '\sa' + Space);
      PutText(ColumnsList[i].Title.Font, ColumnsList[i].Title.Caption, ColumnsList[i].Title.Color);
      PutL('\cell}');
    end;

    PutL('\pard\intbl\row}');
  end;
end;

procedure TDBGridEhExportAsRTF.WriteRecord(ColumnsList: TColumnsEhList);
var fLogPelsX: Integer;
  i, w: Integer;
begin
  Put('\trowd');
  PutL('\trgaph40');

  fLogPelsX := GetDeviceCaps(DBGridEh.Canvas.Handle, LOGPIXELSX);

  w := 0;
  for i := 0 to ColumnsList.Count - 1 do
  begin
    WriteCellBorder(True, True, True, True);
    Inc(w, Trunc(ColumnsList[i].Width / fLogPelsX * 1440)); // in twips
    Put('\clshdng10000\clcfpat' + IntToStr(GetColorIndex(GetDataCellColor(ColumnsList, i))));
    PutL('\cellx' + IntToStr(w));
  end;

  PutL('{\trrh0');

  inherited WriteRecord(ColumnsList);

  PutL('\pard\intbl\row}');
end;

procedure TDBGridEhExportAsRTF.WriteDataCell(Column: TColumnEh; FColCellParamsEh: TColCellParamsEh);
var Space: String;
begin
  if DBGridEh.Flat then Space := '12' else Space := '24';
  Put('\pard\intbl{' + GetAlignment(FColCellParamsEh.Alignment) + '\sb' + Space + '\sa' + Space);
  PutText(FColCellParamsEh.Font, FColCellParamsEh.Text, FColCellParamsEh.Background);
  PutL('\cell}');
end;

procedure TDBGridEhExportAsRTF.WriteCellBorder(LeftBorder, TopBorder, BottomBorder, RightBorder: Boolean);
begin
  if LeftBorder then
  begin
    Put('\clbrdrl');
    Put('\brdrs');
    PutL('\brdrcf0');
  end;

  if TopBorder then
  begin
    Put('\clbrdrt');
    Put('\brdrs');
    PutL('\brdrcf0');
  end;

  if BottomBorder then
  begin
    Put('\clbrdrb');
    Put('\brdrs');
    PutL('\brdrcf0');
  end;

  if RightBorder then
  begin
    Put('\clbrdrr');
    Put('\brdrs');
    PutL('\brdrcf0');
  end;
end;

procedure TDBGridEhExportAsRTF.WriteFooter(ColumnsList: TColumnsEhList;
  FooterNo: Integer);
var fLogPelsX: Integer;
  i, w: Integer;
begin
  Put('\trowd');
  PutL('\trgaph40');

  fLogPelsX := GetDeviceCaps(DBGridEh.Canvas.Handle, LOGPIXELSX);

  w := 0;
  for i := 0 to ColumnsList.Count - 1 do
  begin
    WriteCellBorder(True, True, True, True);
    Inc(w, Trunc(ColumnsList[i].Width / fLogPelsX * 1440)); // in twips
    Put('\clshdng10000\clcfpat' +
      IntToStr(GetColorIndex(GetFooterCellColor(ColumnsList, i, FooterNo))));
    PutL('\cellx' + IntToStr(w));
  end;

  PutL('{\trrh0'); // row auto-height

  inherited WriteFooter(ColumnsList, FooterNo);

  PutL('\pard\intbl\row}');
end;

procedure TDBGridEhExportAsRTF.WriteFooterCell(DataCol, Row: Integer;
  Column: TColumnEh; AFont: TFont; Background: TColor;
  Alignment: TAlignment; Text: String);
var Space: String;
begin
  if DBGridEh.Flat then Space := '12' else Space := '24';
  Put('\pard\intbl{' + GetAlignment(Alignment) + '\sb' + Space + '\sa' + Space);
  PutText(AFont, Text, Background);
  PutL('\cell}');
end;

function TDBGridEhExportAsRTF.GetDataCellColor(ColumnsList: TColumnsEhList;
  ColIndex: Integer): TColor;
var Font: TFont;
  State: TGridDrawState;
begin
  Font := TFont.Create;
  try
    Font.Assign(ColumnsList[ColIndex].Font);
    Result := ColumnsList[ColIndex].Color;
    State := [];
    if Assigned(DBGridEh.OnGetCellParams) then
      DBGridEh.OnGetCellParams(DBGridEh, ColumnsList[ColIndex], Font, Result, State);
  finally
    Font.Free;
  end;
end;

function TDBGridEhExportAsRTF.GetFooterCellColor(
  ColumnsList: TColumnsEhList; ColIndex: Integer; FooterNo: Integer): TColor;
var Font: TFont;
  State: TGridDrawState;
  Alignment: TAlignment;
  Value: String;
begin
  Font := TFont.Create;
  try
    Font.Assign(ColumnsList[ColIndex].UsedFooter(FooterNo).Font);
    Result := ColumnsList[ColIndex].UsedFooter(FooterNo).Color;
    Alignment := ColumnsList[ColIndex].UsedFooter(FooterNo).Alignment;
    if ColumnsList[ColIndex].UsedFooter(FooterNo).ValueType in [fvtSum, fvtCount] then
      Value := GetFooterValue(FooterNo, ColIndex)
    else
      Value := DBGridEh.GetFooterValue(FooterNo, ColumnsList[ColIndex]);
    State := [];
    if Assigned(DBGridEh.OnGetFooterParams) then
      DBGridEh.OnGetFooterParams(DBGridEh, ColumnsList[ColIndex].Index, FooterNo,
        ColumnsList[ColIndex], Font, Result, Alignment, State, Value);
  finally
    Font.Free;
  end;
end;

{ TDBGridEhExportAsXLS }

var
  CXlsBof: array[0..5] of Word = ($809, 8, 0, $10, 0, 0);
  CXlsEof: array[0..1] of Word = ($0A, 00);
  CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
  CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
  CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
  CXlsBlank: array[0..4] of Word = ($201, 6, 0, 0, $17);


procedure TDBGridEhExportAsXLS.WriteBlankCell;
begin
  CXlsBlank[2] := FRow;
  CXlsBlank[3] := FCol;
  Stream.WriteBuffer(CXlsBlank, SizeOf(CXlsBlank));
  IncColRow;
end;

procedure TDBGridEhExportAsXLS.WriteFloatCell(const AValue: Double);
begin
  CXlsNumber[2] := FRow;
  CXlsNumber[3] := FCol;
  Stream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
  Stream.WriteBuffer(AValue, 8);
  IncColRow;
end;

procedure TDBGridEhExportAsXLS.WriteIntegerCell(const AValue: Integer);
var
  V: Integer;
begin
  CXlsRk[2] := FRow;
  CXlsRk[3] := FCol;
  Stream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
  V := (AValue shl 2) or 2;
  Stream.WriteBuffer(V, 4);
  IncColRow;
end;

procedure TDBGridEhExportAsXLS.WriteStringCell(const AValue: string);
var
  L: Word;
begin
  L := Length(AValue);
  CXlsLabel[1] := 8 + L;
  CXlsLabel[2] := FRow;
  CXlsLabel[3] := FCol;
  CXlsLabel[5] := L;
  Stream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
  Stream.WriteBuffer(Pointer(AValue)^, L);
  IncColRow;
end;

procedure TDBGridEhExportAsXLS.WritePrefix;
begin
  Stream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;

procedure TDBGridEhExportAsXLS.WriteSuffix;
begin
  Stream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;

procedure TDBGridEhExportAsXLS.WriteTitle(ColumnsList: TColumnsEhList);
var i: Integer;
begin
  for i := 0 to ColumnsList.Count - 1 do
  begin
    WriteStringCell(ColumnsList[i].Title.Caption);
  end;
end;

procedure TDBGridEhExportAsXLS.WriteDataCell(Column: TColumnEh; FColCellParamsEh: TColCellParamsEh);
begin
  if Column.Field = nil then
    WriteBlankCell
  else if Column.GetColumnType = ctKeyPickList then
    WriteStringCell(FColCellParamsEh.Text)
  else if Column.Field.IsNull then
    WriteBlankCell
  else
    with Column.Field do
      case DataType of
        ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
          WriteIntegerCell(AsInteger);
        ftFloat, ftCurrency, ftBCD{$IFDEF EH_LIB_6}, ftFMTBcd{$ENDIF}:
          WriteFloatCell(AsFloat);
      else
        WriteStringCell(FColCellParamsEh.Text);
      end;
end;

procedure TDBGridEhExportAsXLS.WriteFooterCell(DataCol, Row: Integer;
  Column: TColumnEh; AFont: TFont; Background: TColor;
  Alignment: TAlignment; Text: String);
begin
  if Column.UsedFooter(Row).ValueType in [fvtSum, fvtCount] then
    WriteFloatCell(FooterValues[Row * ExpCols.Count + DataCol])
  else
    WriteStringCell(Text);
end;

procedure TDBGridEhExportAsXLS.ExportToStream(AStream: TStream;
  IsExportAll: Boolean);
begin
  FCol := 0;
  FRow := 0;
  inherited ExportToStream(AStream, IsExportAll);
end;

procedure TDBGridEhExportAsXLS.IncColRow;
begin
  if FCol = ExpCols.Count - 1 then
  begin
    Inc(FRow);
    FCol := 0;
  end else
    Inc(FCol);
end;

{ TDBGridEhExportAsVCLDBIF }

var
  VCLDBIF_BOF: TVCLDBIF_BOF = (Signatura: ('V', 'C', 'L', 'D', 'B', 'I', 'F'); Version: 1; ColCount: 0);

procedure TDBGridEhExportAsVCLDBIF.WritePrefix;
var
  i: Integer;
  b: Byte;
begin
  VCLDBIF_BOF.ColCount := ExpCols.Count; //CalcColCount;
  Stream.WriteBuffer(VCLDBIF_BOF, SizeOf(VCLDBIF_BOF));
  for i := 0 to ExpCols.Count - 1 do
  begin
    if ExpCols[i].Visible then b := 1 else b := 0;
    Stream.WriteBuffer(b, SizeOf(Byte));
    //Stream.WriteBuffer(PChar(ExpCols[i].FieldName)^,Length(ExpCols[i].FieldName)+1);
    Stream.WriteBuffer(PChar('')^, 1);
  end;
end;

procedure TDBGridEhExportAsVCLDBIF.WriteSuffix;
var b: Byte;
begin
  b := TVCLDBIF_TYPE_EOF;
  Stream.WriteBuffer(b, SizeOf(Byte));
end;

procedure TDBGridEhExportAsVCLDBIF.WriteDataCell(Column: TColumnEh; FColCellParamsEh: TColCellParamsEh);
var Field: TField;
begin
  if (Column.Field <> nil) and Column.Field.Lookup then
    Field := Column.Field.Dataset.FieldByName(Column.Field.KeyFields)
  else
    Field := Column.Field;
  if Field = nil then
    WriteUnassigned
  else if Field.IsNull then