marcocantu.com - Code Repository

Marco Web Center

[an error occurred while processing this directive]

Home: Code Repository: Mastering Delphi 6

Chapter 22 - Project CustQueP

Project Structure

CustQueP.dpr
CustWebM.pas
CustWebM.dfm

CustQueP.dpr

program CustQueP;

{$APPTYPE CONSOLE}

uses
  WebBroker,
  CGIApp,
  CustWebM in 'CustWebM.pas' {WebModule1: TWebModule};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TWebModule1, WebModule1);
  Application.Run;
end.

CustWebM.pas

unit CustWebM;

interface

uses
  Windows, Messages, SysUtils, Classes, HTTPApp, Db, DBTables, DBWeb,
  HTTPProd, DBBdeWeb;

type
  TWebModule1 = class(TWebModule)
    QueryTableProducer1: TQueryTableProducer;
    Query1: TQuery;
    Query1Company: TStringField;
    Query1State: TStringField;
    Query1Country: TStringField;
    PageProducer1: TPageProducer;
    Query2: TQuery;
    procedure PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
      const TagString: String; TagParams: TStrings;
      var ReplaceText: String);
    procedure RecordAction(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
    procedure QueryTableProducer1FormatCell(Sender: TObject; CellRow,
      CellColumn: Integer; var BgColor: THTMLBgColor;
      var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
      CellData: String);
  end;

var
  WebModule1: TWebModule1;

implementation

uses WebReq;

{$R *.DFM}

procedure TWebModule1.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: String; TagParams: TStrings; var ReplaceText: String);
begin
  if TagString = 'script' then
    ReplaceText := Request.InternalScriptName
  else
  begin
    ReplaceText := '';
    Query2.SQL.Clear;
    Query2.SQL.Add ('select distinct ' +
      TagString + ' from customer');
    try
      Query2.Open;
      try
        Query2.First;
        while not Query2.EOF do
        begin
          ReplaceText := ReplaceText +
            '<option>' + Query2.Fields[0].AsString +
            '</option>'#13;
          Query2.Next;
        end;
      finally
        Query2.Close;
      end;
    except
      ReplaceText := '{wrong field: ' + TagString + '}';
    end;
  end;
end;

procedure TWebModule1.RecordAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  I: Integer;
begin
  if Request.QueryFields.Count = 0 then
    Response.Content := 'Record not found'
  else
  begin
    Query2.SQL.Clear;
    Query2.SQL.Add ('select * from customer ' +
      'where Company="' + Request.QueryFields[0] + '"');
    Query2.Open;
    Response.Content :=
      '<HTML><HEAD><TITLE>Customer Record</TITLE></HEAD><BODY>'#13 +
      '<H1>Customer Record: ' + Request.QueryFields[0] +
      '</H1>'#13 +
      '<table border>'#13;
    for I := 1 to Query2.FieldCount - 1 do
      Response.Content := Response.Content +
        '<tr><td>' + Query2.Fields [I].FieldName +
        '</td>'#13'<td>'   + Query2.Fields [I].AsString +
        '</td></tr>'#13;
    Response.Content := Response.Content +
      '</table><hr>'#13 +
      // pointer to the query form
      '<a HREF="' + Request.InternalScriptName + '/form">' +
      ' Next Query </a>'#13 +
      '</BODY></HTML>'#13;
  end;
end;

procedure TWebModule1.QueryTableProducer1FormatCell(Sender: TObject;
  CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
  var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  CellData: String);
begin
  if (CellColumn = 0) and (CellRow <> 0) then
    CellData := '<a HREF="' + Request.InternalScriptName +
      '/record?' + CellData + '">' + CellData + '</a>'#13;
  if CellData = '' then
    CellData := '&nbsp;';
end;

initialization
  WebRequestHandler.WebModuleClass := TWebModule1;

end.

CustWebM.dfm

object WebModule1: TWebModule1
  OldCreateOrder = True
  Actions = <
    item
      Name = 'ActionSearch'
      PathInfo = '/search'
      Producer = QueryTableProducer1
    end
    item
      Default = True
      Name = 'ActionForm'
      PathInfo = '/form'
      Producer = PageProducer1
    end
    item
      Name = 'ActionRecord'
      PathInfo = '/record'
      OnAction = RecordAction
    end>
  Left = 384
  Top = 174
  Height = 207
  Width = 319
  object QueryTableProducer1: TQueryTableProducer
    Caption = '<b>Customers</b>'
    Columns = <
      item
        FieldName = 'Company'
      end
      item
        FieldName = 'State'
      end
      item
        FieldName = 'Country'
      end>
    Query = Query1
    TableAttributes.Border = 1
    TableAttributes.CellSpacing = 0
    TableAttributes.CellPadding = 3
    OnFormatCell = QueryTableProducer1FormatCell
    Left = 48
    Top = 16
  end
  object Query1: TQuery
    DatabaseName = 'DBDEMOS'
    SQL.Strings = (
      'SELECT Company, State,  Country'
      'FROM CUSTOMER.DB'
      'WHERE '
      '  State = :State OR Country = :Country')
    Left = 120
    Top = 16
    ParamData = <
      item
        DataType = ftString
        Name = 'State'
        ParamType = ptUnknown
      end
      item
        DataType = ftString
        Name = 'Country'
        ParamType = ptUnknown
        Value = 'US'
      end>
    object Query1Company: TStringField
      FieldName = 'Company'
      Size = 30
    end
    object Query1State: TStringField
      FieldName = 'State'
    end
    object Query1Country: TStringField
      FieldName = 'Country'
    end
  end
  object PageProducer1: TPageProducer
    HTMLDoc.Strings = (
      '<h4>Customer QueryProducer Search Form</h4>'
      '<form action="<#script>/search" method="POST">'
      '<table>'
      '<tr><td>State:</td><td><select name="State">'
      '<#State>'
      '</select>'
      '</td></tr>'
      '<tr><td>Country:</td><td><select name="Country">'
      '<option> </option>'
      '<#Country>'
      '</select>'
      '</td></tr>'

              '<tr><td></td><td><center><input type="Submit"></center></td></tr' +
        '>'
      '</table></form>')
    OnHTMLTag = PageProducer1HTMLTag
    Left = 48
    Top = 64
  end
  object Query2: TQuery
    DatabaseName = 'DBDEMOS'
    Left = 120
    Top = 64
  end
end