Перейти к содержанию
Fire Monkey от А до Я
  • 0

Сообщения чата в виде сообщений в iphone.


gorec323

Вопрос

Здравствуйте, подскажите пожалуйста есть ли уже готовые компоненты на FireMonkey или на основе чего можно сделать сообщения в окне переписки в виде сообщений iphone? Как показано ниже:

Картинка удалена модератором! (Причина: Вместо картинки подгружалась реклама регистратора доменов)

 

Заранее спасибо.

Изменено пользователем Andrey Efimov
Удаление рекламы
Ссылка на комментарий

Рекомендуемые сообщения

  • 0
  • Администраторы

Добрый день,

  1. Я бы взял TScrollBox для контейнера сообщений.
  2. Каждое сообщени представил в виде TLabel с вашим стилем в виде облаков
  3. TLabel поместил в TLayout и внутри него выравнивал бы по правому или левому краю.
  4. А сами TLayout выравнивал бы по верху.
Ссылка на комментарий
  • 0
  • Администраторы

Для содания стиля сообщения используйте TStyleObject. Он позволяет исходную растровую картинку облака собщения растягивать в любой размер.

Ссылка на комментарий
  • 2

Для одного проекта писал такое пару месяцев назад, пользуйтесь.Под windows, при клике на сообщение, оно превращается в readonly TMemo - дабы можно было скопировать нужное из сообщения. При наличии URL в сообщении, сбоку появляется кнопка открыть - лучше ничего для открытия ссылок не придумал. Надо бы сделать диалог выбора для открытия одной из нескольких ссылок, но руки пока не доходят. Пощупать чат вживую можно в приложении https://play.google.com/store/apps/details?id=ru.flintnet.InternetAgent , для активации и загрузки примера чата отсканируйте  приложением qr-код с страницы  http://internetagent.flintnet.ru/

 

Screenshot004_resize.png

unit ChatBox;

interface

uses
  System.SysUtils, System.Classes, FMX.Types, FMX.Controls, FMX.Layouts,System.Types,
  FMX.StdCtrls,FMX.Edit,FMX.Memo,FMX.TextLayout,System.UITypes,FMX.Graphics,FMX.Objects,
  FMX.Effects,FMX.Styles.Objects;

type
  TMessagePos = (msgLeft,msgRight);
  TEventText = procedure(PURL: String) of object;

  TChatBox = class(TVertScrollBox)
  private
    FTextLyout : TTextLayout;
    FLastMessageId : Integer;
    FMsgWidthPercentage : Integer;
    FOnURLButtonClick : TEventText;
    FCalloutLength : Single;
    FCalloutXRadius : Single;
    FCalloutYRadius : Single;
    FMessageFontSize : Single;
    FMemo : TMemo;
    procedure ButtonClick(Sender: TObject);
    procedure MyMsgContainerOnClick(Sender: TObject);
    procedure MyMsgContainerOnExit(Sender: TObject);
    function FCreateMsgBlock(AOwner: TComponent; PMessageId : Integer;
      PDate, PAutor, PMessage : String; PMessagePos : TMessagePos) : TLayout;
    function CalculateTextItemHeight(Sender: TObject) : Single;
    procedure LayoutResize(Sender: TObject);
    function ExtractURL(pString : String) : String;
    procedure Memo1ApplyStyleLookup(Sender: TObject);
  public
    property LastMessageId : Integer read FLastMessageId;
    property MsgWidthPercentage : Integer read FMsgWidthPercentage write FMsgWidthPercentage default 80;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    Procedure AddMessage(pMessageId : Integer; PDate, PAutor, PMessage : String; PMessagePos : TMessagePos);
    procedure ClearChildren(AChatBox: TChatBox);
    procedure ScrollBottomSmoothly;
    procedure ScrollBottom;
  published
    property OnURLButtonClick : TEventText read FonURLButtonClick write FonURLButtonClick;
    property CalloutLength : Single read FCalloutLength write FCalloutLength;
    property CalloutXRadius : Single read FCalloutXRadius write FCalloutXRadius;
    property CalloutYRadius : Single read FCalloutYRadius write FCalloutYRadius;
    property MessageFontSize : Single read FMessageFontSize write FMessageFontSize;
  end;

  TOpenChatBox = class(TChatBox);

Procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('EKorepov', [TChatBox]);
end;

constructor TChatBox.Create(AOwner: TComponent);
begin
  inherited create(Aowner);
  FLastMessageId:=-1;
  FTextLyout := TTextLayoutManager.DefaultTextLayout.Create;
  FMemo:=TMemo.Create(Aowner);
  FMemo.TextSettings.WordWrap:=True;
  FMemo.ReadOnly:=True;
  FMemo.Align:=TAlignLayout.Client;
  FMemo.OnExit:=MyMsgContainerOnExit;
  FMemo.OnApplyStyleLookup:=Memo1ApplyStyleLookup;
  FMemo.StyledSettings:=FMemo.StyledSettings-[TStyledSetting.Size];
  With Self as TVertScrollBox do
  begin
    AniCalculations.Animation := True;
    AniCalculations.BoundsAnimation := True;
    AniCalculations.TouchTracking := [ttVertical];
  end;
end;

destructor TChatBox.Destroy;
begin
  FreeAndNil(FMemo);
  FreeAndNil(FTextLyout);
  inherited Destroy;
end;

procedure TChatBox.ScrollBottomSmoothly;
begin
  AniCalculations.MouseWheel(0, ContentBounds.Height+5);
end;

procedure TChatBox.ScrollBottom;
begin
  ScrollBy(0, -ContentBounds.Height);
end;

procedure TChatBox.ButtonClick(Sender: TObject);
Var URL : String;
begin
  URL:=TButton(Sender).HelpKeyword;
  if Assigned(FonURLButtonClick) then
    FonURLButtonClick(URL);
end;

procedure TChatBox.Memo1ApplyStyleLookup(Sender: TObject);
begin
end;

procedure TChatBox.MyMsgContainerOnClick(Sender: TObject);
begin
  FMemo.TextSettings:=TLabel(Sender).TextSettings;
  FMemo.Lines.Text:=TLabel(Sender).Text;
  TLabel(Sender).AddObject(FMemo);
end;

procedure TChatBox.MyMsgContainerOnExit(Sender: TObject);
begin
  if (Sender is TMemo) then
    if Assigned(TMemo(Sender).Parent) then
      if (TMemo(Sender).Parent is TLabel) then
        TLabel(TMemo(Sender).Parent).RemoveObject(TMemo(Sender));
end;

procedure TChatBox.ClearChildren(AChatBox: TChatBox);
begin
  Assert(AChatBox <> nil);
  TOpenChatBox(AChatBox).Content.DeleteChildren;
  AChatBox.Repaint;
end;

function TChatBox.CalculateTextItemHeight(Sender: TObject) : Single;
var Item: TLabel;
begin
  Result:=0;
  if (Sender is TLabel) then
  begin
    Item := TLabel(Sender);
    FTextLyout.BeginUpdate;
    try
      FTextLyout.Text := Item.Text;
      FTextLyout.MaxSize := TPointF.Create(Item.Width-Item.Margins.Left-Item.Margins.Right-10, 1000);
      FTextLyout.Font := Item.Font;
      FTextLyout.WordWrap:= Item.WordWrap;
      FTextLyout.HorizontalAlign:= Item.TextSettings.HorzAlign;
      FTextLyout.VerticalAlign:= Item.TextSettings.VertAlign;
    finally
      FTextLyout.EndUpdate;
    end;
    Result:= FTextLyout.Height+10;
  end;
end;

procedure TChatBox.LayoutResize(Sender: TObject);
Var Item : TLabel;
    CalloutRectangle : TCalloutRectangle;
    Layout : TLayout;
    I : Integer;
begin
  Layout:=TLayout(Sender);
  for I := 0 to Layout.Children.Count-1 do
  begin
    If Layout.Children.Items[I] is TCalloutRectangle Then
    begin
      CalloutRectangle:=TCalloutRectangle(Layout.Children.Items[I]);
      Item:=TLabel(CalloutRectangle.Children.Items[0]);
      CalloutRectangle.Width:=(Layout.Width / 100) * FMsgWidthPercentage;
      Layout.Height:=CalculateTextItemHeight(Item);
    end;
    If Layout.Children.Items[I] is TButton Then
    begin
      TButton(Layout.Children.Items[I]).Width:=(Layout.Width / 100) * (100-FMsgWidthPercentage-5);
    end;
  end;
end;

Procedure TChatBox.AddMessage(pMessageId : Integer; PDate, PAutor, PMessage : String; PMessagePos : TMessagePos);
Var lcLayout : TLayout;
begin
  PDate:=Trim(PDate);
  PAutor:=Trim(PAutor);
  PMessage:=Trim(PMessage);
  FLastMessageId:=PMessageId;
  lcLayout:=FCreateMsgBlock((Self as TVertScrollBox), PMessageId, PDate, PAutor, PMessage, PMessagePos);
  Self.AddObject(lcLayout);
end;

function TChatBox.FCreateMsgBlock(AOwner: TComponent; PMessageId : Integer; PDate, PAutor, PMessage : String;
                                  PMessagePos : TMessagePos) : TLayout;
Var lcLayout,lcLayout2 : TLayout;
    Item : TLabel;
    Button : TButton;
    CalloutRectangle : TCalloutRectangle;
    lcHeight : Single;
    URL : String;
begin
  lcLayout:=TLayout.Create(AOwner);
  lcLayout.Tag:=pMessageId;
  lcLayout.Align:=TAlignLayout.Top;
  lcLayout.Width:=200;
  lcLayout.Position.X:=0;
  lcLayout.Position.Y:= ((AOwner as TVertScrollBox).ContentBounds.Height+10);
  lcLayout.Margins.Bottom:=10;
  CalloutRectangle:=TCalloutRectangle.Create(lcLayout);
  CalloutRectangle.XRadius:=FCalloutXRadius;
  CalloutRectangle.YRadius:=FCalloutYRadius;
  CalloutRectangle.CalloutWidth:=10;
  CalloutRectangle.CalloutOffset:=-3-FCalloutYRadius-CalloutRectangle.CalloutWidth;
  CalloutRectangle.Width:=((AOwner as TVertScrollBox).Width / 100) * FMsgWidthPercentage;
  CalloutRectangle.HitTest:=False;
  case PMessagePos of
    msgRight :
    begin
      CalloutRectangle.Align:=TAlignLayout.Right;
      CalloutRectangle.CalloutPosition:=TCalloutPosition.Right;
      CalloutRectangle.Padding.Right:=CalloutRectangle.CalloutLength+CalloutRectangle.XRadius;
      CalloutRectangle.Padding.Left:=CalloutRectangle.XRadius;
    end;
    msgLeft :
    begin
      CalloutRectangle.Align:=TAlignLayout.Left;
      CalloutRectangle.CalloutPosition:=TCalloutPosition.Left;
      CalloutRectangle.Padding.Left:=CalloutRectangle.CalloutLength+CalloutRectangle.XRadius;
      CalloutRectangle.Padding.Right:=CalloutRectangle.XRadius;
    end;
  end;
  CalloutRectangle.Padding.Top:=1;
  CalloutRectangle.Padding.Bottom:=1;
  lcLayout.AddObject(CalloutRectangle);

  Item:=TLabel.Create(CalloutRectangle);
  Item.TextSettings.Font.Size:=MessageFontSize;

  CalloutRectangle.AddObject(Item);
  Item.Align:=TAlignLayout.Client;
{$IFDEF MSWINDOWS}
  Item.OnClick:=MyMsgContainerOnClick;
{$ENDIF MSWINDOWS}

  Item.Text:=PDate+' '+PAutor+#10+PMessage;
  Item.HitTest:=True;
  Item.WordWrap:=True;
  lcHeight:=CalculateTextItemHeight(Item);
  lcLayout.Height:=lcHeight;
  URL:=ExtractURL(pMessage);
  Item.StyledSettings:=Item.StyledSettings- [TStyledSetting.Size,TStyledSetting.Style];

  if Not URL.IsEmpty then
  begin
    lcLayout2:=TLayout.Create(lcLayout);
    lcLayout2.Align:=TAlignLayout.Client;
    lcLayout2.Margins.Left:=5;
    lcLayout2.Margins.Right:=5;
    lcLayout.AddObject(lcLayout2);
    Button:=TButton.Create(lcLayout2);
    Button.Text:='Открыть';
    Button.Align:=TAlignLayout.Center;
    Button.HelpKeyword:=URL;
    Button.OnClick:=ButtonClick;
    lcLayout2.AddObject(Button);
  end;
  lcLayout.OnResize:=LayoutResize;
  Result:=lcLayout;
end;

function TChatBox.ExtractURL(pString : String) : String;
Var S : String;
begin
  Result:='';
  if Not pString.Contains('http') then
    Exit;
  S:=pString.Substring(Pos('http',pString)-1);
  S:=S.Remove(S.IndexOfAny([' ',',']));
  Result:=S.TrimRight(['.']);
end;


end.
Ссылка на комментарий
  • 0

Евгений Корепов, а как пользоваться этим чатом?

Вот, например, я подцепил к проекту unit ChatBox и пытаюсь добавить сообщения.

  public
    { Public declarations }
    chat:TChatBox;
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

procedure TForm1.Button1Click(Sender: TObject);
begin
  chat.AddMessage(1,'22:15','Автор1','сообщение',TMessagePos.msgLeft);
  chat.AddMessage(2,'22:16','Автор2','сообщение2',TMessagePos.msgRight);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  chat:=TChatBox.Create(Layout1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  chat.Destroy;
end;

но ничего не происходит.

Ссылка на комментарий
  • 1
В 17.05.2016 в 16:46, Rusland сказал:

Евгений Корепов, а как пользоваться этим чатом?

Вот, например, я подцепил к проекту unit ChatBox и пытаюсь добавить сообщения.


  public
    { Public declarations }
    chat:TChatBox;
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

procedure TForm1.Button1Click(Sender: TObject);
begin
  chat.AddMessage(1,'22:15','Автор1','сообщение',TMessagePos.msgLeft);
  chat.AddMessage(2,'22:16','Автор2','сообщение2',TMessagePos.msgRight);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  chat:=TChatBox.Create(Layout1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  chat.Destroy;
end;

но ничего не происходит.

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  chat:=TChatBox.Create(Layout1); 
  Chat.Align:=TAlignLayout.Client;
  Chat.MsgWidthPercentage:=66;
  Chat.CalloutLength:=10;
  Chat.CalloutXRadius:=5;
  Chat.CalloutYRadius:=5;
  Chat.MessageFontSize:=14;
  Layout1.AddObject(Chat);
end;

Как то так...

Ссылка на комментарий
  • 0

Заработало!

Но почему-то появляются полоски:

chat.png

Отчего это?

И при нажатии на кнопку Открыть урл не открывается.

procedure TChatBox.ButtonClick(Sender: TObject);
Var URL : String;
begin
  URL:=TButton(Sender).HelpKeyword;
  if Assigned(FonURLButtonClick) then
    FonURLButtonClick(URL); // сюда не заходит
end;

И как очистить чат?

Изменено пользователем Rusland
Ссылка на комментарий
  • 0

При нажатие на кнопку и не должно ничего происходить. Вы сами обрабатываете событие:

...
TFormMain = class(TForm)
  procedure ChatBoxURLButton(PURL: string); 
...
ChatBox.OnURLButtonClick:=ChatBoxURLButton; // При создании ChatBox
...
procedure TFormMain.ChatBoxURLButton(PURL: string);
begin
  OpenURL(PURL); // Открываем url мультиплатформенной процедурой
end;

// К примеру такой:
procedure TFormMain.OpenURL(const AUrl: string);
{$IFDEF ANDROID}
var Uri: Jnet_Uri;
    OpenLinkIntent: JIntent;
{$ENDIF ANDROID}
begin
{$IFDEF MSWINDOWS}
  ShellExecute(0, 'open', PChar(AUrl), nil, nil, SW_SHOWNORMAL);
{$ENDIF MSWINDOWS}
{$IFDEF ANDROID}
  Uri := StrToJURI(AUrl);
  OpenLinkIntent := TJIntent.JavaClass.init(TJIntent.JavaClass.ACTION_VIEW, Uri);
  SharedActivity.startActivity(OpenLinkIntent);
{$ENDIF ANDROID}
end;

 

Ссылка на комментарий
  • 0

Спасибо. Пока этот чат нравится больше остальных.

20 минут назад, Евгений Корепов сказал:

Очистить : 


Chat.ClearChildren(Chat);

 

После очистки длинного чата, остается висеть скроллер VertScrollBox. Как его скрыть?

 

Как сделать, например, на longtap облачка открытие url (вместо отображения кнопки... не очень красиво выходит) или предложить выбор (если ссылок несколько)?  (копирование из мемо не интересует, поэтому готов им пожертвовать... тем более что если CalloutRectangle не белого цвета, то при активации мемо - он белого цвета)

Изменено пользователем Rusland
Ссылка на комментарий
  • 0
4 часа назад, Евгений Корепов сказал:

Полоски это TLabel видимо с бордюром, поэкспериментируйте со стилем или с свойством Clip 

Похоже этот бордюр бывает только в Windows (в Android не наблюдаю), причем если окно свернуть/развернуть или проскроллировать сообщения, то бордюр исчезает. Видимо что-то с прорисовкой. Пробовал делать Invalidate - не помогает. 

Изменено пользователем Rusland
Ссылка на комментарий
  • 1

Подправил uChatBox.pas под себя, заменил TLabel на TText, теперь проблем с отрисовкой бордюра не наблюдаю. Добавил выделение заголовка и градиент в "облачка".

Чат2.png

ChatBox.zip

Ссылка на комментарий
  • 0
В 19.05.2016 в 21:02, Rusland сказал:

Подправил uChatBox.pas под себя, заменил TLabel на TText, теперь проблем с отрисовкой бордюра не наблюдаю. Добавил выделение заголовка и градиент в "облачка".

Чат2.png

ChatBox.zip

Всем привет! Под Андроид у некоторых сообщений внизу создаётся лишнее пустое пространство.
В примере это видно (выделил красным). Rad Studio 10.2 Tokyo.
Никто это не правил?
 

573dc67daa0a1_2.png.0084dcb7a497a64596c8120701ea74cf.png

Ссылка на комментарий
  • 0

В HTML Library в комплекте идет пример чата с автоматической конвертации ссылки на картинку в картинку, ссылки на гугл карту в кусок карты, просто ссылки в активную ссылку и.т.д

Ну и понятно, что сообщения могут содержать абсолютно любое оформление текста, картинки и.т.д.

Компилированный вариант для VCL http://delphihtmlcomponents.com/editorchatdemo.zip

IMG_0982.PNG

Ссылка на комментарий
  • 0
  • Модераторы
В 07.09.2017 в 17:44, r@di0 сказал:

Всем привет! Под Андроид у некоторых сообщений внизу создаётся лишнее пустое пространство.
В примере это видно (выделил красным). Rad Studio 10.2 Tokyo.
Никто это не правил?

Скорее всего неправильно задана ширина области для функции, которая возвращает высоту текста.

Ссылка на комментарий

Присоединяйтесь к обсуждению

Вы можете написать сейчас и зарегистрироваться позже. Если у вас есть аккаунт, авторизуйтесь, чтобы опубликовать от имени своего аккаунта.

Гость
Ответить на вопрос...

×   Вставлено с форматированием.   Вставить как обычный текст

  Разрешено использовать не более 75 эмодзи.

×   Ваша ссылка была автоматически встроена.   Отображать как обычную ссылку

×   Ваш предыдущий контент был восстановлен.   Очистить редактор

×   Вы не можете вставлять изображения напрямую. Загружайте или вставляйте изображения по ссылке.

  • Последние посетители   0 пользователей онлайн

    • Ни одного зарегистрированного пользователя не просматривает данную страницу
×
×
  • Создать...