dbgridehimpexp.pas

Delphi控件源码

            PutText(DBGridEh.TitleFont,
                    THeadTreeNode(TList(ListOfHeadTreeNodeList.Items[k]).Items[i]).Text);
            PutL('</TD>');
          end;
        end;
        PutL('</TR>');
      end;

      PutL('<TR>');
      for i := 0 to ColumnsList.Count-1 do
      begin
        if THeadTreeNode(TList(ListOfHeadTreeNodeList.Items[0]).Items[i]) <> nil then
        begin
          Put('  <TD WIDTH=' + IntToStr(ColumnsList[i].Width) + ' ALIGN="CENTER"');
          CalcSpan(ColumnsList,ListOfHeadTreeNodeList,0,i,ColSpan,RowSpan);
          if ColSpan > 1 then
            Put(' COLSPAN = "' + IntToStr(ColSpan) + '"');
          if RowSpan > 1 then
            Put(' ROWSPAN = "' + IntToStr(RowSpan) + '"');
          Put('>');
          PutText(ColumnsList[i].Title.Font,
                  THeadTreeNode(TList(ListOfHeadTreeNodeList.Items[0]).Items[i]).Text);
          PutL('</TD>');
        end;
      end;
      PutL('</TR>');

    finally
      for i := 0 to ListOfHeadTreeNodeList.Count-1 do
        TList(ListOfHeadTreeNodeList.Items[i]).Free;
      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;
  AFont: TFont; Background: TColor);
begin
 Put('  <TD WIDTH=' + IntToStr(Column.Width) +
                ' ALIGN="' + GetAlignment(Column.Alignment) + '"' +
                ' BGCOLOR=#' + GetColor(Background) +
                '>');
 PutText(AFont,Column.DisplayText);
 PutL('</TD>');
end;

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

{$IFNDEF EH_LIB_4} {Borland Delphi 3.0 or C++ Builder 3.0}
type
  TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);
  
function StringReplace(const S, OldPattern, NewPattern: string;
  Flags: TReplaceFlags): string;
var
  SearchStr, Patt, NewStr: string;
  Offset: Integer;
begin
  if rfIgnoreCase in Flags then
  begin
    SearchStr := AnsiUpperCase(S);
    Patt := AnsiUpperCase(OldPattern);
  end else
  begin
    SearchStr := S;
    Patt := OldPattern;
  end;
  NewStr := S;
  Result := '';
  while SearchStr <> '' do
  begin
    Offset := AnsiPos(Patt, SearchStr);
    if Offset = 0 then
    begin
      Result := Result + NewStr;
      Break;
    end;
    Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
    if not (rfReplaceAll in Flags) then
    begin
      Result := Result + NewStr;
      Break;
    end;
    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  end;
end;
{$ENDIF}

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 := TMemoryStream.Create;
  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
  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: PTitleExpArr;
    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;