开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
CustWebM.pas
资源名称：delphi.rar　[点击查看]
上传用户：fh681027
上传日期：2022-07-23
资源大小：1959k
文件大小：3k
源码类别：

Delphi控件源码

开发平台：

Delphi

CustWebM.pas：源码内容
  1. unit CustWebM;
  3. interface
  5. uses
  6.   Windows, Messages, SysUtils, Classes, HTTPApp, Db, DBTables, DBWeb,
  7.   HTTPProd, DBBdeWeb;
  9. type
  10.   TWebModule1 = class(TWebModule)
  11.     QueryTableProducer1: TQueryTableProducer;
  12.     Query1: TQuery;
  13.     Query1Company: TStringField;
  14.     Query1State: TStringField;
  15.     Query1Country: TStringField;
  16.     PageProducer1: TPageProducer;
  17.     Query2: TQuery;
  18.     procedure PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  19.       const TagString: String; TagParams: TStrings;
  20.       var ReplaceText: String);
  21.     procedure RecordAction(Sender: TObject;
  22.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  23.     procedure QueryTableProducer1FormatCell(Sender: TObject; CellRow,
  24.       CellColumn: Integer; var BgColor: THTMLBgColor;
  25.       var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  26.       CellData: String);
  27.   end;
  29. var
  30.   WebModule1: TWebModule1;
  32. implementation
  34. uses WebReq;
  36. {$R *.DFM}
  38. procedure TWebModule1.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  39.   const TagString: String; TagParams: TStrings; var ReplaceText: String);
  40. begin
  41.   if TagString = 'script' then
  42.     ReplaceText := Request.InternalScriptName
  43.   else
  44.   begin
  45.     ReplaceText := '';
  46.     Query2.SQL.Clear;
  47.     Query2.SQL.Add ('select distinct ' +
  48.       TagString + ' from customer');
  49.     try
  50.       Query2.Open;
  51.       try
  52.         Query2.First;
  53.         while not Query2.EOF do
  54.         begin
  55.           ReplaceText := ReplaceText +
  56.             '<option>' + Query2.Fields[0].AsString +
  57.             '</option>'#13;
  58.           Query2.Next;
  59.         end;
  60.       finally
  61.         Query2.Close;
  62.       end;
  63.     except
  64.       ReplaceText := '{wrong field: ' + TagString + '}';
  65.     end;
  66.   end;
  67. end;
  69. procedure TWebModule1.RecordAction(Sender: TObject;
  70.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  71. var
  72.   I: Integer;
  73. begin
  74.   if Request.QueryFields.Count = 0 then
  75.     Response.Content := 'Record not found'
  76.   else
  77.   begin
  78.     Query2.SQL.Clear;
  79.     Query2.SQL.Add ('select * from customer ' +
  80.       'where Company="' + Request.QueryFields[0] + '"');
  81.     Query2.Open;
  82.     Response.Content :=
  83.       '<HTML><HEAD><TITLE>Customer Record</TITLE></HEAD><BODY>'#13 +
  84.       '<H1>Customer Record: ' + Request.QueryFields[0] +
  85.       '</H1>'#13 +
  86.       '<table border>'#13;
  87.     for I := 1 to Query2.FieldCount - 1 do
  88.       Response.Content := Response.Content +
  89.         '<tr><td>' + Query2.Fields [I].FieldName +
  90.         '</td>'#13'<td>' + Query2.Fields [I].AsString +
  91.         '</td></tr>'#13;
  92.     Response.Content := Response.Content +
  93.       '</table><hr>'#13 +
  94.       // pointer to the query form
  95.       '<a HREF="' + Request.InternalScriptName + '/form">' +
  96.       ' Next Query </a>'#13 +
  97.       '</BODY></HTML>'#13;
  98.   end;
  99. end;
  101. procedure TWebModule1.QueryTableProducer1FormatCell(Sender: TObject;
  102.   CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
  103.   var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  104.   CellData: String);
  105. begin
  106.   if (CellColumn = 0) and (CellRow <> 0) then
  107.     CellData := '<a HREF="' + Request.InternalScriptName +
  108.       '/record?' + CellData + '">' + CellData + '</a>'#13;
  109.   if CellData = '' then
  110.     CellData := '&nbsp;';
  111. end;
  113. initialization
  114.   WebRequestHandler.WebModuleClass := TWebModule1;
  116. end.