Delphi-int.ru: портал программистов

Вход Регистрация | Забыли пароль?

Просмотр кода

Идентификатор: 70a4ea26 Описание: BBCode Код загружен: 24 мая 2012, 12:02 (mirt.steelwater)

  1. unit BBCode;
  2. {******************************************************************************}
  3. {*  BB Code Unit                                                              *}
  4. {*  Revolutionary Confederation of Anarcho Syndicalists                       *}
  5. {*  Written by: black.rabbit 2010-2012                                        *}
  6. {******************************************************************************}
  7. interface
  8.  
  9. uses
  10.     Windows, SysUtils, Classes, Graphics,
  11.     ComCtrls, RichEdit, RxRichEd,
  12.     acPNG, jpeg, ImgList, acAlphaImageList,
  13.     Strings;
  14.  
  15. const
  16.     QUOTES : array [0..1] of String = ( '[QUOTE]', '[/QUOTE]' );
  17.  
  18. function ColorToHex (const aColor: TColor) : String;
  19. procedure InsertBBCode (anObject: TRichEdit; const aBBCode: String); overload;
  20. procedure InsertBBCode (anObject: TRxRichEdit; const aBBCode: String); overload;
  21. procedure InsertBitMap (anObject: TRxRichEdit; aBitMap: TBitMap);
  22. function StrToBitMap (anObject: TRxRichEdit; aStr: String; aBitMap: TBitMap) : Integer;
  23. procedure MarkQuotes (var aBBCode: String; const aColor: TColor = clNone);
  24. procedure InsertQuotes (anObject: TRxRichEdit;
  25.                         anIcons : TsAlphaImageList;
  26.                         aBackColor: TColor = clNone);
  27. procedure InsertSmiles (anObject: TRxRichEdit;
  28.                         const aSMILES: array of String;
  29.                         anIcons : TsAlphaImageList;
  30.                         aBackColor: TColor = clNone);
  31. procedure GetTagWords (const aBBCode: String;
  32.                        const aTagOpen: String;
  33.                        const aTagClose: String;
  34.                        out aWords: TStringList);
  35. procedure GetBoldWords (const aBBCode: String;
  36.                         out aWords: TStringList);
  37. procedure GetItalicWords (const aBBCode: String;
  38.                           out aWords: TStringList);
  39. procedure GetUnderlineWords (const aBBCode: String;
  40.                              out aWords: TStringList);
  41. procedure GetKeyWords (const aBBCode: String;
  42.                        out aWords: TStringList);
  43.  
  44. resourcestring
  45.     ERR_BBCODE_NOT_INITIALIZE_OBJECT = 'Объект класса ''%s'' не инициализирован!';
  46.     ERR_BBCODE_INSERT                = 'Ошибка инъекции данных!';
  47.     ERR_BBCODE_BMP                   = 'Ошибка преобразования изображения в RTF-формат!';
  48.     ERR_SMILES_INSERT                = 'Ошибка замены смайлов на изображения!';
  49.  
  50. implementation
  51.  
  52. type
  53.     TEditStreamCallBack = function (dwCookie: LongInt;
  54.                                     pbBuff: PByte;
  55.                                     cb: LongInt;
  56.                                     var pcb: LongInt) : DWORD; stdcall;
  57.     TEditStreamData = packed record
  58.         dwCookie    : LongInt;
  59.         dwError     : LongInt;
  60.         pfnCallback : TEditStreamCallBack;
  61.     end;
  62.  
  63. function EditStreamInCallback (dwCookie: Longint;
  64.                                pbBuff: PByte;
  65.                                cb: Longint;
  66.                                var pcb: Longint) : DWORD; stdcall;
  67. var
  68.     Stream    : TStream;
  69.     dataAvail : LongInt;
  70. begin
  71.     Result := UINT (E_FAIL);
  72.     try
  73.         Stream := TStream (dwCookie);
  74.         if Assigned (Stream) then
  75.         with Stream do
  76.         begin
  77.             dataAvail := Size - Position;
  78.             Result := 0;
  79.             if ( dataAvail <= cb ) then
  80.             begin
  81.                 pcb := Read (pbBuff^,dataAvail);
  82.                 if ( pcb <> dataAvail ) then
  83.                     Result := UINT (E_FAIL);
  84.             end
  85.             else
  86.             begin
  87.                 pcb := Read (pbBuff^,cb);
  88.                 if ( pcb <> cb ) then
  89.                     Result := UINT (E_FAIL);
  90.             end;
  91.         end;
  92.     except
  93.         Result := UINT (E_FAIL);
  94.     end;
  95. end;
  96.  
  97. procedure PutRTFSelection (anObject: TRichEdit; aSourceStream: TStream); overload;
  98. var
  99.     Data : TEditStreamData;
  100. begin
  101.     try
  102.         if ( not Assigned (anObject) ) then
  103.             raise Exception.CreateFmt (ERR_BBCODE_NOT_INITIALIZE_OBJECT,
  104.                                        [TRichEdit.ClassName]);
  105.         with Data do
  106.         begin
  107.             dwCookie := LongInt (aSourceStream);
  108.             dwError := 0;
  109.             pfnCallback := EditStreamInCallBack;
  110.         end;
  111.         anObject.Perform ( EM_STREAMIN, SF_RTF or SFF_SELECTION, LongInt (@Data) );
  112.     except on E: Exception do
  113.         raise Exception.CreateFmt ('%s'#13#10'%s',[ERR_BBCODE_INSERT,E.Message]);
  114.     end;
  115. end;
  116.  
  117. procedure PutRTFSelection (anObject: TRxRichEdit; aSourceStream: TStream); overload;
  118. var
  119.     Data : TEditStreamData;
  120. begin
  121.     try
  122.         if ( not Assigned (anObject) ) then
  123.             raise Exception.CreateFmt (ERR_BBCODE_NOT_INITIALIZE_OBJECT,
  124.                                        [TRxRichEdit.ClassName]);
  125.         with Data do
  126.         begin
  127.             dwCookie := LongInt (aSourceStream);
  128.             dwError := 0;
  129.             pfnCallback := EditStreamInCallBack;
  130.         end;
  131.         anObject.Perform ( EM_STREAMIN, SF_RTF or SFF_SELECTION, LongInt (@Data) );
  132.     except on E: Exception do
  133.         raise Exception.CreateFmt ('%s'#13#10'%s',[ERR_BBCODE_INSERT,E.Message]);
  134.     end;
  135. end;
  136.  
  137. procedure ColorToRGB (const aColor: TColor;
  138.                       var R: Byte;
  139.                       var G: Byte;
  140.                       var B: Byte);
  141. var
  142.     clr : LongInt;
  143. begin
  144.     clr := Graphics.ColorToRGB (aColor);
  145.     R := clr;
  146.     G := clr shr 8;
  147.     B := clr shr 16;
  148. end;
  149.  
  150. function ColorToHex (const aColor: TColor) : String;
  151. var
  152.     R : Byte;
  153.     G : Byte;
  154.     B : Byte;
  155. begin
  156.     Result := '000000';
  157.     try
  158.         ColorToRGB (aColor,R,G,B);
  159.         Result := Format ('%s%s%s',[ IntToHex (R,2), IntToHex (G,2), IntToHex (B,2) ]);
  160.     except
  161.         Result := '000000';
  162.     end;
  163. end;
  164.  
  165. function GetColors (var aBBCode: String; var aPallete: WORD;
  166.                     const aFontColor: TColor = clBlack) : String;
  167. var
  168.     Buf1   : String;
  169.     Buf2   : String;
  170.     Buf3   : String;
  171.     Buffer : String;
  172.     color  : String;
  173.     R      : Byte;
  174.     G      : Byte;
  175.     B      : Byte;
  176. begin
  177.     Result := '';
  178.     Buf1 := '';
  179.     Buf2 := aBBCode;
  180.     Buf3 := '';
  181.     Buffer := aBBCode;
  182.     R := 0;
  183.     G := 0;
  184.     B := 0;
  185.     // цвет шрифта по-умолчанию
  186.     ColorToRGB (aFontColor,R,G,B);
  187.     Result := Format ('\red%d\green%d\blue%d;',[R,G,B]);
  188.     Inc (aPallete);
  189.     // разбираем палитру
  190.     while ( Pos ('[COLOR:#',Buf2) > 0 ) do
  191.     begin
  192.         Buf2 := Copy (  Buf2, Pos ('[COLOR:#', Buf2), ( Length (Buf2) - Pos ('[COLOR:#', Buf2) ) + 1  );
  193.         Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  194.         color := Copy  ( Buf2, Pos ('[COLOR:#', Buf2) + Length ('[COLOR:#'), Length ('RRGGBB') );
  195.         R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
  196.         G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
  197.         B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
  198.         Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
  199.         Inc (aPallete);
  200.         Delete ( Buf2, Pos ('[COLOR:#', Buf2), Length ('[COLOR:#RRGGBB]') );
  201.         Buf3 := Copy (  Buf2, 1, ( Pos ('[/COLOR]', Buf2) - 1 )  );
  202.         Buf2 := Copy (  Buf2, Pos ('[/COLOR]', Buf2) + Length ('[/COLOR]'), ( Length (Buf2) - Pos ('[/COLOR]', Buf2) ) +
  203. 1  );
  204.         // возвращаемся к цвету шрифта 1 - начальный цвет шрифта
  205.         Buffer := Format ('%s\cf%d %s\cf1 %s',[Buf1,aPallete,Buf3,Buf2]);
  206.     end;
  207.     Buffer := Format ('\cf1 %s\cf1',[Buffer]);
  208.     aBBCode := Buffer;
  209. end;
  210.  
  211. function GetBackgrounds (var aBBCode: String; var aPallete: WORD;
  212.                          const aColor: TColor = clWhite) : String;
  213. var
  214.     Buf1   : String;
  215.     Buf2   : String;
  216.     Buf3   : String;
  217.     Buffer : String;
  218.     color  : String;
  219.     R      : Byte;
  220.     G      : Byte;
  221.     B      : Byte;
  222. begin
  223.     Result := '';
  224.     Buf1 := '';
  225.     Buf2 := aBBCode;
  226.     Buf3 := '';
  227.     Buffer := aBBCode;
  228.     R := 0;
  229.     G := 0;
  230.     B := 0;
  231.     // цвет фона по-умолчанию
  232.     ColorToRGB (aColor,R,G,B);
  233.     Result := Format ('\red%d\green%d\blue%d;',[R,G,B]);
  234.     Inc (aPallete);
  235.     // разбираем палитру
  236.     while ( Pos ('[BACKGROUND:#',Buf2) > 0 ) do
  237.     begin
  238.         Buf2 := Copy (  Buf2, Pos ('[BACKGROUND:#', Buf2), ( Length (Buf2) - Pos ('[BACKGROUND:#', Buf2) ) + 1  );
  239.         Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  240.         color := Copy  ( Buf2, Pos ('[BACKGROUND:#', Buf2) + Length ('[BACKGROUND:#'), Length ('RRGGBB') );
  241.         R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
  242.         G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
  243.         B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
  244.         Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
  245.         Inc (aPallete);
  246.         Delete ( Buf2, Pos ('[BACKGROUND:#', Buf2), Length ('[BACKGROUND:#RRGGBB]') );
  247.         Buf3 := Copy (  Buf2, 1, ( Pos ('[/BACKGROUND]', Buf2) - 1 )  );
  248.         Buf2 := Copy (  Buf2, Pos ('[/BACKGROUND]', Buf2) + Length ('[/BACKGROUND]'), ( Length (Buf2) - Pos
  249. ('[/BACKGROUND]', Buf2) ) + 1  );
  250.         // возвращаемся к цвету фона 0 - нет фона
  251.         Buffer := Format ('%s\highlight%d %s\highlight0 %s',[Buf1,aPallete,Buf3,Buf2]);
  252.     end;
  253.     aBBCode := Buffer;
  254. end;
  255.  
  256. function GetFonts (var aBBCode: String; var aFontNumber: WORD;
  257.                    const aFont: TFont) : String;
  258. var
  259.     Buf1   : String;
  260.     Buf2   : String;
  261.     Buf3   : String;
  262.     Buffer : String;
  263.     font   : String;
  264.     size   : String;
  265. begin
  266.     Result := '';
  267.     Buf1 := '';
  268.     Buf2 := aBBCode;
  269.     Buf3 := '';
  270.     Buffer := aBBCode;
  271.     // шрифт по-умолчанию
  272.     Result := Format ('{\f%d\fswiss\fcharset1 %s;}',[aFontNumber,aFont.Name]);
  273.     Inc (aFontNumber);
  274.     // разбираем шрифты
  275.     while ( Pos ('[FONT:',Buf2) > 0 ) do
  276.     begin
  277.         Buf2 := Copy (  Buf2, Pos ('[FONT:', Buf2), ( Length (Buf2) - Pos ('[FONT:', Buf2) ) + 1  );
  278.         Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  279.         font := Copy  ( Buf2, Pos ('[FONT:', Buf2) + Length ('[FONT:'),
  280.                               Pos (']', Buf2) - Pos ('[FONT:', Buf2) - Length ('[FONT:') );
  281.         Result := Format ('%s{\f%d\fswiss\fcharset1 %s;}',[Result,aFontNumber,font]);
  282.         Delete ( Buf2, Pos ('[FONT:', Buf2), Length ( Format ('[FONT:%s]',[font]) ) );
  283.         Buf3 := Copy (  Buf2, 1, ( Pos ('[/FONT]', Buf2) - 1 )  );
  284.         Buf2 := Copy (  Buf2, Pos ('[/FONT]', Buf2) + Length ('[/FONT]'), ( Length (Buf2) - Pos ('[/FONT]', Buf2) ) + 1 
  285. );
  286.         Buffer := Format ('%s\f%d %s\f0 %s',[Buf1,aFontNumber,Buf3,Buf2]);
  287.         Inc (aFontNumber);
  288.     end;
  289.     // размер шрифта по-умолчанию
  290.     Buffer := Format ('\fs%d %s',[aFont.Size*2,Buffer]);
  291.     // разбираем размеры
  292.     while ( Pos ('[SIZE:',Buf2) > 0 ) do
  293.     begin
  294.         Buf2 := Copy (  Buf2, Pos ('[SIZE:', Buf2), ( Length (Buf2) - Pos ('[SIZE:', Buf2) ) + 1  );
  295.         Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  296.         size := Copy  ( Buf2, Pos ('[SIZE:', Buf2) + Length ('[SIZE:'),
  297.                               Pos (']', Buf2) - Pos ('[SIZE:', Buf2) - Length ('[SIZE:') );
  298.         Delete ( Buf2, Pos ('[SIZE:', Buf2), Length ( Format ('[SIZE:%s]',[size]) ) );
  299.         Buf3 := Copy (  Buf2, 1, ( Pos ('[/SIZE]', Buf2) - 1 )  );
  300.         Buf2 := Copy (  Buf2, Pos ('[/SIZE]', Buf2) + Length ('[/SIZE]'), ( Length (Buf2) - Pos ('[/SIZE]', Buf2) ) + 1 
  301. );
  302.         Buffer := Format ('%s\fs%d %s\fs%d %s',[ Buf1, StrToInt (Trim(size))*2, Buf3, aFont.Size*2, Buf2 ]);
  303.     end;
  304.     aBBCode := Buffer;
  305. end;
  306.  
  307. procedure MarkQuotes (var aBBCode: String; const aColor: TColor = clNone);
  308. var
  309.     Buf1   : String;
  310.     Buf2   : String;
  311.     Buf3   : String;
  312.     Buffer : String;
  313.     Author : String;
  314. begin
  315.     aBBCode := StrReplace (aBBCode,'[quote','[QUOTE');
  316.     aBBCode := StrReplace (aBBCode,'[/quote]','[/QUOTE]');
  317.     Buf1 := '';
  318.     Buf2 := aBBCode;
  319.     Buf3 := '';
  320.     Buffer := aBBCode;
  321.     while ( Pos ('[QUOTE:',Buf2) > 0 ) do
  322.     begin
  323.         Buf2 := Copy (  Buf2, Pos ('[QUOTE:', Buf2), ( Length (Buf2) - Pos ('[QUOTE:', Buf2) ) + 1  );
  324.         Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  325.         Author := Copy  ( Buf2, Pos ('[QUOTE:', Buf2) + Length ('[QUOTE:'),
  326.                                 Pos (']', Buf2) - Pos ('[QUOTE:', Buf2) - Length ('[QUOTE:') );
  327.  
  328.         Delete ( Buf2, Pos ('[QUOTE:', Buf2), Length ( Format ('[QUOTE:%s]',[Author]) ) );
  329.         Buf3 := Copy (  Buf2, 1, ( Pos ('[/QUOTE]', Buf2) - 1 )  );
  330.         Buf2 := Copy (  Buf2, Pos ('[/QUOTE]', Buf2) + Length ('[/QUOTE]'), ( Length (Buf2) - Pos ('[/FONT]', Buf2) ) +
  331. 1  );
  332.         Buffer := Format ('%s [QUOTE][B]%s[/B] %s[/QUOTE] %s',[Buf1,Author,Buf3,Buf2]);
  333.     end;
  334.     if ( aColor <> clNone ) then
  335.     begin
  336.         Buffer := StrReplace ( Buffer, '[QUOTE]', Format ('[BACKGROUND:#%s][QUOTE]',[ ColorToHex (aColor) ]) );
  337.         Buffer := StrReplace ( Buffer, '[/QUOTE]', '[/QUOTE][/BACKGROUND]' );
  338.     end;
  339.     aBBCode := Buffer;
  340. end;
  341.  
  342. procedure GetLists (var aBBCode: String);
  343. begin
  344.     aBBCode := StrReplace (aBBCode,'[LI]','•  ');
  345.     aBBCode := StrReplace (aBBCode,'[/LI]','');
  346. end;
  347.  
  348. procedure InsertBBCode (anObject: TRichEdit; const aBBCode: String);
  349. var
  350.     Stream     : TStringStream;
  351.     s          : String;
  352.     charset    : String;
  353.     fonts      : String;
  354.     fonttable  : WORD;
  355.     colors     : String;
  356.     backgrouns : String;
  357.     palette    : WORD;
  358. begin
  359.     s := aBBCode;
  360.     s := StrReplace (s,'[li]','[LI]');
  361.     s := StrReplace (s,'[/li]','[/LI]');
  362.     s := StrReplace (s,'[B]','\b ',FALSE);
  363.     s := StrReplace (s,'[/B]','\b0 ',FALSE);
  364.     s := StrReplace (s,'[I]','\i ',FALSE);
  365.     s := StrReplace (s,'[/I]','\i0 ',FALSE);
  366.     s := StrReplace (s,'[U]','\ul ',FALSE);
  367.     s := StrReplace (s,'[/U]','\ulnone ',FALSE);
  368.     s := StrReplace (s,'[S]','\strike ',FALSE);
  369.     s := StrReplace (s,'[/S]','\strike0 ',FALSE);
  370.     s := StrReplace (s,#13#10,'\par ');
  371.     s := StrReplace (s,'[color:#','[COLOR:#');
  372.     s := StrReplace (s,'[/color]','[/COLOR]');
  373.     s := StrReplace (s,'[background:#','[BACKGROUND:#');
  374.     s := StrReplace (s,'[/background]','[/BACKGROUND]');
  375.     s := StrReplace (s,'[font:','[FONT:');
  376.     s := StrReplace (s,'[/font]','[/FONT]');
  377.     s := StrReplace (s,'[size:','[SIZE:');
  378.     s := StrReplace (s,'[/size]','[/SIZE]');
  379.     s := StrReplace (s,'[KEY]','');
  380.     s := StrReplace (s,'[/KEY]','');
  381.     s := StrReplace (s,'[key]','');
  382.     s := StrReplace (s,'[/key]','');
  383.     charset := '';
  384.     if ( anObject.Font.CharSet = RUSSIAN_CHARSET ) then
  385.         charset := '\ansi\ansicpg1251';
  386.     palette := 0;
  387.     colors := GetColors (s,palette,anObject.Font.Color);
  388.     backgrouns := GetBackGrounds (s,palette,anObject.Color);
  389.     fonttable := 0;
  390.     fonts := GetFonts (s,fonttable,anObject.Font);
  391.     GetLists (s);
  392.     Stream := TStringStream.Create ( Format ('{\rtf1'+'%s'+
  393.                                              '{\fonttbl %s}'+
  394.                                              '{\colortbl ;%s%s}'+
  395.                                              '%s}',
  396.                                              [charset,
  397.                                               fonts,
  398.                                               colors,backgrouns,
  399.                                               s]) );
  400.     if Assigned (Stream) then
  401.     try
  402.         PutRTFSelection (anObject,Stream);
  403.     finally
  404.         FreeAndNil (Stream);
  405.     end;
  406. end;
  407.  
  408. procedure InsertBBCode (anObject: TRxRichEdit; const aBBCode: String);
  409. var
  410.     Stream     : TStringStream;
  411.     s          : String;
  412.     charset    : String;
  413.     fonts      : String;
  414.     fonttable  : WORD;
  415.     colors     : String;
  416.     backgrouns : String;
  417.     palette    : WORD;
  418. begin
  419.     s := aBBCode;
  420.     s := StrReplace (s,'[li]','[LI]');
  421.     s := StrReplace (s,'[/li]','[/LI]');
  422.     s := StrReplace (s,'[B]','\b ',FALSE);
  423.     s := StrReplace (s,'[/B]','\b0 ',FALSE);
  424.     s := StrReplace (s,'[I]','\i ',FALSE);
  425.     s := StrReplace (s,'[/I]','\i0 ',FALSE);
  426.     s := StrReplace (s,'[U]','\ul ',FALSE);
  427.     s := StrReplace (s,'[/U]','\ulnone ',FALSE);
  428.     s := StrReplace (s,'[S]','\strike ',FALSE);
  429.     s := StrReplace (s,'[/S]','\strike0 ',FALSE);
  430.     s := StrReplace (s,#13#10,'\par ');
  431.     s := StrReplace (s,'[color:#','[COLOR:#');
  432.     s := StrReplace (s,'[/color]','[/COLOR]');
  433.     s := StrReplace (s,'[background:#','[BACKGROUND:#');
  434.     s := StrReplace (s,'[/background]','[/BACKGROUND]');
  435.     s := StrReplace (s,'[font:','[FONT:');
  436.     s := StrReplace (s,'[/font]','[/FONT]');
  437.     s := StrReplace (s,'[size:','[SIZE:');
  438.     s := StrReplace (s,'[/size]','[/SIZE]');
  439.     s := StrReplace (s,'[KEY]','');
  440.     s := StrReplace (s,'[/KEY]','');
  441.     s := StrReplace (s,'[key]','');
  442.     s := StrReplace (s,'[/key]','');
  443.     charset := '';
  444.     if ( anObject.Font.CharSet = RUSSIAN_CHARSET ) then
  445.         charset := '\ansi\ansicpg1251';
  446.     palette := 0;
  447.     colors := GetColors (s,palette,anObject.Font.Color);
  448.     backgrouns := GetBackGrounds (s,palette,anObject.Color);
  449.     fonttable := 0;
  450.     fonts := GetFonts (s,fonttable,anObject.Font);
  451.     GetLists (s);
  452.     Stream := TStringStream.Create ( Format ('{\rtf1'+'%s'+
  453.                                              '{\fonttbl %s}'+
  454.                                              '{\colortbl ;%s%s}'+
  455.                                              '%s}',
  456.                                              [charset,
  457.                                               fonts,
  458.                                               colors,backgrouns,
  459.                                               s]) );
  460.     if Assigned (Stream) then
  461.     try
  462.         PutRTFSelection (anObject,Stream);
  463.     finally
  464.         FreeAndNil (Stream);
  465.     end;
  466. end;
  467.  
  468. function BitMapToRTF (const aValue: TBitMap) : String;
  469. var
  470.     Header, Image         : String;
  471.     HeaderSize, ImageSize : Cardinal;
  472.     S                     : ShortString;
  473.     HEX                   : String;
  474.     I                     : Integer;
  475. begin
  476.     try
  477.         GetDIBSizes (aValue.Handle, HeaderSize, ImageSize);
  478.         SetLength (Header, HeaderSize);
  479.         SetLength (Image, ImageSize);
  480.         GetDIB ( aValue.Handle, aValue.Palette, PChar (Header)^, PChar (Image)^ );
  481.         Result := '{\rtf1 {\pict\dibitmap ';
  482.         SetLength (  HEX, ( Length (Header) + Length (Image) ) * 2  );
  483.         I := 2;
  484.         for HeaderSize := 1 to Length (Header) do
  485.         begin
  486.             s := Format ('%x',[ Integer ( Header [HeaderSize] ) ]);
  487.             if Length (s) = 1 then
  488.                 s := '0' + s;
  489.             HEX [I-1] := s [1];
  490.             HEX [I] := s [2];
  491.             Inc (I,2);
  492.         end;
  493.         for ImageSize := 1 to Length (Image) do
  494.         begin
  495.             s := Format ('%x',[ Integer (Image [ImageSize]) ]);
  496.             if Length (s) = 1 then
  497.                 s := '0' + s;
  498.             HEX [I-1] := s [1];
  499.             HEX [I] := s [2];
  500.             Inc (I,2);
  501.         end;
  502.         Result := Result + HEX + ' }}';
  503.     except on E: Exception do
  504.         raise Exception.CreateFmt ('%s#13#10%s',[ERR_BBCODE_BMP,E.Message]);
  505.     end;
  506. end;
  507.  
  508. procedure InsertBitMap (anObject: TRxRichEdit; aBitMap: TBitMap);
  509. var
  510.     Stream : TStringStream;
  511. begin
  512.     Stream := TStringStream.Create ( BitMapToRTF (aBitMap) );
  513.     if Assigned (Stream) then
  514.     try
  515.         PutRTFSelection (anObject,Stream);
  516.     finally
  517.         if Assigned (Stream) then
  518.             FreeAndNil (Stream);
  519.     end;
  520. end;
  521.  
  522. function StrToBitMap (anObject: TRxRichEdit; aStr: String; aBitMap: TBitMap) : Integer;
  523. var
  524.     FindPos    : LongInt;
  525.     CurrentPos : LongInt;
  526. begin
  527.     if Assigned (anObject) then
  528.     with anObject do
  529.     repeat
  530.         FindPos := FindText ( aStr, 0, Length (Text),[] );
  531.         if ( FindPos >= 0 ) then
  532.         begin
  533.             Lines.BeginUpdate;
  534.             SelStart := FindPos;
  535.             SelLength := Length (aStr);
  536.             SelText := '';
  537.             CurrentPos := FindPos;
  538.             InsertBitMap (anObject,aBitMap);
  539.             SelStart := CurrentPos;
  540.             Lines.EndUpdate;
  541.         end;
  542.     until ( FindPos < 0 );
  543. end;
  544.  
  545. procedure InsertSmiles (anObject: TRxRichEdit;
  546.                         const aSMILES: array of String;
  547.                         anIcons : TsAlphaImageList;
  548.                         aBackColor: TColor = clNone);
  549. var
  550.     Bmp  : TBitMap;
  551.     Rect : TRect;
  552.     I    : Integer;
  553. begin
  554.     try
  555.         if Assigned (anObject) and Assigned (anIcons) then
  556.         begin
  557.             Bmp := TBitmap.Create;
  558.             try
  559.                 Rect.Left := 0;
  560.                 Rect.Top := 0;
  561.                 Rect.Right := anIcons.Width;
  562.                 Rect.Bottom := anIcons.Height;
  563.                 for I := 0 to High (aSMILES) do
  564.                 begin
  565.                     if ( I <= anIcons.Count -1 ) and anIcons.GetBitmap32 (I,Bmp) then
  566.                     begin
  567.                         if ( aBackColor = clNone ) then
  568.                         begin
  569.                             Bmp.Canvas.Brush.Color := anObject.Color;
  570.                             Bmp.Canvas.Pen.Color := anObject.Color;
  571.                         end
  572.                         else
  573.                         begin
  574.                             Bmp.Canvas.Brush.Color := aBackColor;
  575.                             Bmp.Canvas.Pen.Color := aBackColor;
  576.                         end;
  577.                         Bmp.Canvas.FillRect (Rect);
  578.                         anIcons.Draw (Bmp.Canvas,0,0,I,dsTransparent,itImage);
  579.                         StrToBitMap ( anObject, aSMILES [I], Bmp );
  580.                     end;
  581.                 end;
  582.             finally
  583.                 FreeAndNil (Bmp);
  584.             end;
  585.         end;
  586.     except on E: Exception do
  587.         raise Exception.CreateFmt ('%s'#13#10'%s',[ERR_SMILES_INSERT,E.Message])
  588.     end;
  589. end;
  590.  
  591. procedure InsertQuotes (anObject: TRxRichEdit;
  592.                         anIcons : TsAlphaImageList;
  593.                         aBackColor: TColor = clNone);
  594. begin
  595.     InsertSmiles (anObject,QUOTES,anIcons,aBackColor);
  596. end;
  597.  
  598. procedure GetTagWords (const aBBCode: String;
  599.                        const aTagOpen: String;
  600.                        const aTagClose: String;
  601.                        out aWords: TStringList);
  602. var
  603.     Buf1  : String;
  604.     Buf2  : String;
  605.     Buf3  : String;
  606.     lst   : TStringList;
  607.     I     : Integer;
  608.     Index : Integer;
  609. begin
  610.     if not Assigned (aWords) then
  611.         raise Exception.CreateFmt (ERR_BBCODE_NOT_INITIALIZE_OBJECT,
  612.                                    [TStringList.ClassName]);
  613.     Buf1 := '';
  614.     Buf2 := aBBCode;
  615.     Buf3 := '';
  616.     // разбираем
  617.     while ( Pos (aTagOpen,Buf2) > 0 ) do
  618.     begin
  619.         Buf2 := Copy (  Buf2, Pos (aTagOpen, Buf2), ( Length (Buf2) - Pos (aTagOpen, Buf2) ) + 1  );
  620.         Buf1 := Copy  ( aBBCode, 1, Length (aBBCode) - Length (Buf2) );
  621.         Delete ( Buf2, Pos (aTagOpen, Buf2), Length (aTagOpen) );
  622.         Buf3 := Copy (  Buf2, 1, ( Pos (aTagClose, Buf2) - 1 )  );
  623.         Buf2 := Copy (  Buf2, Pos (aTagClose, Buf2) + Length (aTagClose), ( Length (Buf2) - Pos (aTagClose, Buf2) ) + 1 
  624. );
  625.         Buf3 := Trim (Buf3);
  626.         lst := TStringList.Create;
  627.         try
  628.             lst.CommaText := Buf3;
  629.             for I := 0 to lst.Count - 1 do
  630.                 if notEmpty (lst [I]) and not aWords.Find (lst [I],Index) then
  631.                     aWords.Add (lst [I]);
  632.         finally
  633.             FreeAndNil (lst);
  634.         end;
  635.     end;
  636. end;
  637.  
  638. procedure GetBoldWords (const aBBCode: String;
  639.                         out aWords: TStringList);
  640. begin
  641.     GetTagWords (aBBCode,'[B]','[/B]',aWords);
  642. end;
  643.  
  644. procedure GetItalicWords (const aBBCode: String;
  645.                           out aWords: TStringList);
  646. begin
  647.     GetTagWords (aBBCode,'[I]','[/I]',aWords);
  648. end;
  649.  
  650. procedure GetUnderlineWords (const aBBCode: String;
  651.                              out aWords: TStringList);
  652. begin
  653.     GetTagWords (aBBCode,'[U]','[/U]',aWords);
  654. end;
  655.  
  656. procedure GetKeyWords (const aBBCode: String;
  657.                        out aWords: TStringList);
  658. begin
  659.     GetTagWords (aBBCode,'[KEY]','[/KEY]',aWords);
  660. end;
  661.  
  662.  
  663. end.

Ссылка на данный код:

На главную страницу сервиса обмена кодом »