Архив исходников программ, модулей и компонентов на Delphi


Начальная страница

Поиск по базе



Операционная система
Настройка приложения
Взаимодействия приложений
Файлы и директории
Строки и символы
Математика
Базы данных
Интернет и сеть
Мультимедиа
Аппаратная часть
VCL
Другие разделы [0]
 

Количество записей в базе - 537
Сегодня добавлено – 0

Сервис для компонентов



Вернуться к списку функций
 Преобразование информации из табличных компонент в RTF

 Прислал: Delirium (Москва) ( 9 июля 2002 г. )
©  Copyright (c) 1999 by K. Nishita / Master BRAIN (Delirium) - 2002 г.
 Описание:
Модуль содержит ряд функций, ориентированных на работу с VCL-компонентами. Содержимое списков и таблиц, конвертируется в формат RTF, для дальнейшей распечатки или копирования в буфер обмена.

 Зависимости:
SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, ExtCtrls, Grids, Forms, DBGrids

 Ограничения:
D6

 Исходный текст:
{ **** UBPFD *********** by http://kladovka.net.ru/delphibase/ ****
>> Преобразование информации из табличных компонент в 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;


Вернуться к списку функций

Наверх ▲