суббота, 25 января 2014 г.

RSS клиент для сайта DelphiFeeds{.ru}

Читал тут статью(DelphiFeedsClient on Android (and iOS)) в блоге Marco Cantù. В этой статье Марко написал RSS клиент для сайтов blogs.embarcadero.com и www.delphifeeds.com. И относительно недавно, я узнал (из статистики блога), что есть русская версия данного сайта www.delphifeeds.ru (Спасибо, что добавили мой блог :). Вот и решил сегодня (Just for Fun) использовать статью Марко и (до)написать RSS клиент для сайта www.delphifeeds.ru, только я пошёл немного дальше, чем просто вывод списка последних статей.

Upd (21.04.14). Проверено на Delphi XE6.

Представляю вашему вниманию RSS клиент для сайта www.delphifeeds.ru.
Что умеет приложение:
  • Просмотр списка последних 10 статей из RSS ленты
  • Выбор и просмотр любой статьи из списка сразу на сайте автора (Пришлось написать маленькую кривенькую(да простят меня Гуру) функцию для извлечения прямой ссылки. Как ещё можно вытащить нужную ссылку?)
Скриншоты:



При просмотре статьи: для удобства реализовал обработку некоторых событий браузера, кнопку обновления страницы и кнопку возврата на предыдущую страницу (это если вы решили полазить по сайту автора статьи).

Примечание. Конечно же, это приложение нельзя считать законченным, т.к. не все варианты поведения пользователя обрабатываются (например, запуск приложения без интернета и т.п.), но я делал это приложение Just for Fun и результаты меня устраивают :) В целом приложение работает нормально.
Примечание.2. Статья на скриншоте выбрана рандомно.

Код:

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, Xml.xmldom,
  Xml.XMLIntf, FMX.WebBrowser, FMX.Layouts, FMX.ListBox, FMX.StdCtrls,
  FMX.TabControl, Xml.XMLDoc, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP, Xml.adomxmldom;

type
  TForm1 = class(TForm)
    IdHTTP1: TIdHTTP;
    XMLDocument1: TXMLDocument;
    TabControl1: TTabControl;
    TabItem1: TTabItem;
    TabItem2: TTabItem;
    ToolBar1: TToolBar;
    ToolBar2: TToolBar;
    ListBox1: TListBox;
    WebBrowser1: TWebBrowser;
    Label1: TLabel;
    SpeedButton1: TSpeedButton;
    Label2: TLabel;
    Label3: TLabel;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    procedure SpeedButton1Click(Sender: TObject);
    procedure ListBox1ItemClick(const Sender: TCustomListBox;
      const Item: TListBoxItem);
    procedure WebBrowser1DidStartLoad(ASender: TObject);
    procedure WebBrowser1DidFinishLoad(ASender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

uses
  System.StrUtils;

const
  rssUrl: string = 'http://delphifeeds.ru/index.php?format=feed&type=rss';

procedure TForm1.FormCreate(Sender: TObject);
begin
  TabControl1.ActiveTab := TabItem1;
  WebBrowser1.Navigate; // Избавляемся от бага
end;

procedure TForm1.ListBox1ItemClick(const Sender: TCustomListBox;
  const Item: TListBoxItem);
begin
  TabControl1.ActiveTab := TabItem2;
  WebBrowser1.Navigate(Item.TagString);
end;

{Получаем ссылку на полную версию статьи}
function CutUrl(s: string): string;
var
  StrStart, StrEnd: string; // Что ищем, начало и конец строки
  LenStrStart: integer; // Длина начальной строчки
  PosStart, PosEnd: integer; // Позиции начала и конца строки
begin
  StrStart := '...Читать на сайте автора';
  LenStrStart := Length(StrStart);

  PosStart := PosEx(StrStart, s);
  PosEnd := PosEx(StrEnd, s, PosStart);

  result := Copy(s, PosStart + LenStrStart, PosEnd - PosStart - LenStrStart);
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  RssXml: string;
  i: integer;
  LItem: TListBoxItem;
  ChannelNode, ItemNode: IXMLNode;
  title, author, pubDate, url, descr: string;
begin
  try
    rssXml := IdHTTP1.Get(rssUrl);
  except
    on E: Exception do
    begin
      ShowMessage ('Error: ' + E.Message);
      Exit;
    end;
  end;
  XMLDocument1.LoadFromXML(rssXml);
  //XMLDocument1.Active := True;

  ListBox1.BeginUpdate;
  try
    ListBox1.Clear;

    ChannelNode := XMLDocument1.DocumentElement.ChildNodes.FindNode ('channel');

    for i := 0 to ChannelNode.ChildNodes.Count - 1 do
      begin
        ItemNode := ChannelNode.ChildNodes[I];
        if ItemNode.NodeName = 'item' then
        begin
          title := ItemNode.ChildValues ['title'];
          pubDate := ItemNode.ChildValues ['pubDate'];
          author := ItemNode.ChildValues ['category'];
          descr := ItemNode.ChildValues ['description'];
          url := CutUrl(descr);

          LItem := TListBoxItem.Create(ListBox1);
          LItem.Height := 44;
          LItem.ItemData.Text := title;
          LItem.ItemData.Detail := author + ' - ' + Copy(pubDate, 1, 11);
          LItem.TagString := url;
          ListBox1.AddObject(LItem);
        end;
    end;
  finally
    ListBox1.EndUpdate;
  end;
end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  WebBrowser1.GoBack;
end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  WebBrowser1.Navigate;
end;

procedure TForm1.WebBrowser1DidFinishLoad(ASender: TObject);
begin
  Label3.Text := 'Загрузка завершена!';
end;

procedure TForm1.WebBrowser1DidStartLoad(ASender: TObject);
begin
  Label3.Text := 'Загрузка...';
end;

end.


Исходный код проекта: Скачать с Google Drive
APK файл для установки на ваш девайс: Скачать с Google Drive

p.s. Заметил баг, иногда, при открытии любой статьи, приложение виснет и падает. Проблема с WebBrowser1?!
Нашёл "решение", если добавить в "TForm1.FormCreate" строчку "WebBrowser1.Navigate;", то баг пропадает. Код в посте и по ссылкам обновил.

9 комментариев:

  1. Подскажите, пожалуйста. Совсем недавно открыла для себя возможность писать под андроид на делфи. Как сделать кнопки-картинки? Как у вас на скринах, например: обновить и назад.

    ОтветитьУдалить
    Ответы
    1. У кнопок есть свойство "StyleLookup", в нём можно выбрать картинку.

      Удалить
  2. А возможно ли такое, чтобы при обновлении, форма не висла? Пытаюсь прикрутить (вывести) TAniIndicator во время загрузки, не получается :D

    ОтветитьУдалить
    Ответы
    1. Чтобы форма не висла, попробуйте использовать отдельный поток.

      Удалить
  3. Перекинул в поток, но после завершения потока, приложение просто навсего вылетает, даже если написать простенько чтобы вывело сообщение "Showmessage" в потоке. Причем не я один с такой проблемой.

    ОтветитьУдалить
  4. а у меня почему-то LItem.ItemData.Detail вообще не отображается. Все стайлы перепробовала. Это включается в свойствах?

    ОтветитьУдалить
    Ответы
    1. Выставите свойство: DefaultItemStyles->ItemStyle: listboxitembottomdetail

      Удалить
    2. спасибо. Всё получилось. Только можно ли заставить делфи читать знаки типа « ? Или это только кодом просматривать текст?

      Удалить
  5. У меня при закрытии вашего приложения ошибка:
    Project DelphiFeedsRuClient.exe raised exception class $C0000005 with message 'access violation at 0x008d1842: read of address 0x00000004'.

    В отладке выбрасывает на модуль FMX.Platform

    function TPlatformServices.SupportsPlatformService(const AServiceGUID: TGUID;
    out AService): Boolean;
    begin
    if FServicesList.ContainsKey(AServiceGUID) then

    ОтветитьУдалить