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

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

Delphi控件源码

开发平台：

Delphi

BrokWm.pas：源码内容
  1. unit BrokWm;
  3. interface
  5. uses
  6.   Windows, Messages, SysUtils, Classes, HTTPApp, Db, DBTables, DSProd,
  7.   DBWeb, HTTPProd;
  9. type
  10.   TWebModule1 = class(TWebModule)
  11.     Table1: TTable;
  12.     Table1EmpNo: TIntegerField;
  13.     Table1LastName: TStringField;
  14.     Table1FirstName: TStringField;
  15.     Table1PhoneExt: TStringField;
  16.     Table1HireDate: TDateTimeField;
  17.     Table1Salary: TFloatField;
  18.     PageHead: TPageProducer;
  19.     DataSetPage: TDataSetPageProducer;
  20.     PageTail: TPageProducer;
  21.     DataSetTableProducer1: TDataSetTableProducer;
  22.     procedure TimeAction(Sender: TObject; Request: TWebRequest;
  23.       Response: TWebResponse; var Handled: Boolean);
  24.     procedure DateAction(Sender: TObject; Request: TWebRequest;
  25.       Response: TWebResponse; var Handled: Boolean);
  26.     procedure MenuAction(Sender: TObject; Request: TWebRequest;
  27.       Response: TWebResponse; var Handled: Boolean);
  28.     procedure StatusAction(Sender: TObject;
  29.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  30.     procedure RecordAction(Sender: TObject;
  31.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  32.     procedure PageTailHTMLTag(Sender: TObject; Tag: TTag;
  33.       const TagString: String; TagParams: TStrings;
  34.       var ReplaceText: String);
  35.     procedure DataSetTableProducer1FormatCell(Sender: TObject; CellRow,
  36.       CellColumn: Integer; var BgColor: THTMLBgColor;
  37.       var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  38.       CellData: String);
  39.     procedure WebModule1AfterDispatch(Sender: TObject;
  40.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  41.     procedure WebModule1WaTableAction(Sender: TObject;
  42.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  43.   public
  44.     { Public declarations }
  45.   end;
  47. var
  48.   WebModule1: TWebModule1;
  50. implementation
  52. {$R *.DFM}
  54. procedure TWebModule1.TimeAction(Sender: TObject;
  55.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  56. begin
  57.   Response.Content := 'Time at this site: ' +
  58.     FormatDateTime('hh:mm:ss AM/PM', Now) + '<p>';
  59. end;
  61. procedure TWebModule1.DateAction(Sender: TObject;
  62.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  63. begin
  64.   Response.Content := 'Today is ' +
  65.     FormatDateTime('dddd, mmmm d, yyyy', Now) + '<p>';
  66. end;
  68. procedure TWebModule1.MenuAction(Sender: TObject;
  69.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  70. var
  71.   I: Integer;
  72. begin
  73.   Response.Content := '<H3>Menu</H3><ul>'#13;
  74.   for I := 0 to Actions.Count - 1 do
  75.     Response.Content := Response.Content +
  76.       '<li> <a href="' + Request.ScriptName +
  77.       Action[I].PathInfo + '"> ' + Copy (Action[I].Name, 3, 1000) + '</a>'#13;
  78.   Response.Content := Response.Content + '</ul>';
  79. end;
  81. procedure TWebModule1.StatusAction(Sender: TObject;
  82.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  83. var
  84.   I: Integer;
  85. begin
  86.   Response.Content := '<H3>Status</H3>'#13 +
  87.     'Method: ' + Request.Method + '<br>'#13 +
  88.     'ProtocolVersion: ' + Request.ProtocolVersion + '<br>'#13 +
  89.     'URL: ' + Request.URL + '<br>'#13 +
  90.     'Query: ' + Request.Query + '<br>'#13 +
  91.     'PathInfo: ' + Request.PathInfo + '<br>'#13 +
  92.     'PathTranslated: ' + Request.PathTranslated + '<br>'#13 +
  93.     'Authorization: ' + Request.Authorization + '<br>'#13 +
  94.     'CacheControl: ' + Request.CacheControl + '<br>'#13 +
  95.     'Cookie: ' + Request.Cookie + '<br>'#13 +
  96.     'Date: ' + DateTimeToStr (Request.Date) + '<br>'#13 +
  97.     'Accept: ' + Request.Accept + '<br>'#13 +
  98.     'From: ' + Request.From + '<br>'#13 +
  99.     'Host: ' + Request.Host + '<br>'#13 +
  100.     'IfModifiedSince: ' + DateTimeToStr (Request.IfModifiedSince) + '<br>'#13 +
  101.     'Referer: ' + Request.Referer + '<br>'#13 +
  102.     'UserAgent: ' + Request.UserAgent + '<br>'#13 +
  103.     'ContentEncoding: ' + Request.ContentEncoding + '<br>'#13 +
  104.     'ContentType: ' + Request.ContentType + '<br>'#13 +
  105.     'ContentLength: ' + IntToStr (Request.ContentLength) + '<br>'#13 +
  106.     'ContentVersion: ' + Request.ContentVersion + '<br>'#13 +
  107.     'Content: ' + Request.Content + '<br>'#13 +
  108.     'Connection: ' + Request.Connection + '<br>'#13 +
  109.     'DerivedFrom: ' + Request.DerivedFrom + '<br>'#13 +
  110.     'Expires: ' + DateTimeToStr (Request.Expires) + '<br>'#13 +
  111.     'Title: ' + Request.Title + '<br>'#13 +
  112.     'RemoteAddr: ' + Request.RemoteAddr + '<br>'#13 +
  113.     'RemoteHost: ' + Request.RemoteHost + '<br>'#13 +
  114.     'ScriptName: ' + Request.ScriptName + '<br>'#13 +
  115.     'ServerPort: ' + IntToStr (Request.ServerPort) + '<br>'#13;
  116.   // list of strings
  117.   Response.Content := Response.Content +
  118.     'ContentFields:<ul>'#13;
  119.   for I := 0 to Request.ContentFields.Count - 1 do
  120.     Response.Content := Response.Content +
  121.       '<li>' + Request.ContentFields [I]+ #13;
  122.   Response.Content := Response.Content +
  123.     '</ul>CookieFields:<ul>'#13;
  124.   for I := 0 to Request.CookieFields.Count - 1 do
  125.     Response.Content := Response.Content +
  126.       '<li>' + Request.CookieFields [I] + #13;
  127.   Response.Content := Response.Content +
  128.     '</ul>QueryFields:<ul>'#13;
  129.   for I := 0 to Request.QueryFields.Count - 1 do
  130.     Response.Content := Response.Content +
  131.       '<li>' + Request.QueryFields [I] + #13;
  132. end;
  134. procedure TWebModule1.RecordAction(Sender: TObject;
  135.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  136. begin
  137.   Table1.Open;
  138.   // go to the requested record
  139.   Table1.FindNearest ([Request.QueryFields.Values['LastName'],
  140.     Request.QueryFields.Values['FirstName']]);
  141.   // get the output
  142.   Response.Content := DataSetPage.Content;
  143. end;
  145. procedure TWebModule1.PageTailHTMLTag(Sender: TObject; Tag: TTag;
  146.   const TagString: String; TagParams: TStrings; var ReplaceText: String);
  147. begin
  148.   if TagString = 'script' then
  149.     ReplaceText := Request.ScriptName;
  150. end;
  152. procedure TWebModule1.DataSetTableProducer1FormatCell(Sender: TObject;
  153.   CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
  154.   var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  155.   CellData: String);
  156. begin
  157.   if (CellColumn = 0) and (CellRow <> 0) then
  158.     CellData := '<a href="' + Request.ScriptName + '/record?LastName=' +
  159.       Table1['LastName'] + '&FirstName=' + Table1 ['FirstName'] + '"> '
  160.       + CellData + ' </a>';
  161. end;
  163. procedure TWebModule1.WebModule1AfterDispatch(Sender: TObject;
  164.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  165. begin
  166.   Response.Content := PageHead.Content +
  167.     Response.Content + PageTail.Content;
  168. end;
  170. procedure TWebModule1.WebModule1WaTableAction(Sender: TObject;
  171.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  172. begin
  173.   Table1.Open;
  174.   Table1.First;
  175. end;
  177. end.