Преобразование информации из табличных компонент в RTFDelphi , Синтаксис , ПреобразованияПреобразование информации из табличных компонент в RTF
Автор: Delirium { **** 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; Статья Преобразование информации из табличных компонент в RTF раздела Синтаксис Преобразования может быть полезна для разработчиков на Delphi и FreePascal. Комментарии и вопросыМатериалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта. :: Главная :: Преобразования ::
|
||||
©KANSoftWare (разработка программного обеспечения, создание программ, создание интерактивных сайтов), 2007 |