Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 5

Project CUSTQUEP

Project Structure


CUSTQUEP.DPR

library CustQueP;

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

{$R *.RES}

exports
  GetExtensionVersion,
  HttpExtensionProc,
  TerminateExtension;

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

CUSTWEBM.PAS

unit CustWebM;

interface

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

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);
    procedure WebModule1BeforeDispatch(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  private
    ScriptName: string;
  end;

var
  WebModule1: TWebModule1;

implementation

{$R *.DFM}

procedure TWebModule1.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: String; TagParams: TStrings; var ReplaceText: String);
begin
  if TagString = 'script' then
    ReplaceText := ScriptName
  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="' + ScriptName + '/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.ScriptName +
      '/record?' + CellData + '">' + CellData + '</a>'#13;
end;

procedure TWebModule1.WebModule1BeforeDispatch(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  ScriptName := Request.ScriptName;
end;

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>
  BeforeDispatch = WebModule1BeforeDispatch
  Left = 385
  Top = 217
  Height = 479
  Width = 741
  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 = 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' +
        '>'
      '</form>')
    OnHTMLTag = PageProducer1HTMLTag
    Left = 48
    Top = 64
  end
  object Query2: TQuery
    DatabaseName = 'DBDEMOS'
    Left = 120
    Top = 64
  end
end