}

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'' не ини'%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. //ue%d;',[R,G,B]);
  186. Inc (aPallete);
  187. // разбираем палитру
  188. while ( Pos ('[COLOR:#',Buf2) > 0 ) do
  189. begin
  190. Buf2 :=
  191. Inc (aPallete);
  192. //#', Buf2), ( Length (Buf2) - Pos ('[COLOR:#', Buf2) ) + 1 );
  193. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  194. color := Copy ( Buf2, Pos ('[COLOR:
  195. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  196. color := Copy ( Buf2, Pos ('[COLOR:#', Buf2) + Length ('[COLOR:#'), Length ('RRGGBB') );
  197. R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
  198. G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
  199. B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
  200. Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
  201. Inc (aPallete);
  202. Delete ( Buf2, Pos ('[COLOR:#', Buf2), Length ('[COLOR:#RRGGBB]') );
  203. Buf3 := Copy ( Buf2, 1, ( Pos ('[/COLOR]', Buf2) - 1 ) );
  204. Buf2 := Copy ( Buf2, Pos ('[/COLOR]', Buf2) + Length ('[/COLOR]'%s\cf%d %s\cf1 %s',[Buf1,aPallete,Buf3,Buf2]);
  205. end;
  206. Buffer := Format ('\cf1 %s\cf1',[Buffer]);
  207. aBBCode := Buffer;
  208. end;
  209.  
  210. function GetBackgrounds (var aBB,[Buf1,aPallete,Buf3,Buf2]);
  211. end;
  212. Buffer := Format ('\cf1 %s\cf1',[Buffer]);
  213. aBBCode := Buffer;
  214. end;
  215.  
  216. function GetBackgrounds (var aBBCode: String; var aPallete: WORD;
  217. const aColor: TColor = clWhite) : String;
  218. var
  219. Buf1 : String;
  220. Buf2 : String;
  221. Buf3 : String;
  222. Buffer : String;
  223. color : String;
  224. R : Byte;
  225. G : Byte;
  226. B : Byte;
  227. begin
  228. Result := '';
  229. Buf1 := '';
  230. Buf2 := aBBCode;
  231. Buf3 := '';
  232. Buffer := aBBCode;
  233. R := 0;
  234. G := 0;
  235. B := 0;
  236. // ('[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 (Buf
  240. begin
  241. Buf2 := Copy ( Buf2, Pos ('[BACKGROUND:#'[BACKGROUND:#', Buf2) + Length ('[BACKGROUND:#'), Length ('RRGGBB') );
  242. R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
  243. G := StrToInt ( Format ('$%s',[Copy (color,3,2, Buf2) + Length ('[BACKGROUND:#'), Length ('RRGGBB') );
  244. R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
  245. G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
  246. B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
  247. Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
  248. Inc (aPallete);
  249. Delete ( Buf2, Pos ('[BACKGROUND:#', Buf2), Length ('[BACKGROUND:#RRGGBB]') );
  250. Buf3 := Copy ( Buf2, 1, ( Pos ('[/BACKGROUND]', Buf2) - 1 ) );
  251. Buf2 := Copy ( Buf2, Pos ('[/BACKGROUND]', Buf2) + Length ('[/BACKGROUND]'), ( Length (Buf2) - Pos
  252. ('[/BACKGROUND]', Buf2) ) + 1 );
  253. //ode: String; var aFontNumber: WORD;
  254. const aFont: TFont) : String;
  255. var
  256. Buf1 : String;
  257. Buf2 : String;
  258. Buf3 : String;
  259. Buffer : String;
  260. font : String;
  261. size : String;
  262. begin
  263. Res
  264. const aFont: TFont) : String;
  265. var
  266. Buf1 : String;
  267. Buf2 : String;
  268. Buf3 : String;
  269. Buffer : String;
  270. font : String;
  271. size : String;
  272. begin
  273. Result := '';
  274. Buf1 := '';
  275. Buf2 := aBBCode;
  276. Buf3 := '';
  277. Buffer := aBBCode;
  278. //Copy ( Buf2, Pos ('[FONT:', Buf2), ( Length (Buf2) - Pos ('[FONT:', Buf2) ) + 1 );
  279. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  280. font := Copy ( Buf2, Pos ('[FONT:', Buf2) + Length ('[FONT:'),
  281. Pos (']', Buf2) - Pos ('[FONT:', Buf2) -
  282. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  283. font := Copy ( Buf2, Pos ('[FONT:', Buf2) + Length ('[FONT:'),
  284. Pos (']',[font]) ) );
  285. Buf3 := Copy ( Buf2, 1, ( Pos ('[/FONT]', Buf2) - 1 ) );
  286. Buf2 := Copy ( Buf2, Pos ('[/FONT]', Buf2) + Length ('[/FONT]'), ( Length (Buf2) - Pos ('[/FONT]', Buf2) ) + 1
  287. );
  288. Buffer := Format ('%s\f%d %s\f0 %s',[Buf1,aFontNumber,B[/FONT]', Buf2) - 1 ) );
  289. Buf2 := Copy ( Buf2, Pos ('[/FONT]', Buf2) + Length ('\fs%d %s',[aFont.Size*2,Buffer]);
  290. // разбираем размеры
  291. while ( Pos ('[SIZE:',Buf2) > 0 ) do
  292. begin
  293. Buf2 := Copy ( Buf2, Pos ('[SIZE:', Buf2), ( Length (Buf2) - Pos ('[SIZE:', Buf2) ) + 1 );
  294. Buf1 := Copy ( Buffer, 1, Leng,[aFont.Size*2,Buffer]);
  295. // size := Copy ( Buf2, Pos ('[SIZE:', Buf2) + Length ('[SIZE:'),
  296. Pos (']', Buf2) - Pos ('[SIZE:', Buf2) - Length ('[SIZE:') );
  297. Delete ( Buf2, Pos ('[SIZE:', Buf2), Length ( Format ('[SIZE:%s]',[s
  298. size := Copy ( Buf2, Pos ('[SIZE:', Buf2) + Length ('[SIZE:'),
  299. Pos (']', Buf2) - Pos ('[SIZE:', Buf2) - Length ('[SIZE:') );
  300. Delete ( Buf2, Pos ('[SIZE:', Buf2), Length ( Format ('[SIZE:%s]',[size]) ) );
  301. Buf3 := Copy ( Buf2, 1, ( Pos ('[/SIZE]', Buf2) - 1 ) );
  302. Buf2 := Copy ( Buf2, Pos ('[/SIZE]', Buf2) + Length ('[/SIZE]'), ( Length (Buf2) - Pos ('[/SIZE]', Buf2) ) + 1
  303. );
  304. Buffer := Format ('%s\fs%d %s\fs%d %s',[ Buf1, StrToInt (Trim(size))*2, Buf3, aFont.Size*2, Buf2 ]);
  305. end;
  306. aBBCode := Buffer;
  307. end;
  308.  
  309. procedure MarkQuotes (var aBBCode: String; const aColor: TColor = clNone);
  310. var
  311. Buf1 : String;
  312. Buf2 : String;
  313. Buf3 : String;
  314. Buffer : String;
  315. Author : String;
  316. begin
  317. aBBCode := StrReplace (aBBCode,'[quote',', Buf2), ( Length (Buf2) - Pos ('[QUOTE:', Buf2) ) + 1 );
  318. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  319. Author := Copy ( Buf2, Pos ('[QUOTE:', Buf2) + Length ('[QUOTE:'),
  320. Pos (']', Buf2) - Pos ('[QUOTE:', Buf[QUOTE:', Buf2) ) + 1 );
  321. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  322. Author := Copy ( Buf2, Pos ('[QUOTE:', Buf2) + Length ('[QUOTE:', Buf2) - 1 ) );
  323. Buf2 := Copy ( Buf2, Pos ('[/QUOTE]', Buf2) + Length ('[/QUOTE]'), ( Length (Buf2) - Pos ('[/FONT]', Buf2) ) +
  324. 1 );
  325. Buffer := Format ('%s [QUOTE][B]%s[/B] %s[/QUOTE] %s',[Buf1,Author,Buf3,Buf2]);
  326. end;
  327. if ( aColor <> clNone ) then
  328. begin
  329. Buf[/QUOTE]', Buf2) + Length ('[/QUOTE]', Format ('[BACKGROUND:#%s][QUOTE]',[ ColorToHex (aColor) ]) );
  330. Buffer := StrReplace ( Buffer, '[/QUOTE]', '[/QUOTE][/BACKGROUND]' );
  331. end;
  332. aBBCode := Buffer;
  333. end;
  334.  
  335. procedure GetLists (var aBBCode: String);
  336. begin
  337. aBBCode := StrReplac[BACKGROUND:#%s][QUOTE]',[ ColorToHex (aColor) ]) );
  338. Buffer := StrReplace ( Buffer, '[/QUOTE]', '[/QUOTE][/BACKGROUND]' );
  339. end;
  340. aBBCode := Buffer;
  341. end;
  342.  
  343. procedure GetLists (var aBBCode: String);
  344. begin
  345. aBBCode := StrReplace (aBBCode,'[LI]','• ');
  346. aBBCode := StrReplace (aBBCode,'[/LI]','');
  347. end;
  348.  
  349. procedure InsertBBCode (anObject: TRichEdit; const aBBCode: String);
  350. var
  351. Stream : TStringStream;
  352. s : String;
  353. charset : String;
  354. fonts : String;
  355. fonttable : WORD;
  356. colors : String;
  357. backgrouns : String;
  358. palette : WORD;
  359. begin
  360. s := aBBCode;
  361. s := StrReplace (s,'[li]','[LI]');
  362. s := StrReplace (s,'[/li]','[/LI]');
  363. s := StrReplace (s,'[B]','\b ',FALSE);
  364. s := StrReplace (s,',FALSE);
  365. s := StrReplace (s,'[/S]','\strike0 ',FALSE);
  366. s := StrReplace (s,#13#10,'\par ');
  367. s := StrReplace (s,'[color:#','[COLOR:#');
  368. s := StrReplace (s,'[/color]','[/COLOR]');
  369. s := StrReplace (s,'[background:#','[BACKGROUND:#');
  370. s := StrReplace (s,'[/background]','[/BACKGROUND]');
  371. s := StrReplace (s,'[font:','[FONT:');
  372. s := StrReplace (s,'[/font]','[/FONT]');
  373. s := StrReplace (s,'[size:','[SIZE:');
  374. s := StrReplace (s,'[/size]','[/SIZE]');
  375. s := StrReplace (s,'[KEY]','');
  376. s := ','[/BACKGROUND]');
  377. s := StrReplace (s,'[font:','[FONT:'');
  378. s := StrReplace (s,'[/key]','');
  379. charset := '';
  380. if ( anObject.Font.CharSet = RUSSIAN_CHARSET ) then
  381. charset := '\ansi\ansicpg1251';
  382. palette := 0;
  383. colors := GetColors (s,palette,anObject.Font.Color);
  384. backgr');
  385. s := StrReplace (s,'[/key]','');
  386. charset := '';
  387. if ( anObject.Font.CharSet = RUSSIAN_CHARSET ) then
  388. charset := '\ansi\ansicpg1251';
  389. palette := 0;
  390. colors := GetColors (s,palette,anObject.Font.Color);
  391. backgrouns := GetBackGrounds (s,palette,anObject.Color);
  392. fonttable := 0;
  393. fonts := GetFonts (s,fonttable,anObject.Font);
  394. GetLists (s);
  395. Stream := TStringStream.Create ( Format ('{arset,
  396.   fonts,
  397.   colors,backgrouns,
  398.   s]) );
  399.   if Assigned (Stream) then
  400.   try
  401.   PutRTFSelection (anObject,Stream);
  402.   finally
  403.   FreeAndNil (Stream);
  404.   end;
  405. end;
  406.  
  407. procedure InsertBBCode (anObject: TRxRichEdit; const aBBCode: String);
  408. var
  409.   Stream : TStringStream;
  410.   s : String;
  411.   charset : String;
  412.   fonts : String;
  413.   fonttable : WORD;
  414.   colors : String;
  415.   backgrouns : String;
  416.   palette : WORD;
  417. begin
  418.   s := aBBCode;
  419.   s := StrReplace (s,'[li]','[LI]');
  420.   s := StrReplace (s,'[/li]','[/LI]');
  421.   s := StrReplace (s,'[B]','\b ',FALSE);
  422.   s := StrReplace (s,'[/B]','\b0 ',FALSE);
  423.   s := StrReplace (s,'[I]','\i ',FALSE);
  424.   s := StrReplace (s,'[/I]','\i0 ',FALSE);
  425.   s := StrReplace (s,'[U]','\ul ',FALSE);
  426.   s := StrReplace (s,'[/U]','\ulnone ',FALSE);
  427.   s := StrReplace (s,'[S]','\strike ',FALSE);
  428.   s := StrReplace (s,'[/S]','\strike0 ',FALSE);
  429.   s := StrReplace (s,#13#10,'\par ');
  430.   s := StrReplace (s,'[color:#','[COLOR:#');
  431.   s := StrReplace (s,'[/color]','[/COLOR]');
  432.   s := StrReplace (s,'[background:#','[BACKGROUND:#');
  433.   s := StrReplace (s,'[/background]','[/BACKGROUND]');
  434.   s := StrReplace (s,'[font:','[FONT:');
  435.   s := StrReplace (s,'[/font]','[/FONT]');
  436.   s := StrReplace (s,'[size:','[SIZE:');
  437.   s := StrReplace (s,'[/size]','[/SIZE]');
  438.   s := StrReplace (s,'[KEY]','');
  439.   s := StrReplace (s,'[/KEY]','');
  440.   s := StrReplace (s,'[key]','');
  441.   s := StrReplace (s,'[/key]','');
  442.   charset := '';
  443.   if ( anObject.Font.CharSet = RUSSIAN_CHARSET ) then
  444.   charset := '\ansi\ansicpg1251';
  445.   palette := 0;
  446.   colors := GetColors (s,palette,anObject.Font.Color);
  447.   backgrouns := GetBackGrounds (s,palette,anObject.Color);
  448.   fonttable := 0;
  449.   fonts := GetFonts (s,fonttable,anObject.Font);
  450.   GetLists (s);
  451.   Stream := TStringStream.Create ( Format ('{\rtf1'+'%s'+
  452.   '{\fonttbl %s}'+
  453.   '{\colortbl ;%s%s}'+
  454.   '%s}',
  455.   [charset,
  456.   fonts,
  457.   }'+
  458. '{s,
  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}}';
  513. except on E: Exception do
  514. raise Exception.CreateFmt ('%s#13#10%s',[ERR_BBCODE_BMP,E.Message]);
  515. end;
  516. end;
  517.  
  518. procedure InsertBitMap (anObject: TRxRichEdit; aBitMap: TBitMap);
  519. var
  520. Stream : TStringStream;
  521. begin
  522. Stream := TStringStream.Create ( BitMapToRTF (aBitMap) );
  523. if Assigned (Stream) then
  524. try
  525. PutRTFSelection (anObject,Stream);
  526. finally
  527. if Assigned (Stream) then
  528. FreeAndNil (Stream);
  529. end;
  530. end;
  531.  
  532. function StrToBitMap (anObject: TRxRichEdit; aStr: String; aBitMap: TBitMap) : Integer;
  533. var
  534. FindPos : LongInt;
  535. CurrentPos : LongInt;
  536. begin
  537. if Assigned (anObject) then
  538. with anObject do
  539. repeat
  540. FindPos := FindText ( aStr, 0, Length (Text),[] );
  541. if ( FindPos >= 0 ) then
  542. begin
  543. Lines.BeginUpdate;
  544. SelStart := FindPos;
  545. SelLength := Length (aStr);
  546. SelText := '';
  547. CurrentPos := FindPos;
  548. InsertBitMap (anObject,aBitMap);
  549. SelStart := CurrentPos;
  550. Lines.EndUpdate;
  551. end;
  552. until ( FindPos < 0 );
  553. end;
  554.  
  555. procedure InsertSmiles (anObject: TRxRichEdit;
  556. const aSMILES: array of String;
  557. anIcons : TsAlphaImageList;
  558. aBackColor: TColor = clNone);
  559. var
  560. Bmp : TBitMap;
  561. Rect : TRect;
  562. I : Integer;
  563. begin
  564. try
  565. if Assigned (anObject) and Assigned (anIcons) then
  566. begin
  567. Bmp := TBitmap.Create;
  568. try
  569. Rect.Left := 0;
  570. Rect.Top := 0;
  571. Rect.Right := anIcons.Width;
  572. Rect.Bottom := anIcons.Height;
  573. for I := 0 to High (aSMILES) do
  574. begin
  575. if ( I <= anIcons.Count -1 ) and anIcons.GetBitmap32 (I,Bmp) then
  576. begin
  577. if ( aBackColor = clNone ) then
  578. begin
  579. Bmp.Canvas.Brush.Color := anObject.Color;
  580. Bmp.Canvas.Pen.Color := anObject.Color;
  581. end
  582. else
  583. begin
  584. Bmp.Canvas.Brush.Color := aBackColor;
  585. Bmp.Canvas.Pen.Color := aBackColor;
  586. end;
  587. Bmp.Canvas.FillRect (Rect);
  588. anIcons.Draw (Bmp.Canvas,0,0,I,dsTransparent,itImage);
  589. StrToBitMap ( anObject, aSMILES [I], Bmp );
  590. end;
  591. end;
  592. finally
  593. FreeAndNil (Bmp);
  594. end;
  595. end;
  596. except on E: Exception do
  597. raise Exception.CreateFmt ('%s'#13#10'%s',[ERR_SMILES_INSERT,E.Message])
  598. end;
  599. end;
  600.  
  601. procedure InsertQuotes (anObject: TRxRichEdit;
  602. anIcons : TsAlphaImageList;
  603. aBackColor: TColor = clNone);
  604. begin
  605. InsertSmiles (anObject,QUOTES,anIcons,aBackColor);
  606. end;
  607.  
  608. procedure GetTagWords (const aBBCode: String;
  609. const aTagOpen: String;
  610. const aTagClose: String;
  611. out aWords: TStringList);
  612. var
  613. Buf1 : String;
  614. Buf2 : String;
  615. Buf3 : String;
  616. lst : TStringList;
  617. I : Integer;
  618. Index : Integer;
  619. begin
  620. if not Assigned (aWords) then
  621. raise Exception.CreateFmt (ERR_BBCODE_NOT_INITIALIZE_OBJECT,
  622. [TStringList.ClassName]);
  623. Buf1 := '';
  624. Buf2 := aBBCode;
  625. Buf3 := '';
  626. //e ( Buf2, Pos (aTagOpen, Buf2), Length (aTagOpen) );
  627. Buf3 := Copy ( Buf2, 1, ( Pos (aTagClose, Buf2) - 1 ) );
  628. Buf2 := Copy ( Buf2, Pos (aTagClose, Buf2) + Length (aTagClose), ( Length (Buf2) - Pos (aTagClose, Buf2) ) + 1
  629. );
  630. Buf3 := Trim (Buf3);
  631. lst := TStringList
  632.  
  633. Buf3 := Copy ( Buf2, 1, ( Pos (aTagClose, Buf2) - 1 ) );
  634. Buf2 := Copy ( Buf2, Pos (aTagClose, Buf2) + Length (aTagClose), ( Length (Buf2) - Pos (aTagClose, Buf2) ) + 1
  635. );
  636. Buf3 := Trim (Buf3);
  637. lst := TStringList.Create;
  638. try
  639. lst.CommaText := Buf3;
  640. for I := 0 to lst.Count - 1 do
  641. if notEmpty (lst [I]) and not aWords.Find (lst [I],Index) then
  642. aWords.Add (lst [I]);
  643. finally
  644. FreeAndNil (lst);
  645. end;
  646. end;
  647. end;
  648.  
  649. procedure GetBoldWords (const aBBCode: String;
  650. out aWords: TStringList);
  651. begin
  652. GetTagWords (aBBCode,'[B]','[/B]',aWords);
  653. end;
  654.  
  655. procedure GetItalicWords (const aBBCode: String;
  656. out aWords: TStringList);
  657. begin
  658. GetTagWords (aBBCode,'[I]','[/I]',aWords);
  659. end;
  660.  
  661. procedure GetUnderlineWords (const aBBCode: String;
  662. out aWo

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

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