Главная страницаОбратная связьКарта сайта

Преобразование информации из табличных компонент в RTF

Автор: 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;

Обсудить статью на форуме


Если Вас заинтересовала или понравилась информация по разработке на Delph - "Преобразование информации из табличных компонент в RTF", Вы можете поставить закладку в социальной сети или в своём блоге на данную страницу:

Так же Вы можете задать вопрос по работе этого модуля или примера через форму обратной связи, в сообщение обязательно указывайте название или ссылку на статью!
   


Copyright © 2008 - 2024 Дискета.info