Преобразование информации из табличных компонент в 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", Вы можете поставить закладку в социальной сети или в своём блоге на данную страницу:
Так же Вы можете задать вопрос по работе этого модуля или примера через форму обратной связи , в сообщение обязательно указывайте название или ссылку на статью!