dbgridehimpexp.pas

ehlib 4.2.16 表格控件 for delphi 5-2009

      ListOfHeadTreeNodeList.Free;
//      FreeMem(FPTitleExpArr);
    end;
  end else
  begin
    PutL('<TR>');
    for i := 0 to ColumnsList.Count - 1 do
    begin
      Put('  <TD WIDTH=' + IntToStr(ColumnsList[i].Width) +
        ' ALIGN="' + GetAlignment(ColumnsList[i].Title.Alignment) + '"' + '>');
      PutText(ColumnsList[i].Title.Font, ColumnsList[i].Title.Caption);
      PutL('</TD>');
    end;
    PutL('</TR>');
  end;
end;

procedure TDBGridEhExportAsHTML.WriteRecord(ColumnsList: TColumnsEhList);
begin
  PutL('<TR>');
  inherited;
  PutL('</TR>');
end;

procedure TDBGridEhExportAsHTML.WriteDataCell(Column: TColumnEh; FColCellParamsEh: TColCellParamsEh);
begin
  Put('  <TD WIDTH=' + IntToStr(Column.Width) +
    ' ALIGN="' + GetAlignment(FColCellParamsEh.Alignment) + '"' +
    ' BGCOLOR=#' + GetColor(FColCellParamsEh.Background) +
    '>');
  PutText(FColCellParamsEh.Font, FColCellParamsEh.Text);
  PutL('</TD>');
end;

function TDBGridEhExportAsHTML.GetAlignment(Alignment: TAlignment): String;
begin
  case Alignment of
    taLeftJustify: Result := 'LEFT';
    taCenter: Result := 'CENTER';
    taRightJustify: Result := 'RIGHT';
  end;
end;

procedure TDBGridEhExportAsHTML.PutText(Font: TFont; Text: String);
var s: String;
begin
  s := '<FONT STYLE="font-family: ' + Font.Name;
  s := s + '; font-size: ' + IntToStr(Font.Size);
  s := s + 'pt; color: #' + GetColor(Font.Color) + '">';

  if (fsBold in Font.Style) then s := s + '<B>';
  if (fsItalic in Font.Style) then s := S + '<I>';
  if (fsUnderline in Font.Style) then s := s + '<U>';
  if (fsStrikeOut in Font.Style) then s := s + '<STRIKE>';

  Text := StringReplace(Text, '&', '&amp', [rfReplaceAll]);
  Text := StringReplace(Text, '<', '&lt', [rfReplaceAll]);
  Text := StringReplace(Text, '>', '&gt', [rfReplaceAll]);
  Text := StringReplace(Text, '"', '&quot', [rfReplaceAll]);

  if Text <> '' then
    s := s + Text
  else
    s := s + '&nbsp';

  if (fsBold in Font.Style) then s := s + '</B>';
  if (fsItalic in Font.Style) then s := S + '</I>';
  if (fsUnderline in Font.Style) then s := s + '</U>';
  if (fsStrikeOut in Font.Style) then s := s + '</STRIKE>';
  s := s + '</FONT>';

  Put(s);
end;

function TDBGridEhExportAsHTML.GetColor(Color: TColor): String;
var s: String;
begin
  if Color = clNone then
    s := '000000'
  else
    s := IntToHex(ColorToRGB(Color), 6);
  Result := Copy(s, 5, 2) + Copy(s, 3, 2) + Copy(s, 1, 2);
end;

procedure TDBGridEhExportAsHTML.WriteFooter(ColumnsList: TColumnsEhList;
  FooterNo: Integer);
begin
  PutL('<TR>');
  inherited;
  PutL('</TR>');
end;

procedure TDBGridEhExportAsHTML.WriteFooterCell(DataCol, Row: Integer;
  Column: TColumnEh; AFont: TFont; Background: TColor;
  Alignment: TAlignment; Text: String);
var Footer: TColumnFooterEh;
begin
  Footer := Column.UsedFooter(Row);
  Put('  <TD WIDTH=' + IntToStr(Column.Width) +
    ' ALIGN="' + GetAlignment(Footer.Alignment) + '"' +
    ' BGCOLOR=#' + GetColor(Background) +
    '>');
  PutText(AFont, Text);
  PutL('</TD>');
end;

{ TDBGridEhExportAsRTF }

procedure TDBGridEhExportAsRTF.ExportToStream(AStream: TStream; IsExportAll: Boolean);
var
  i: Integer;
begin
  FCacheStream := TMemoryStreamEh.Create;
  FCacheStream.HalfMemoryDelta := $10000;
  ColorTblList := TStringList.Create;
  FontTblList := TStringList.Create;
  try
    GetColorIndex(clBlack);
    GetColorIndex(clWhite);
    GetColorIndex(clBtnFace);

    inherited ExportToStream(FCacheStream, IsExportAll);

    Stream := AStream;

    PutL('{\rtf0\ansi');

    Put('{\colortbl');
    for i := 0 to ColorTblList.Count - 1 do
      Put('\red' + Trim(Copy(ColorTblList[i], 1, 3)) +
        '\green' + Trim(Copy(ColorTblList[i], 4, 3)) +
        '\blue' + Trim(Copy(ColorTblList[i], 7, 3)) + ';');
    PutL('}');

    Put('{\fonttbl');
    for i := 0 to FontTblList.Count - 1 do
      Put('\f' + IntToStr(i) + '\fnil ' + FontTblList[i] + ';');
    PutL('}');
    FCacheStream.SaveToStream(Stream);
  finally
    FCacheStream.Free;
    ColorTblList.Free;
    FontTblList.Free;
  end;
end;

procedure TDBGridEhExportAsRTF.Put(Text: String);
begin
  StreamWriteAnsiString(Stream, AnsiString(Text));
//  Stream.Write(PChar(Text)^, Length(Text));
end;

procedure TDBGridEhExportAsRTF.PutL(Text: String);
begin
  Put(Text + #13#10);
end;

procedure TDBGridEhExportAsRTF.PutText(Font: TFont; Text: String; Background: TColor);
var s: String;
begin

  s := '\fs' + IntToStr(Font.Size * 2);
  if (fsBold in Font.Style) then s := s + '\b';
  if (fsItalic in Font.Style) then s := s + '\i';
  if (fsStrikeOut in Font.Style) then s := s + '\strike';
  if (fsUnderline in Font.Style) then s := s + '\ul';
  s := s + '\f' + IntToStr(GetFontIndex(Font.Name));
  s := s + '\cf' + IntToStr(GetColorIndex(Font.Color));
  s := s + '\cb' + IntToStr(GetColorIndex(Background));
  Put(s + ' ');
  Put(Text);
end;

function TDBGridEhExportAsRTF.GetAlignment(Alignment: TAlignment): String;
begin
  case Alignment of
    taLeftJustify: Result := '\ql';
    taCenter: Result := '\qc';
    taRightJustify: Result := '\qr';
  end;
end;

function TDBGridEhExportAsRTF.GetFontIndex(FontName: String): Integer;
begin
  Result := FontTblList.IndexOf(FontName);
  if Result = -1 then
    Result := FontTblList.Add(FontName);
end;

function TDBGridEhExportAsRTF.GetColorIndex(Color: TColor): Integer;
var RGBColor: Longint;
  s: String;
begin
  RGBColor := ColorToRGB(Color);
  s := Format('%3d%3d%3d', [GetRValue(RGBColor), GetGValue(RGBColor), GetBValue(RGBColor)]);
  Result := ColorTblList.IndexOf(s);
  if Result = -1 then
    Result := ColorTblList.Add(s);
end;

procedure TDBGridEhExportAsRTF.WritePrefix;
begin
end;

procedure TDBGridEhExportAsRTF.WriteSuffix;
begin
  Put('}');
end;

procedure TDBGridEhExportAsRTF.WriteTitle(ColumnsList: TColumnsEhList);
var fLogPelsX: Integer;
  i, w, k: Integer;
  FPTitleExpArr: TTitleExpArr;
  ListOfHeadTreeNodeList: TList;
  ColSpan, RowSpan: Integer;
  Text: String;
  LeftBorder, TopBorder, BottomBorder, RightBorder: Boolean;
  ExclLeftBorders, ExclTopBorders, ExclBottomBorders, ExclRightBorders: TStringList;
  Space: String;

  procedure AddExclBorders(Col, Row, ColSpan, RowSpan: Integer);
  var i, k: Integer;
  begin
    for i := Col to Col + ColSpan - 1 do
      for k := Row downto Row - RowSpan + 1 do
      begin
        if i <> Col then
          ExclLeftBorders.Add(Format('%3d%3d', [i, k]));
        if i <> Col + ColSpan - 1 then
          ExclRightBorders.Add(Format('%3d%3d', [i, k]));
        if k <> Row then
          ExclTopBorders.Add(Format('%3d%3d', [i, k]));
        if k <> Row - RowSpan + 1 then
          ExclBottomBorders.Add(Format('%3d%3d', [i, k]));
      end;
  end;

  procedure CalcBorders(Col, Row: Integer);
  begin
    LeftBorder := True; TopBorder := True;
    BottomBorder := True; RightBorder := True;
    if ExclLeftBorders.IndexOf(Format('%3d%3d', [Col, Row])) <> -1 then
      LeftBorder := False;
    if ExclRightBorders.IndexOf(Format('%3d%3d', [Col, Row])) <> -1 then
      RightBorder := False;
    if ExclTopBorders.IndexOf(Format('%3d%3d', [Col, Row])) <> -1 then
      TopBorder := False;
    if ExclBottomBorders.IndexOf(Format('%3d%3d', [Col, Row])) <> -1 then
      BottomBorder := False;
  end;
begin
  fLogPelsX := GetDeviceCaps(DBGridEh.Canvas.Handle, LOGPIXELSX);

  if DBGridEh.UseMultiTitle then
  begin
    Space := IntToStr(Abs(Trunc(DBGridEh.VTitleMargin / 2 / fLogPelsX * 1440 - 20)));
    ExclLeftBorders := nil; ExclTopBorders := nil;
    ExclBottomBorders := nil; ExclRightBorders := nil;
    try
      CreateMultiTitleMatrix(DBGridEh, ColumnsList, FPTitleExpArr, ListOfHeadTreeNodeList);

      ExclLeftBorders := TStringList.Create;
      ExclTopBorders := TStringList.Create;
      ExclBottomBorders := TStringList.Create;
      ExclRightBorders := TStringList.Create;

      //MultiTitle
      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,