}

Delphi.int.ru — Портал программистов

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

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

Идентификатор: 8f8ddb58 Описание: BB Code delphi unit Код загружен: 10 июня 2011, 10:18 (mirt.steelwater)

  1. unit BBCode;
  2. {******************************************************************************}
  3. {* BB Code Unit *}
  4. {* Do not use this unit in commercial projects *}
  5. {* Revolutionary Confederation of Anarcho Syndicalists *}
  6. {* Written by: black.rabbit 2010 *}
  7. {******************************************************************************}
  8. interface
  9.  
  10. uses
  11. Windows, SysUtils, Classes,
  12. ComCtrls, RichEdit;
  13.  
  14. procedure InsertBBCode (anObject: TRichEdit; const aBBCode: String);
  15.  
  16. implementation
  17.  
  18. type
  19. TEditStreamCallBack = function (dwCookie: LongInt;
  20. pbBuff: PByte;
  21. cb: LongInt;
  22. var pcb: LongInt) : DWORD; stdcall;
  23. TEditStreamData = packed record
  24. dwCookie : LongInt;
  25. dwError : LongInt;
  26. pfnCallback : TEditStreamCallBack;
  27. end;
  28.  
  29. function EditStreamInCallback (dwCookie: Longint;
  30. pbBuff: PByte;
  31. cb: Longint;
  32. var pcb: Longint) : DWORD; stdcall;
  33. var
  34. Stream : TStream;
  35. dataAvail : LongInt;
  36. begin
  37. Result := UINT (E_FAIL);
  38. try
  39. Stream := TStream (dwCookie);
  40. if Assigned (Stream) then
  41. with Stream do
  42. begin
  43. dataAvail := Size - Position;
  44. Result := 0;
  45. if ( dataAvail <= cb ) then
  46. begin
  47. pcb := Read (pbBuff^,dataAvail);
  48. if ( pcb <> dataAvail ) then
  49. Result := UINT (E_FAIL);
  50. end
  51. else
  52. begin
  53. pcb := Read (pbBuff^,cb);
  54. if ( pcb <> cb ) then
  55. Result := UINT (E_FAIL);
  56. end;
  57. end;
  58. except
  59. Result := UINT (E_FAIL);
  60. end;
  61. end;
  62.  
  63. procedure PutRTFSelection (anObject: TRichEdit; aSourceStream: TStream);
  64. var
  65. Data : TEditStreamData;
  66. begin
  67. try
  68. if ( not Assigned (anObject) ) then
  69. raise Exception.CreateFmt ('Объект класса ''%s'' не ини'%s'' не инициализирован!',
  70. [anObject.ClassName]);
  71. with Data do
  72. begin
  73. dwCookie := LongInt (aSourceStream);
  74. dwError := 0;
  75. pfnCallback := EditStreamInCallBack;
  76. end;
  77. anObject.Perform ( EM_STREAMIN, SF_RTF or SFF_SELECTION, LongInt (@Data) );
  78. except on E: Exception do
  79. raise Exception.CreateFmt (',
  80. [E.Message]);
  81. end;
  82. end;
  83.  
  84. function StrReplace (const Source, Search, Replace: String) : String;
  85. var
  86. Buf1 : String;
  87. Buf2 : String;
  88. Buffer : String;
  89. begin
  90. Result := Source;
  91. Buf1 := '';
  92. Buf2 := Source;
  93. Buffer ';
  94. Buf2 := Source;
  95. Buffer := Source;
  96. while ( Pos (Search, Buf2) > 0 ) do
  97. begin
  98. Buf2 := Copy ( Buf2, Pos (Search, Buf2), ( Length (Buf2) - Pos (Search, Buf2) ) + 1 );
  99. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) ) + Replace;
  100. Delete ( Buf2, Pos (Search, Buf2), Length (Search) );
  101. Buffer := Buf1 + Buf2;
  102. end;
  103. Result := Buffer;
  104. end;
  105.  
  106. function GetColors (var aBBCode: String; var aPallete: WORD) : String;
  107. var
  108. Buf1 : String;
  109. Buf2 : String;
  110. Buf3 : String;
  111. Buffer : String;
  112. color : String;
  113. R : Byte;
  114. G : Byte;
  115. B : Byte;
  116. begin
  117. Result := '';
  118. Buf1 := '';
  119. Buf2 := aBBCode;
  120. Buf3 := '';
  121. Buffer := aBBCode;
  122. R := 0;
  123. G := 0;
  124. B := 0;
  125. while ( Pos ('[COLOR:#',Buf2) > 0 ) do
  126. begin
  127. Buf2 := Copy ( Buf2, Pos ('[COLOR:#', Buf2), ( Length (Buf2) - Pos ('[COLOR:#', Buf2) ) + 1 );
  128. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  129. color := Copy ( Buf2, Pos ('[COLOR:#', Buf2) + Length ('[COLOR:#'), Length ('RRGGBB') );
  130. R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
  131. G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
  132. B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
  133. Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
  134. Inc (aPallete);
  135. Delete ( Buf2, Pos ('[COLOR:#') );
  136. Buf3 := Copy ( Buf2, 1, ( Pos ('[/COLOR]', Buf2) - 1 ) );
  137. [/COLOR]', Buf2) - 1 ) );
  138. Buf2 := Copy ( Buf2, Pos ('[/COLOR]', Buf2) + Length ('[/COLOR]'), ( Length (Buf2) - Pos ('[/COLOR]', Buf2) ) +
  139. 1 );
  140. Buffer := Format ('%s\cf%d %s\cf0 %s',[Buf1,aPallete,Buf3,Buf2]);
  141. end;
  142. aBBCode := Buffer;
  143. end;
  144.  
  145. function GetBackgrounds (var aBBCode: String; var aPallete: WORD) : String;
  146. var
  147. Buf1 : String;
  148. Buf2 : String;
  149. Buf3 : String;
  150. Buffer : String;
  151. color : String;
  152. R : Byte;
  153. G : Byte;
  154. B : Byte;
  155. begin
  156. Result := '';
  157. Buf1 := '';
  158. Buf2 := aBBCode;
  159. Buf3 := '';
  160. Buffer := aBBCode;
  161. R := 0;
  162. G := 0;
  163. B := 0;
  164. while ( Pos ('[BACKGROUND:#',Buf2) > 0 ) do
  165. begin
  166. Buf2 := Copy ( Buf2, Pos ('[BACKGROUND:#', Buf2), ( Length (Buf2) - Pos ('[BACKGROUND:#', Buf2) ) + 1 );
  167. Buf1 := Copy ( Buffer, 1, Length (Buffer) - Length (Buf2) );
  168. color := Copy ( Buf2, Pos ('[BACKGROUND:#', Buf2) + Length ('[BACKGROUND:#'), Length ('RRGGBB') );
  169. R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
  170. G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
  171. B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
  172. Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
  173. Inc (aPallete);
  174. Delete ( Buf2, Pos ('[BACKGROUND:#', Buf2), Length ('[BACKGROUND:#RRGGBB]') );
  175. Buf3 := Copy ( Buf2, 1, ( Pos ('[/BACKGROUND]', Buf2) - 1 ) );
  176. Buf2 := Copy ( Buf2, Pos ('[/BACKGROUND]', Buf2) + Length ('[/BACKGROUND]'), ( Length (Buf2) - Pos
  177. ('[/BACKGROUND]', Buf2) ) + 1 );
  178. Buffer := Format ('%s\highlight%d %s\highlight0 %s',[Buf1,aPallete,Buf3,Buf2]);
  179. end;
  180. aBBCode := Buffer;
  181. end;
  182.  
  183. procedure InsertBBCode (anObject: TRichEdit; const aBBCode: String);
  184. var
  185. Stream : TStringStream;
  186. s : String;
  187. colors : String;
  188. backgrouns : String;
  189. palette : WORD;
  190. begin
  191. s := aBBCode;
  192. s := StrReplace (s,'[B]','\b '\b0');
  193. s := StrReplace (s,'[I]','\);
  194. s := StrReplace (s,'[I]','\i '\i0');
  195. s := StrReplace (s,'[U]','\);
  196. s := StrReplace (s,'[U]'[/U]','\ulnone');
  197. s := StrReplace (,'\ulnone');
  198. s := StrReplace (s,'[S]','\strike '\strike0');
  199. s := StrReplace (s,#13#10,');
  200. s := StrReplace (s,#13#10,'\par ');
  201. palette := 0;
  202. colors := GetColors (s,palette);
  203. backgrouns := GetBackGrounds (s,palette);
  204. Stream := TStringStream.Create ( Format ('{ [colors,backgrouns,s]) );
  205.   if Assigned (Stream) then
  206.   try
  207.   PutRTFSelection (anObject,Stream);
  208.   finally
  209.   FreeAndNil (Stream);
  210.   end;
  211. end;
  212.  
  213. end.</code>

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

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