Delphi: TRichEdit не принимает RTF через Stream

Столкнулся с проблемой: компонент TRichEdit в Delphi 10 при приеме данных из потока (через socket) не отображает текст в RTF формате, а отображает rtf-код. Использовать сторонние компоненты не хотелось и нагуглилось вот такое решение:

implementation

{$R *.dfm}

function EditStreamCallback(dwCookie: Longint; pbBuff: PByte;
                                 cb: Longint; var pcb: Longint): Longint;
     stdcall;
     var
       MS : TMemoryStream;
     begin
       MS := TMemoryStream(dwCookie);
       result := 0;

       with MS do begin
         if (Size = position) then begin
           pcb := 0;
           Exit;
         end
         else if (Size - Position) <= cb then begin
           pcb := Size;
           Read(pbBuff^, Size);
         end
         else begin
           pcb := cb;
           Read(pbBuff^, cb);
         end;
       end;
     end;

     function REFetchText(RE: TRichEdit; const Text: string): integer;
     var
       ES : TEditStream;
       MS :  TMemoryStream;
     begin
       MS := TMemoryStream.Create;
       try
         MS.Write(Text[1], Length(Text));
         MS.Seek(0, soFromBeginning);

         ES.dwCookie    := longint(MS);
         ES.dwError     := 0;
         ES.pfnCallback := @EditStreamCallback;

         result := SendMessage(RE.Handle, EM_STREAMIN, SF_RTF or SFF_SELECTION,
                               longint(@ES));
       finally
         MS.Free;
       end;
     end;

     type
       TREPutAction = (paAppend, paInsert, paReplace);

     function REPutText(RE: TRichEdit; const Text: string; PutAction: TREPutAction): integer;
     begin
       result := -1;

       if Text = '' then
         exit;

       case PutAction of
         paAppend  : begin
                       RE.Lines.Append(' ');

                       RE.SelStart :=  SendMessage(RE.Handle, EM_LINEINDEX, RE.Lines.Count - 1, 0);
                       RE.SelLength := 1;
                     end;
         paInsert  : begin
                       if RE.SelLength > 0 then
                         RE.SelText := RE.SelText +#32
                       else
                         RE.SelText := #32;

                       RE.SelStart := RE.SelStart +RE.SelLength -1;
                       RE.SelLength := 1;
                     end;
         paReplace : begin
                       if RE.SelLength > 0 then
                         RE.SelText := #32;
                     end;
       end;

       Result := REFetchText(RE, Text);
     end;

function REAppendFile(RE: TRichEdit; const Filename: string): integer;
     var
       FS : TFileStream;
       len : int64;
       s : string;
     begin
       result := -1;
       s := '';

       FS := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone);
       try
         len := FS.Size;
         if len > 0 then begin
           FS.Position := 0;
           SetLength(s, len);
           FS.Read(s[1], len);
         end;
       finally
         FS.Free;
       end;

       if s <> '' then
         result := REPutText(RE, s, paAppend);
     end;


function StreamToString(Stream : TStream) : String;
var ms : TMemoryStream;
begin
  Result := '';
  ms := TMemoryStream.Create;
  try
    ms.LoadFromStream(Stream);
    SetString(Result,PChar(ms.memory),ms.Size);
  finally
    ms.free;
  end;
end;

......

procedure TForm1.ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
var
  fs:TMemoryStream;
  L:integer;
  buf: pointer;
  s: string;
begin
  fs := TMemoryStream.Create();
  try
    L := ClientSocket1.Socket.ReceiveLength;
    fs.SetSize(L);
    GetMem(buf, L);
    fs.Position := 0;
    L := ClientSocket1.Socket.ReceiveBuf(buf^, L);
    fs.Write(buf^, L);
    fs.Position:=0;
    RichEdit1.Clear;
    Richedit1.DoubleBuffered:=false;
    RichEdit1.MaxLength := fs.Size;
    RichEdit1.PlainText := False;
    S:=StreamToString(fs);
    REPutText(RichEdit1, s, paReplace);
    RichEdit1.PlainText := False;
  finally
    fs.free;
    freeMem(buf);
  end;
end;
Запись опубликована в рубрике IT с метками . Добавьте в закладки постоянную ссылку.

Добавить комментарий

Войти с помощью: 

Ваш адрес email не будет опубликован. Обязательные поля помечены *

Лимит времени истёк. Пожалуйста, перезагрузите CAPTCHA.