盒子论坛 v2.1

一、目标
    近日写了一个小模块，实现了获取今日头条新闻数据、保存到数据库的功能，将此模块挂接到QuickBurro中间件上，新闻数据就会源源不断地增加。
    然后，我们就可以轻轻松松在自己的应用里加入新闻资讯频道，甚至，直接做一个类似“今日头条”的APP。这里，我们用Delphi来实现一下。
    先看此App的设计时界面：

此帖子包含附件:

大小:27.5K

----------------------------------------------
樵夫的大马甲

作者：

jopher3 (樵夫的马六甲)	▲▲▲▲▲	-
	普通会员

2017/1/5 8:14:20

1楼：

二、App程序的实现
    我们采用“壳+h5页面”的形式来实现此App，所以，程序主框架用Delphi控件搭建，而主工作区，则使用了一个TWebBrowser对象，用于显示页面。下面是程序代码：

unit main;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts,
  FMX.StdCtrls, FMX.Objects, FMX.TabControl, System.Rtti, FMX.Grid, FMX.ListBox,
  MBAccessor, MBConnection, System.IOUtils, FMX.DateTimeCtrls, FMX.Controls.Presentation,
  FMX.WebBrowser, FMX.Edit, FMX.ComboEdit, MBCommon, FMX.ExtCtrls;

type
  TMainForm = class(TForm)
    Layout1: TLayout;
    Rectangle1: TRectangle;
    Button1: TButton;
    Button2: TButton;
    Image2: TImage;
    Image3: TImage;
    Layout2: TLayout;
    Layout3: TLayout;
    View1: TRectangle;
    MBConn: TMBConnection;
    MBA: TMBAccessor;
    MainBack: TRectangle;
    Label1: TLabel;
    Rectangle2: TRectangle;
    Edit1: TEdit;
    Button3: TButton;
    Image1: TImage;
    Browser: TWebBrowser;
    Rectangle3: TRectangle;
    Button4: TButton;
    Image8: TImage;
    Button5: TButton;
    Image4: TImage;
    Button6: TButton;
    Image5: TImage;
    StyleBook1: TStyleBook;
    Button7: TButton;
    Image6: TImage;
    Button8: TButton;
    Image7: TImage;
    comboedit1: TComboEdit;
    Button9: TButton;
    Image9: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char;
      Shift: TShiftState);
    procedure Button3Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ComboEdit1Change(Sender: TObject);
    procedure Button9Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.fmx}

//
// 退出...
procedure TMainForm.Button1Click(Sender: TObject);
begin
  MessageDlg(#13#10+'退出就看不到爽歪歪的新闻了！'+#13#10#13#10+'是否确认退出樵夫新闻速递？'
     +#13#10, System.UITypes.TMsgDlgType.mtInformation,
    [
      System.UITypes.TMsgDlgBtn.mbYes,
      System.UITypes.TMsgDlgBtn.mbNo
    ], 0,
    procedure(const AResult: TModalResult)
    begin
      if AResult = mrYES then
         begin
          mbconn.Disconnect;
          close;
         end;
    end);
end;

//
// 关于...
procedure TMainForm.Button2Click(Sender: TObject);
var
   tmpstr: string;
begin
   if mbconn.connect then
      begin
         if mba.ReadSimpleResult('select count(*) from todaynews',tmpstr) then
          ShowMessage('@@@ 樵夫新闻速递 @@@'+#13#10+'版权所有(C) 樵夫工作室'
          +#13#10#13#10+'[ 当前已有'+tmpstr+'条新闻！]')
         else
          ShowMessage('** 无法获取新闻条数 **');
         mbconn.Disconnect;
      end
   else
      ShowMessage('** 无法连接应用服务器 **');
end;

//
// 查找...
procedure TMainForm.Button3Click(Sender: TObject);
begin
   ComboEdit1Change(nil);
end;

//
// 首页...
procedure TMainForm.Button4Click(Sender: TObject);
begin
   ComboEdit1.OnChange:=nil;
   ComboEdit1.Text:='推荐';
   ComboEdit1.OnChange:=ComboEdit1Change;
   edit1.text:='';
   ComboEdit1Change(nil);
end;

//
// 回退...
procedure TMainForm.Button5Click(Sender: TObject);
begin
   if browser.CanGoBack then
      browser.GoBack;
end;

//
// 前进...
procedure TMainForm.Button6Click(Sender: TObject);
begin
   if browser.CanGoForward then
      browser.GoForward;
end;

//
// 刷新...
procedure TMainForm.Button7Click(Sender: TObject);
begin
   ComboEdit1Change(nil);
end;

//
// 清除关键字，重新显示...
procedure TMainForm.Button9Click(Sender: TObject);
begin
   edit1.text:='';
   ComboEdit1Change(nil);
end;

//
// 频道切换...
procedure TMainForm.ComboEdit1Change(Sender: TObject);
var
   newstype: integer;
begin
   browser.EnableCaching:=false;
   newstype:=0;
   if comboedit1.Text='推荐' then
      newstype:=0;
   if comboedit1.Text='国内' then
      newstype:=1;
   if comboedit1.Text='国际' then
      newstype:=2;
   if comboedit1.Text='财经' then
      newstype:=3;
   if comboedit1.Text='科技' then
      newstype:=4;
   if comboedit1.Text='军事' then
      newstype:=5;
   if comboedit1.Text='体育' then
      newstype:=6;
   if comboedit1.Text='社会' then
      newstype:=7;
   if comboedit1.Text='时尚' then
      newstype:=8;
   if comboedit1.Text='娱乐' then
      newstype:=9;
   if trim(edit1.Text)='' then
      browser.Navigate('

http://www.quickburro.org/newsdigger/newsdigger.asq'
         +'?taskid=1&newstype='+inttostr(newstype))
   else
      browser.Navigate('

http://www.quickburro.org/newsdigger/newsdigger.asq'
         +'?taskid=1&newstype='+inttostr(newstype)+'&keyword='+trim(edit1.Text));
   browser.EnableCaching:=true;
end;

//
// 按硬回退时...
procedure TMainForm.FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char;
  Shift: TShiftState);
begin
  if Key = vkHardwareBack then
     begin
       //
       // 可回退时...
       if browser.CanGoBack then
          begin
          browser.GoBack;
          key:=0;
          exit;
          end;
       //
       // 退出程序...
       key:=0;
       Button1Click(nil);
     end;
end;

//
// 程序打开时，显示首页...
procedure TMainForm.FormShow(Sender: TObject);
begin
   ComboEdit1.OnChange:=nil;
   ComboEdit1.Text:='推荐';
   ComboEdit1.OnChange:=ComboEdit1Change;
   edit1.text:='';
   ComboEdit1Change(nil);
end;

end.
----------------------------------------------
樵夫的大马甲

作者：

jopher3 (樵夫的马六甲)	▲▲▲▲▲	-
	普通会员

2017/1/5 8:14:53

2楼：

三、服务端Web服务的实现
    我们采用QuickBurro作为服务端，故只要为此应用专门写一个页面动态生成的Web插件即可，此插件将接收来自WebBrowser的Web请求，根据请求查询新闻数据表，再生成html页面，最后将结果返回给客户端。下面是实现代码：

//
// NewsDigger.dpr -- 今日头条新闻服务插件
//

library NewsDigger;

uses
  FastMM4,
  FastMove,
  SysUtils,
  Classes,
  Windows,
  AnsiStrings,
  QBParcel,
  qbmisc,
  qbjson,
  DllSpread,
  qbserviceapi,
  IdBaseComponent,
  IdComponent,
  IdTCPConnection,
  IdTCPClient,
  IdHTTP,
  Forms,
  ADODB,
  db;

{$R *.RES}

type
   NewsRecord=record
      NewsId: string;
      TypeId: string;
      SubTypeId: string;
      Title: string;
      Author: string;
      ThumbUrl1: string;
      ThumbUrl2: string;
      ThumbUrl3: string;
      NewsUrl: string;
      NewsDate: string;
      SaveDate: string;
   end;

var
   APIParcel: TQBParcel;
   Misc: TApiMisc;
   s_DefaultDir: string;
   databaseid: ansistring;

//
// 生成一条新闻的html（单个缩略图）...
function GetTopicHtml(aNews: NewsRecord): string;
var
   nd: TDateTime;
begin
   nd:=qbmisc.StrToDateTimeEx(aNews.NewsDate);
   result:='<li>'+#13#10;
   result:=result+'<table width=100% border=0 cellpadding=0 cellspacing=0>'+#13#10;
   result:=result+'<tr>'+#13#10;
   result:=result+'<td width=86 align=left valign=middle>'+#13#10;
   result:=result+'<img src="'+anews.ThumbUrl1+'" border=0 width=80>'+#13#10;
   result:=result+'</td>'+#13#10;
   result:=result+'<td align=left valign=middle>'+#13#10;
   result:=result+'<a href="'+anews.NewsUrl+'"><h3 class="wrap" style="font-weight:normal;">'+aNews.Title+'</h3></a>'+#13#10;
   result:=result+'<div style="width:70px;float:right;margin-right:5px;font-size:12px">'
      +formatdatetime('mm-dd hh:nn',nd)+'</div>'+#13#10;
   result:=result+'<div style="margin-right:70px;font-size:12px">'+aNews.Author+'</div>'+#13#10;
   result:=result+'</td>'+#13#10;
   result:=result+'</tr>'+#13#10;
   result:=result+'</table>'+#13#10;
   result:=result+'</li>'+#13#10;
end;

//
// 生成一条新闻的html（三个缩略图）...
function GetTopicHtml3(aNews: NewsRecord): string;
var
   nd: TDateTime;
begin
   nd:=qbmisc.StrToDateTimeEx(aNews.NewsDate);
   result:='<li>'+#13#10;
   result:=result+'<a href="'+anews.NewsUrl+'"><h3 class="wrap" style="font-weight:normal;">'+aNews.Title+'</h3></a>'+#13#10;
   //
   result:=result+'<table width=100% border=0 cellpadding=0 cellspacing=0>'+#13#10;
   result:=result+'<tr>'+#13#10;
   result:=result+'<td width=33% align=center valign=middle>'+#13#10;
   result:=result+'<img src="'+anews.ThumbUrl1+'" border=0 width=98%>'+#13#10;
   result:=result+'</td>'+#13#10;
   result:=result+'<td width=33% align=center valign=middle>'+#13#10;
   result:=result+'<img src="'+anews.ThumbUrl2+'" border=0 width=98%>'+#13#10;
   result:=result+'</td>'+#13#10;
   result:=result+'<td width=33% align=center valign=middle>'+#13#10;
   result:=result+'<img src="'+anews.ThumbUrl3+'" border=0 width=98%>'+#13#10;
   result:=result+'</td>'+#13#10;
   result:=result+'</tr>'+#13#10;
   result:=result+'</table>'+#13#10;
   //
   result:=result+'<div style="width:70px;float:right;margin-right:5px;font-size:12px">'
      +formatdatetime('mm-dd hh:nn',nd)+'</div>'+#13#10;
   result:=result+'<div style="margin-right:70px;font-size:12px">'+aNews.Author+'</div>'+#13#10;
   result:=result+'</li>'+#13#10;
end;

//
// 主函数，此函数由应用程序员编写...
function MainFunction(InParcel: TQBParcel; OutParcel: TQBParcel): boolean;
var
   ok: boolean;
   sql: string;
   tmpstr,newstype,keyword,responsebody: ansistring;
   AdoConn: TAdoConnection;
   SysDataset: TAdoDataset;
   Stream: TMemoryStream;
   j,taskid: integer;
   News: NewsRecord;
   ParamParcel: TQBParcel;
begin
   Stream:=nil;
   AdoConn:=nil;
//
// 若无参数...
   ParamParcel:=TQBParcel.Create;
   if not InParcel.GetParcelGoods('Parameters',ParamParcel) then
      begin
         if assigned(ParamParcel) then
          freeandnil(ParamParcel);
         ResponseBody:='<html><body>Invalid web requestion.</body></html>';
         try
          OutParcel.PutAnsiStringGoods('ResponseBody',ResponseBody);
          result:=true;
         except
          result:=false;
         end;
         exit;
      end;
//
// 分不同功能调用...
   tmpstr:=ParamParcel.GetAnsiStringGoods('TaskId');
   if trim(tmpstr)='' then
      taskid:=-1
   else
      try
         taskid:=strtoint(string(tmpstr));
      except
         taskid:=-1;
      end;
   case taskid of
      //
      // 显示页面...
      1: begin
          //
          // 取类别、关键词...
          newstype:=ParamParcel.GetAnsiStringGoods('NewsType');
          keyword:=ansistring(utf8tostring(ParamParcel.GetAnsiStringGoods('Keyword')));
          if newstype='' then
          j:=0
          else
          try
          j:=strtoint(string(newstype));
          except
          j:=0;
          end;
          case j of
          0: newstype:='';
          1: newstype:='国内';
          2: newstype:='国际';
          3: newstype:='财经';
          4: newstype:='科技';
          5: newstype:='军事';
          6: newstype:='体育';
          7: newstype:='社会';
          8: newstype:='时尚';
          9: newstype:='娱乐';
          end;
          //
          // 模板文件不存在...
          if not fileexists(s_defaultdir+'templates\todaynews.qtml') then
          begin
          if assigned(ParamParcel) then
          freeandnil(ParamParcel);
          ResponseBody:='<html><body>Template file not found.</body></html>';
          try
          OutParcel.PutAnsiStringGoods('ResponseBody',ResponseBody);
          result:=true;
          except
          result:=false;
          end;
          exit;
          end;
          //
          // 读入模板...
          Stream:=TMemoryStream.Create;
          try
          Stream.LoadFromFile(s_defaultdir+'templates\todaynews.qtml');
          SetLength(ResponseBody,Stream.size);
          Stream.Position:=0;
          Stream.Read(ResponseBody[1],Stream.Size);
          ok:=true;
          except
          ok:=false;
          end;
          FreeAndNil(Stream);
          if not ok then
          begin
          if assigned(ParamParcel) then
          freeandnil(ParamParcel);
          ResponseBody:='<html><body>Read template file failed.</body></html>';
          try
          OutParcel.PutAnsiStringGoods('ResponseBody',ResponseBody);
          result:=true;
          except
          result:=false;
          end;
          exit;
          end;
          //
          // 分配数据库连接...
          AdoConn:=QBServiceAPI.CreateAdoConnection(InParcel,DatabaseId);
          if AdoConn<>nil then
          begin
          //
          // 生成SQL...
          if NewsType='' then
          sql:=''
          else
          sql:='SubTypeId='''+string(NewsType)+'''';
          if keyword<>'' then
          begin
          if sql<>'' then
          sql:=sql+' and ';
          sql:=sql+'(Title like ''%'+string(keyword)+'%'' or Author like ''%'+string(keyword)+'%'')';
          end;
          if sql='' then
          sql:='select top 50 * from todaynews order by newsid desc'
          else
          sql:='select top 50 * from todaynews where '+sql+' order by newsid desc';
          //
          // 创建对象...
          SysDataset:=TAdoDataset.Create(nil);
          SysDataset.DisableControls;
          SysDataset.Connection:=AdoConn;
          SysDataset.CommandText:=sql;
          try
          SysDataset.Active:=true;
          ok:=true;
          except
          ok:=false;
          end;
          //
          // 输出列表信息...
          if ok then
          begin
          tmpstr:='';
          try
          SysDataset.First;
          while not SysDataset.Eof do
          begin
          news.NewsId:=trim(sysdataset.FieldByName('NewsId').AsString);
          news.TypeId:=trim(sysdataset.FieldByName('TypeId').AsString);
          news.SubTypeId:=trim(sysdataset.FieldByName('SubTypeId').AsString);
          news.Title:=trim(sysdataset.FieldByName('Title').AsString);
          news.Author:=trim(sysdataset.FieldByName('Author').AsString);
          news.ThumbUrl1:=trim(sysdataset.FieldByName('ThumbUrl1').AsString);
          news.ThumbUrl2:=trim(sysdataset.FieldByName('ThumbUrl2').AsString);
          news.ThumbUrl3:=trim(sysdataset.FieldByName('ThumbUrl3').AsString);
          news.NewsUrl:=trim(sysdataset.FieldByName('NewsUrl').AsString);
          news.NewsDate:=trim(sysdataset.FieldByName('NewsDate').AsString);
          news.SaveDate:=trim(sysdataset.FieldByName('SaveDate').AsString);
          if (news.ThumbUrl2<>'') and (news.ThumbUrl3<>'') then
          tmpstr:=tmpstr+ansistring(GetTopicHtml3(news))
          else
          tmpstr:=tmpstr+ansistring(GetTopicHtml(news));
          SysDataset.Next;
          end;
          SysDataset.Active:=false;
          except
          tmpstr:='';
          end;
          j:=pos(ansistring('`嵌入列表`'),ResponseBody);
          delete(responsebody,j,10);
          insert(tmpstr,ResponseBody,j);
          end
          else
          responsebody:='<html><body>Open news table failed.</body></html>';
          //
          // 释放对象...
          FreeAndNil(SysDataset);
          if assigned(AdoConn) then
          QBServiceAPI.FreeAdoConnection(AdoConn);
          end
          else
          ResponseBody:='<html><body>Allocate ADOConnection object failed.</body></html>';
         end;
      //
      // 其他请求...
      else
         ResponseBody:='<html><body>Invalid web requestion.TaskId='+ansistring(inttostr(taskid))+'</body></html>';
   end;
//
// 返回...
   try
      OutParcel.PutAnsiStringGoods('Content-Type','text/html;charset=utf-8');
      OutParcel.PutAnsiStringGoods('ResponseBody',Utf8Encode(ResponseBody));
   except
   end;
//
// 释放对象、完成...
   FreeAndNil(ParamParcel);
   result:=true;
end;

//
// 接口初始化...
function ApiInitialize(ApiParcelPtr: integer): boolean; stdcall;
var
   tmpParcel: TQBParcel;
   FileName: string;
   Json: TQBJson;
   ok: boolean;
   TransferKey: ansistring;
   BasePtr: integer;
begin
   Json:=nil;
//
// 得到接口参数...
   try
      TmpParcel:=TQBParcel(pointer(ApiParcelPtr));
   except
      result:=false;
      exit;
   end;
   BasePtr:=TmpParcel.GetIntegerGoods('Callback_Proc_List');
   TransferKey:=TmpParcel.GetAnsiStringGoods('Transfer_Key');
   ApiParcel:=TQBParcel.Create;
   ApiParcel.PutIntegerGoods('Callback_Proc_List',BasePtr);
   ApiParcel.PutAnsiStringGoods('Transfer_Key',TransferKey);
   Misc:=TAPIMisc.Create(ApiParcel);
//
// 取配置参数...
   FileName:=s_defaultdir+'config\newsdigger.sys';
   if not fileexists(filename) then
      begin
         Misc.LogMsg('*** NewsDigger.dll: Config file [newsdigger.sys] not found!');
         Result:=false;
         exit;
      end;
   try
      Json:=TQBJson.Create(filename,true);
      databaseid:=Json.GetString('DatabaseId');
      ok:=true;
   except
      ok:=false;
      databaseid:='';
   end;
   if assigned(json) then
      FreeAndNil(Json);
   if not ok then
      begin
         Misc.LogMsg('*** NewsDigger.dll: Read from config file failed!');
         Result:=false;
         exit;
      end
   else
      Misc.LogMsg('NewsDigger.dll: Initialize interface successful!');
//
// 完成...
   result:=true;
end;

//
// 导出函数（应用程序员不用改）...
function WebpageProcess(InParcelPtr: integer; var OutParcelPtr: integer): boolean; stdcall;
var
   aInParcel: TQBParcel;
   aOutParcel: TQBParcel;
begin
   try
      aInParcel:=TQBParcel(InParcelPtr);
   except
      result:=false;
      OutParcelPtr:=0;
      exit;
   end;
   aOutParcel:=TQBParcel.Create;
   try
      Result:=MainFunction(aInParcel,aOutParcel);
      if Result then
         begin
          if aOutParcel.GoodsCount<=0 then
          OutParcelPtr:=0
          else
          OutParcelPtr:=Parcel2Mem(aOutParcel);
         end
      else
         OutParcelPtr:=0;
   except
      OutParcelPtr:=0;
      result:=false;
   end;
   FreeAndNil(aOutParcel);
end;

//
// DLL 出入口过程...
procedure DLLHandler(Reason: integer);
var
   Buffer: array [0..255] of char;
begin
   case Reason of
      DLL_Process_Attach:
         begin
          GetModuleFileName(0, Buffer, SizeOf(Buffer));
          s_DefaultDir:=ExtractFilePath(string(Buffer));
          Misc:=nil;
         end;
      DLL_PROCESS_DETACH:
         begin
          if assigned(Misc) then
          FreeAndNil(Misc);
          if assigned(ApiParcel) then
          FreeAndNil(ApiParcel);
         end;
   end;
end;

//
// 向主程序提供的函数或过程的输出声明...
exports
   WebpageProcess,ApiInitialize;

//
// 初始化代码...
begin
   IsMultiThread:=true;
   DLLProc:=@DLLHandler;
   DLLHandler(DLL_Process_Attach);
end.

此帖子包含附件:

大小:194.0K

----------------------------------------------
樵夫的大马甲

作者：

jopher3 (樵夫的马六甲)	▲▲▲▲▲	-
	普通会员

2017/1/5 8:15:13

3楼：

四、结束
点击新闻Url，可以看新闻内容；点回退按钮，则回到列表页。效果如下图：

此帖子包含附件:

大小:196.8K

----------------------------------------------
樵夫的大马甲

作者：

vmao (毛小毛)	★☆☆☆☆	-
	盒子活跃会员

2017/1/5 8:40:47

4楼：

phonegap不就是干这个的么？而且还支持插件，调用硬件。这样用Delphi绕远了。
----------------------------------------------
-

作者：

jopher3 (樵夫的马六甲)	▲▲▲▲▲	-
	普通会员

2017/1/5 8:54:17

5楼：

楼上的，这么说就差矣！

美国人在吃饭，莫非中国人就不再需要吃饭啦？
----------------------------------------------
樵夫的大马甲

作者：

daxiaoduoshao (大小多少)	★☆☆☆☆	-
	盒子活跃会员

2017/1/5 8:58:52

6楼：

调用相机拍照，图片裁剪和文件、图片上传有问题吧
----------------------------------------------
-

作者：

akay (akay)	★☆☆☆☆	-
	普通会员

2017/1/5 9:09:29

7楼：

做得不错。
----------------------------------------------
-

作者：

msfm (清洁工)	★☆☆☆☆	-
	盒子活跃会员

2017/1/5 9:47:16

8楼：

支持
----------------------------------------------
-

作者：

ybj316 (ybj)	★☆☆☆☆	-
	盒子活跃会员

2017/1/5 10:17:35

9楼：

支持国人自己的东东！否则永远在IT食物链的末端！！！
----------------------------------------------
-

作者：

lxy1997 (lxy)	★☆☆☆☆	-
	普通会员

2017/1/6 11:34:22

10楼：

樵夫技术高手！
----------------------------------------------
-

作者：

isxuzhu (e.Wong)	★☆☆☆☆	-
	盒子活跃会员

2017/1/6 21:58:33

11楼：

很好！
----------------------------------------------
你我,都可以是个造梦者!欢迎加入脚本引擎PaxCompiler交流群303904495http://www.cnblogs.com/fireboxsoft有需要错别字检测软件的朋友可以在我博客上的地址下载使用，备注“2ccc”的朋友可以免费获取超级黄金VVVVVVVVVVIP授权

作者：

FengLinYuShu (FengLinYuShu)	★☆☆☆☆	-
	盒子活跃会员

2017/1/6 22:19:36

12楼：

学习！
----------------------------------------------
-delphi大富翁论坛http://www.delphibbs.com

作者：

jopher3 (樵夫的马六甲)	▲▲▲▲▲	-
	普通会员

2017/1/24 6:57:50

13楼：

顶一个，好东西不能埋没
----------------------------------------------
樵夫的大马甲

信息

登陆以后才能回复