unit BBCode;
{******************************************************************************}
{*  BB Code Unit                                                              *}
{*  Do not use this unit in commercial projects                               *}
{*  Revolutionary Confederation of Anarcho Syndicalists                       *}
{*  Written by: black.rabbit 2010                                             *}
{******************************************************************************}
interface
 
uses
    Windows, SysUtils, Classes,
    ComCtrls, RichEdit;
 
procedure InsertBBCode (anObject: TRichEdit; const aBBCode: String);
 
implementation
 
type
    TEditStreamCallBack = function (dwCookie: LongInt;
                                    pbBuff: PByte;
                                    cb: LongInt;
                                    var pcb: LongInt) : DWORD; stdcall;
    TEditStreamData = packed record
        dwCookie    : LongInt;
        dwError     : LongInt;
        pfnCallback : TEditStreamCallBack;
    end;
 
function EditStreamInCallback (dwCookie: Longint;
                               pbBuff: PByte;
                               cb: Longint;
                               var pcb: Longint) : DWORD; stdcall;
var
    Stream    : TStream;
    dataAvail : LongInt;
begin
    Result := UINT (E_FAIL);
    try
        Stream := TStream (dwCookie);
        if Assigned (Stream) then
        with Stream do
        begin
            dataAvail := Size - Position;
            Result := 0;
            if ( dataAvail <= cb ) then
            begin
                pcb := Read (pbBuff^,dataAvail);
                if ( pcb <> dataAvail ) then
                    Result := UINT (E_FAIL);
            end
            else
            begin
                pcb := Read (pbBuff^,cb);
                if ( pcb <> cb ) then
                    Result := UINT (E_FAIL);
            end;
        end;
    except
        Result := UINT (E_FAIL);
    end;
end;
 
procedure PutRTFSelection (anObject: TRichEdit; aSourceStream: TStream);
var
    Data : TEditStreamData;
begin
    try
        if ( not Assigned (anObject) ) then
            raise Exception.CreateFmt ('Объект класса ''%s'' не инициализирован!',
                                       [anObject.ClassName]);
        with Data do
        begin
            dwCookie := LongInt (aSourceStream);
            dwError := 0;
            pfnCallback := EditStreamInCallBack;
        end;
        anObject.Perform ( EM_STREAMIN, SF_RTF or SFF_SELECTION, LongInt (@Data) );
    except on E: Exception do
        raise Exception.CreateFmt ('Ошибка инъекции данных!'#13#10'%s',
                                   [E.Message]);
    end;
end;
 
function StrReplace (const Source, Search, Replace: String) : String;
var
    Buf1   : String;
    Buf2   : String;
    Buffer : String;
begin
    Result := Source;
    Buf1 := '';
    Buf2 := Source;
    Buffer := Source;
    while ( Pos (Search, Buf2) > 0 ) do
    begin
        Buf2 := Copy (  Buf2, Pos (Search, Buf2), ( Length (Buf2) - Pos (Search, Buf2) ) + 1  );
        Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) ) + Replace;
        Delete ( Buf2, Pos (Search, Buf2), Length (Search) );
        Buffer := Buf1 + Buf2;
    end;
    Result := Buffer;
end;
 
function GetColors (var aBBCode: String; var aPallete: WORD) : String;
var
    Buf1   : String;
    Buf2   : String;
    Buf3   : String;
    Buffer : String;
    color  : String;
    R      : Byte;
    G      : Byte;
    B      : Byte;
begin
    Result := '';
    Buf1 := '';
    Buf2 := aBBCode;
    Buf3 := '';
    Buffer := aBBCode;
    R := 0;
    G := 0;
    B := 0;
    while ( Pos ('[COLOR:#',Buf2) > 0 ) do
    begin
        Buf2 := Copy (  Buf2, Pos ('[COLOR:#', Buf2), ( Length (Buf2) - Pos ('[COLOR:#', Buf2) ) + 1  );
        Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) );
        color := Copy  ( Buf2, Pos ('[COLOR:#', Buf2) + Length ('[COLOR:#'), Length ('RRGGBB') );
        R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
        G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
        B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
        Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
        Inc (aPallete);
        Delete ( Buf2, Pos ('[COLOR:#', Buf2), Length ('[COLOR:#RRGGBB]') );
        Buf3 := Copy (  Buf2, 1, ( Pos ('[/COLOR]', Buf2) - 1 )  );
        Buf2 := Copy (  Buf2, Pos ('[/COLOR]', Buf2) + Length ('[/COLOR]'), ( Length (Buf2) - Pos ('[/COLOR]', Buf2) ) +
1  );
        Buffer := Format ('%s\cf%d %s\cf0 %s',[Buf1,aPallete,Buf3,Buf2]);
    end;
    aBBCode := Buffer;
end;
 
function GetBackgrounds (var aBBCode: String; var aPallete: WORD) : String;
var
    Buf1   : String;
    Buf2   : String;
    Buf3   : String;
    Buffer : String;
    color  : String;
    R      : Byte;
    G      : Byte;
    B      : Byte;
begin
    Result := '';
    Buf1 := '';
    Buf2 := aBBCode;
    Buf3 := '';
    Buffer := aBBCode;
    R := 0;
    G := 0;
    B := 0;
    while ( Pos ('[BACKGROUND:#',Buf2) > 0 ) do
    begin
        Buf2 := Copy (  Buf2, Pos ('[BACKGROUND:#', Buf2), ( Length (Buf2) - Pos ('[BACKGROUND:#', Buf2) ) + 1  );
        Buf1 := Copy  ( Buffer, 1, Length (Buffer) - Length (Buf2) );
        color := Copy  ( Buf2, Pos ('[BACKGROUND:#', Buf2) + Length ('[BACKGROUND:#'), Length ('RRGGBB') );
        R := StrToInt ( Format ('$%s',[Copy (color,1,2)]) );
        G := StrToInt ( Format ('$%s',[Copy (color,3,2)]) );
        B := StrToInt ( Format ('$%s',[Copy (color,5,2)]) );
        Result := Format ('%s\red%d\green%d\blue%d;',[Result,R,G,B]);
        Inc (aPallete);
        Delete ( Buf2, Pos ('[BACKGROUND:#', Buf2), Length ('[BACKGROUND:#RRGGBB]') );
        Buf3 := Copy (  Buf2, 1, ( Pos ('[/BACKGROUND]', Buf2) - 1 )  );
        Buf2 := Copy (  Buf2, Pos ('[/BACKGROUND]', Buf2) + Length ('[/BACKGROUND]'), ( Length (Buf2) - Pos
('[/BACKGROUND]', Buf2) ) + 1  );
        Buffer := Format ('%s\highlight%d %s\highlight0 %s',[Buf1,aPallete,Buf3,Buf2]);
    end;
    aBBCode := Buffer;
end;
 
procedure InsertBBCode (anObject: TRichEdit; const aBBCode: String);
var
    Stream     : TStringStream;
    s          : String;
    colors     : String;
    backgrouns : String;
    palette    : WORD;
begin
    s := aBBCode;
    s := StrReplace (s,'[B]','\b ');
    s := StrReplace (s,'[/B]','\b0');
    s := StrReplace (s,'[I]','\i ');
    s := StrReplace (s,'[/I]','\i0');
    s := StrReplace (s,'[U]','\ul ');
    s := StrReplace (s,'[/U]','\ulnone');
    s := StrReplace (s,'[S]','\strike ');
    s := StrReplace (s,'[/S]','\strike0');
    s := StrReplace (s,#13#10,'\par ');
    palette := 0;
    colors := GetColors (s,palette);
    backgrouns := GetBackGrounds (s,palette);
    Stream := TStringStream.Create ( Format ('{\rtf1{\colortbl ;%s%s}%s}',
                                             [colors,backgrouns,s]) );
    if Assigned (Stream) then
    try
        PutRTFSelection (anObject,Stream);
    finally
        FreeAndNil (Stream);
    end;
end;
 
end.