Автор: Delirium
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Преобразование информации из табличных компонент в RTF

Модуль содержит ряд функций, ориентированных на работу с VCL-компонентами.
Содержимое списков и таблиц, конвертируется в формат RTF, для дальнейшей
распечатки или копирования в буфер обмена.

Зависимости: SysUtils, Windows, Messages, Classes, Graphics, Controls,
StdCtrls, ExtCtrls, Grids, Forms, DBGrids
Автор:       Delirium, Master_BRAIN@beep.ru, ICQ:118395746, Москва
Copyright:   Copyright (c) 1999 by K. Nishita / Master BRAIN (Delirium) - 2002 г.
Дата:        9 июля 2002 г.
***************************************************** }

{*************************************************************}
{ }
{ Переработал компонент в unit, добавил фукцию }
{ по работе с TDBGrid. }
{ }
{ Master BRAIN (Delirium) - 2002 г. }
{ }
{*************************************************************}
{ Delphi Control to RTF Conversion VCL }
{ Version: 1.0 }
{ Author: K. Nishita }
{ E-Mail: info@nishita.com }
{ Home Page: http://nishita.com }
{ Created: 3/1/2000 }
{ Type: Freeware }
{ Legal: Copyright (c) 1999 by K. Nishita }
{*************************************************************}
{ This component convert Delphi grid, edit, listbox, memo, }
{ and label to Rich Text Format. }
{*************************************************************}

unit CtrlToRTF;

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls,
  StdCtrls, ExtCtrls, Grids, Forms, DBGrids;

function RTFHeader: string;
function RTFFooter: string;
function ImageToRTF(Image: TImage; Alignment: TAlignment): string;
function MemoToRTF(Memo: TMemo): string;
function StringsToRTF(pStringList: TStrings; Font: TFont; Alignment:
  TAlignment): string;
function StringToRTF(pString: string; Font: TFont; Alignment: TAlignment):
  string;
function GridToRTF(Grid: TStringGrid): string;
function DBGridToRTF(DBGrid: TDBGrid): string;

implementation

var
  RTF, FontTable: TStrings;

function GetRTFFontTableName(FontName: string): string;
var
  i: Integer;
begin
  Result := '\f0';
  for i := 0 to FontTable.Count - 1 do
  begin
    if Pos(FontName, FontTable.Strings[i]) > 0 then
    begin
      Result := '\f' + IntToStr(i);
      Exit;
    end;
  end;
end;

function GetRTFFontAttrib(Style: TFontStyles): string;
var
  retval: string;
begin
  retval := '';
  if fsBold in Style then
    retval := retval + '\b';
  if fsItalic in Style then
    retval := retval + '\c';
  if fsUnderline in Style then
    retval := retval + '\ul';
  if fsStrikeOut in Style then
    retval := retval + '\strike';
  Result := retval;
end;

function GetRTFFontSize(Size: Integer): string;
begin
  Result := '\fs' + IntToStr(size * 2);
end;

function GetRTFAlignment(Alignment: TAlignment): string;
var
  Align: string;
begin
  if Alignment = taCenter then
    Align := '\qc'
  else if Alignment = taRightJustify then
    Align := '\qr'
  else
    Align := '';
  Result := Align;
end;

function GetRTFFontColorTableName(Color: TColor): string;
begin
  if Color = clBlack then
    Result := '\cf0'
  else if Color = clMaroon then
    Result := '\cf1'
  else if Color = clGreen then
    Result := '\cf2'
  else if Color = clOlive then
    Result := '\cf3'
  else if Color = clNavy then
    Result := '\cf4'
  else if Color = clPurple then
    Result := '\cf5'
  else if Color = clTeal then
    Result := '\cf6'
  else if Color = clGray then
    Result := '\cf7'
  else if Color = clSilver then
    Result := '\cf8'
  else if Color = clRed then
    Result := '\cf9'
  else if Color = clLime then
    Result := '\cf10'
  else if Color = clYellow then
    Result := '\cf11'
  else if Color = clBlue then
    Result := '\cf12'
  else if Color = clFuchsia then
    Result := '\cf13'
  else if Color = clAqua then
    Result := '\cf14'
  else if Color = clWhite then
    Result := '\cf15';
end;

procedure Creator;
begin
  RTF := TStringList.Create;
  FontTable := TStringList.Create;
end;

procedure Destroyer;
begin
  RTF.Free;
  FontTable.Free;
end;

function RTFHeader: string;
var
  i: Integer;
begin
  Creator;

  RTF.Append('{\rtf1\ansi\ansicpg1252\deff0\deftab720');
  RTF.Append('{\fonttbl');
  for i := 0 to FontTable.count - 1 do
    RTF.Append(FontTable.Strings[i]);
  RTF.Append('}');
  RTF.Append('{\colortbl');
  RTF.Append('\red0\green0\blue0;'); {Black}
  RTF.Append('\red128\green0\blue0;'); {Maroon}
  RTF.Append('\red0\green128\blue0;'); {Green}
  RTF.Append('\red128\green128\blue0;'); {Olive}
  RTF.Append('\red0\green0\blue128;'); {Navy}
  RTF.Append('\red128\green0\blue128;'); {Purple}
  RTF.Append('\red0\green128\blue128;'); {Teal}
  RTF.Append('\red128\green128\blue128;'); {Gray}
  RTF.Append('\red192\green192\blue192;'); {Silver}
  RTF.Append('\red255\green0\blue0;'); {Red}
  RTF.Append('\red0\green255\blue0;'); {Lime}
  RTF.Append('\red255\green255\blue0;'); {Yellow}
  RTF.Append('\red0\green0\blue255;'); {Blue}
  RTF.Append('\red255\green0\blue255;'); {Fuchsia}
  RTF.Append('\red0\green255\blue255;'); {Aqua}
  RTF.Append('\red255\green255\blue255;'); {White}
  RTF.Append('}');

  Result := RTF.Text;

  Destroyer;
end;

function RTFFooter: string;
begin
  Result := #13#10+'}}';
end;

function GridToRTF(Grid: TStringGrid): string;
var
  i, j: Integer;
  Temp: double;
  FontColor, FontAttrib, FontSize, FontName: string;
begin
  Creator;

  FontColor := GetRTFFontColorTableName(Grid.Font.Color);
  FontSize := GetRTFFontSize(Grid.Font.Size);
  FontAttrib := GetRTFFontAttrib(Grid.Font.Style);
  FontName := GetRTFFontTableName(Grid.Font.Name);
  RTF.Append('\par \pard\plain\cgrid');
  RTF.Append('{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
  RTF.Append('{\*\cs10 \additive Default Paragraph Font;}}');
  RTF.Append('{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
  RTF.Append('.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
  RTF.Append('{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1' +
    '\pnindent720\pnhang{\pntxta');
  RTF.Append('.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta');
  RTF.Append(')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
  RTF.Append(')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang');
  RTF.Append('{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720'
    +
    '\pnhang{\pntxtb (}{\pntxta');
  RTF.Append(')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
  RTF.Append(')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}');

  for i := 0 to Grid.RowCount - 1 do
  begin
    RTF.Append('\trowd');
    RTF.Append('\trgaph108');
    RTF.Append('\trrh260');
    RTF.Append('\trleft90');
    RTF.Append('\trbrdrt\brdrs\brdrw10');
    RTF.Append('\trbrdrl\brdrs\brdrw10');
    RTF.Append('\trbrdrb\brdrs\brdrw10');
    RTF.Append('\trbrdrr\brdrs\brdrw10');
    RTF.Append('\trbrdrh\brdrs\brdrw10');
    RTF.Append('\trbrdrv\brdrs\brdrw10');

    for j := 0 to Grid.ColCount - 1 do
    begin
      RTF.Append('\clvertalt');
      RTF.Append('\clbrdrt\brdrs\brdrw10');
      RTF.Append('\clbrdrl\brdrs\brdrw10');
      RTF.Append('\clbrdrb\brdrs\brdrw10');
      RTF.Append('\clbrdrr\brdrs\brdrw10');
      if (j < Grid.FixedCols) or (i < Grid.FixedRows) then
        RTF.Append('\clcbpat8');
      RTF.Append('\cltxlrtb');
      Temp := (j + 1) * Grid.DefaultColWidth;
      Temp := (Temp / Screen.pixelsperinch) * 1440.0 + 108.0;
      RTF.Append('\cellx' + IntToStr(round(Temp)));
    end;
    RTF.Append('\pard\ri-123\nowidctlpar\widctlpar\intbl\adjustright');
    RTF.Append(' {' + FontName + FontSize + FontAttrib + FontColor + '\cgrid0');
    for j := 0 to Grid.ColCount - 1 do
      RTF.Append(Grid.Cells[j, i] + '\cell ');
    RTF.Append('}');
    RTF.Append('\pard \nowidctlpar\widctlpar\intbl\adjustright {\row}');
  end;

  RTF.Append('\pard\nowidctlpar\widctlpar\adjustright {');

  Result := RTF.Text;

  Destroyer;
end;

function DBGridToRTF(DBGrid: TDBGrid): string;
var
  j: Integer;
  Temp: double;
  FontColor, FontAttrib, FontSize, FontName: string;
begin
  Creator;
  FontColor := GetRTFFontColorTableName(DBGrid.Font.Color);
  FontSize := GetRTFFontSize(DBGrid.Font.Size);
  FontAttrib := GetRTFFontAttrib(DBGrid.Font.Style);
  FontName := GetRTFFontTableName(DBGrid.Font.Name);
  RTF.Append('\par \pard\plain\cgrid');
  RTF.Append('{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
  RTF.Append('{\*\cs10 \additive Default Paragraph Font;}}');
  RTF.Append('{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
  RTF.Append('.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
  RTF.Append('{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1' +
    '\pnindent720\pnhang{\pntxta');
  RTF.Append('.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta');
  RTF.Append(')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
  RTF.Append(')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang');
  RTF.Append('{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
  RTF.Append(')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
  RTF.Append(')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}');
  DBGrid.DataSource.DataSet.DisableControls;
  DBGrid.DataSource.DataSet.First;
  while not DBGrid.DataSource.DataSet.Eof do
  begin
    RTF.Append('\trowd');
    RTF.Append('\trgaph108');
    RTF.Append('\trrh260');
    RTF.Append('\trleft90');
    RTF.Append('\trbrdrt\brdrs\brdrw10');
    RTF.Append('\trbrdrl\brdrs\brdrw10');
    RTF.Append('\trbrdrb\brdrs\brdrw10');
    RTF.Append('\trbrdrr\brdrs\brdrw10');
    RTF.Append('\trbrdrh\brdrs\brdrw10');
    RTF.Append('\trbrdrv\brdrs\brdrw10');
    Temp := 0;
    for j := 0 to DBGrid.Columns.Count - 1 do
    begin
      RTF.Append('\clvertalt');
      RTF.Append('\clbrdrt\brdrs\brdrw10');
      RTF.Append('\clbrdrl\brdrs\brdrw10');
      RTF.Append('\clbrdrb\brdrs\brdrw10');
      RTF.Append('\clbrdrr\brdrs\brdrw10');
      RTF.Append('\cltxlrtb');
      Temp := Temp + DBGrid.Columns[j].Width + 1;
      RTF.Append('\cellx' + IntToStr(Round((Temp / Screen.pixelsperinch * 1440.0)
        + 108.0)));
    end;
    RTF.Append('\pard\ri-123\nowidctlpar\widctlpar\intbl\adjustright');
    RTF.Append(' {' + FontName + FontSize + FontAttrib + FontColor + '\cgrid0');
    for j := 0 to DBGrid.Columns.Count - 1 do
      RTF.Append(DBGrid.Columns[j].Field.DisplayText + '\cell ');
    RTF.Append('}');
    RTF.Append('\pard \nowidctlpar\widctlpar\intbl\adjustright {\row}');
    DBGrid.DataSource.DataSet.Next;
  end;
  DBGrid.DataSource.DataSet.First;
  DBGrid.DataSource.DataSet.EnableControls;

  RTF.Append('\pard\nowidctlpar\widctlpar\adjustright {');

  Result := RTF.Text;

  Destroyer;
end;

function ImageToRTF(Image: TImage; Alignment: TAlignment): string;
type
  PtrRec = record
    Lo: Word;
    Hi: Word;
  end;
  PHugeByteArray = ^THugeByteArray;
  THugeByteArray = array[0..0] of Byte;

  function GetBigPointer(lp: pointer; Offset: LongInt): Pointer;
  begin
    GetBigPointer := @PHugeByteArray(lp)^[Offset];
  end;

var
  hmf: THandle;
  FCanvas: TCanvas;
  lpBits: pointer;
  dwSize: LongInt;
  h, h1, w, w1: double;
  Align: string;
  pPPoint: PPoint;
  pPSize: PSize;
  ST: TStream;
  SL: TStrings;

begin
  Creator;

  FCanvas := TCanvas.Create;
  FCanvas.Handle := CreateMetafile(nil);
  SetMapMode(FCanvas.Handle, mm_AnIsoTropic);
  pPPoint := nil;
  SetWindowOrgEx(FCanvas.Handle, 0, 0, pPPoint);
  pPSize := nil;
  SetWindowExtEx(FCanvas.Handle, Image.Width, Image.Height, pPSize);
  FCanvas.StretchDraw(rect(0, 0, Image.Width, Image.Height),
    Image.Picture.Graphic);
  hmf := CloseMetafile(FCanvas.Handle);
  dwSize := 0;
  dwSize := GetMetaFileBitsEx(hmf, dwSize, nil);
  GetMem(lpBits, dwSize);
  GetMetaFileBitsEx(hmf, dwSize, lpBits);
  h := Image.Height;
  h1 := h;
  w := Image.Width;
  w1 := w;
  h := (h / Screen.pixelsperinch) * 1440.0;
  w := (w / Screen.pixelsperinch) * 1440.0;
  h1 := 26.46875 * h1;
  w1 := 26.46875 * w1;
  Align := GetRTFAlignment(Alignment);
  RTF.Append('\par \pard' + Align + '\plain\cgrid {\pict');
  RTF.Append('\picscalex100');
  RTF.Append('\picscaley100');
  RTF.Append('\piccropl0');
  RTF.Append('\piccropr0');
  RTF.Append('\piccropt0');
  RTF.Append('\piccropb0');
  RTF.Append('\picw' + inttostr(round(w1)));
  RTF.Append('\pich' + inttostr(round(h1)));
  RTF.Append('\picwgoal' + inttostr(round(w)));
  RTF.Append('\pichgoal' + inttostr(round(h)));
  RTF.Append('\wmetafile8 \bin' + IntToStr(dwSize));
  ST := TMemoryStream.Create;
  ST.Write(lpBits^, dwSize);
  SL := TStringList.Create;
  SL.LoadFromStream(ST);
  RTF.Append(SL.Text);
  SL.Free;
  ST.Free;
  FreeMem(lpBits);
  RTF.Append('}');
  DeleteMetaFile(hmf);
  FCanvas.Free;

  Result := RTF.Text;

  Destroyer;
end;

function MemoToRTF(Memo: TMemo): string;
var
  i: Integer;
  Align, FontColor, FontAttrib, FontSize, FontName: string;
begin
  Creator;

  Align := GetRTFAlignment(Memo.Alignment);
  FontColor := GetRTFFontColorTableName(Memo.Font.Color);
  FontSize := GetRTFFontSize(Memo.Font.Size);
  FontAttrib := GetRTFFontAttrib(Memo.Font.Style);
  FontName := GetRTFFontTableName(Memo.Font.Name);
  RTF.Append('\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib
    + FontColor);
  for i := 0 to Memo.Lines.Count - 1 do
  begin
    RTF.Append(' \par ' + Memo.Lines[i]);
  end;

  Result := RTF.Text;

  Destroyer;
end;

function StringsToRTF(pStringList: TStrings; Font: TFont; Alignment:
  TAlignment): string;
var
  i: Integer;
  Align, FontColor, FontAttrib, FontSize, FontName: string;
begin
  Creator;

  Align := GetRTFAlignment(Alignment);
  FontColor := GetRTFFontColorTableName(Font.Color);
  FontSize := GetRTFFontSize(Font.Size);
  FontAttrib := GetRTFFontAttrib(Font.Style);
  FontName := GetRTFFontTableName(Font.Name);
  RTF.Append('\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib
    + FontColor);
  for i := 0 to pStringList.Count - 1 do
    RTF.Append(' \par ' + pStringList.strings[i]);

  Result := RTF.Text;

  Destroyer;
end;

function StringToRTF(pString: string; Font: TFont; Alignment: TAlignment):
  string;
var
  Align, FontColor, FontAttrib, FontSize, FontName: string;
begin
  Creator;

  Align := GetRTFAlignment(Alignment);
  FontColor := GetRTFFontColorTableName(Font.Color);
  FontSize := GetRTFFontSize(Font.Size);
  FontAttrib := GetRTFFontAttrib(Font.Style);
  FontName := GetRTFFontTableName(Font.Name);
  RTF.Append('\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib
    + FontColor + ' ' + pString);

  Result := RTF.Text;

  Destroyer;
end;

end.

// Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
  RichEdit1.Text := RTFHeader + DBGridToRTF(DBGrid1) + RTFFooter;
end;