mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-30 15:20:35 +02:00
+ Initial implementation of HTML producer
This commit is contained in:
michael
parent
6b9ddca760
commit
f3219862dd
110
fcl/db/Makefile
110
fcl/db/Makefile
@ -1,8 +1,8 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/04/01]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/06/26]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos macosx emx
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx
|
||||
override PATH:=$(subst \,/,$(PATH))
|
||||
ifeq ($(findstring ;,$(PATH)),)
|
||||
inUnix=1
|
||||
@ -32,7 +32,7 @@ inOS2=1
|
||||
endif
|
||||
endif
|
||||
else
|
||||
ifneq ($(findstring cygwin,$(MACHTYPE)),)
|
||||
ifneq ($(findstring cygdrive,$(PATH)),)
|
||||
inCygWin=1
|
||||
endif
|
||||
endif
|
||||
@ -220,7 +220,7 @@ endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
override TARGET_DIRS+=mysql interbase
|
||||
endif
|
||||
override TARGET_UNITS+=db ddg_ds ddg_rec
|
||||
override TARGET_UNITS+=db ddg_ds ddg_rec dbwhtml
|
||||
override TARGET_EXAMPLEDIRS+=tests
|
||||
override INSTALL_FPCPACKAGE=y
|
||||
override COMPILER_OPTIONS+=-S2
|
||||
@ -534,6 +534,12 @@ ifeq ($(OS_TARGET),macos)
|
||||
EXEEXT=
|
||||
FPCMADE=fpcmade.mcc
|
||||
endif
|
||||
ifeq ($(OS_TARGET),darwin)
|
||||
EXEEXT=
|
||||
HASSHAREDLIB=1
|
||||
FPCMADE=fpcmade.darwin
|
||||
ZIPSUFFIX=darwin
|
||||
endif
|
||||
else
|
||||
ifeq ($(OS_TARGET),go32v1)
|
||||
PPUEXT=.pp1
|
||||
@ -892,69 +898,159 @@ TAREXT=.tar.gz
|
||||
endif
|
||||
override REQUIRE_PACKAGES=rtl
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
ifeq ($(CPU_TARGET),m68k)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
ifeq ($(CPU_TARGET),powerpc)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
ifeq ($(CPU_TARGET),sparc)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
ifeq ($(CPU_TARGET),x86_64)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),go32v2)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),win32)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),os2)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),freebsd)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),freebsd)
|
||||
ifeq ($(CPU_TARGET),m68k)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),beos)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
ifeq ($(CPU_TARGET),m68k)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),amiga)
|
||||
ifeq ($(CPU_TARGET),m68k)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),atari)
|
||||
ifeq ($(CPU_TARGET),m68k)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),sunos)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),sunos)
|
||||
ifeq ($(CPU_TARGET),sparc)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),qnx)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),netware)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),wdosx)
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
ifeq ($(CPU_TARGET),m68k)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),wdosx)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),palmos)
|
||||
ifeq ($(CPU_TARGET),m68k)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),macos)
|
||||
ifeq ($(CPU_TARGET),powerpc)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),macosx)
|
||||
endif
|
||||
ifeq ($(OS_TARGET),darwin)
|
||||
ifeq ($(CPU_TARGET),powerpc)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),emx)
|
||||
ifeq ($(CPU_TARGET),i386)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
endif
|
||||
endif
|
||||
ifdef REQUIRE_PACKAGES_RTL
|
||||
PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
|
||||
ifneq ($(PACKAGEDIR_RTL),)
|
||||
@ -1152,7 +1248,7 @@ override COMPILER:=$(FPC) $(FPCOPT)
|
||||
ifeq (,$(findstring -s ,$(COMPILER)))
|
||||
EXECPPAS=
|
||||
else
|
||||
ifeq ($(OS_SOURCE),$(OS_TARGET))
|
||||
ifeq ($(FULL_SOURCE),$(FULL_TARGET))
|
||||
EXECPPAS:=@$(PPAS)
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -12,7 +12,7 @@ dirs_freebsd=mysql interbase
|
||||
dirs_netbsd=mysql interbase
|
||||
dirs_openbsd=mysql interbase
|
||||
dirs_win32=mysql interbase
|
||||
units=db ddg_ds ddg_rec
|
||||
units=db ddg_ds ddg_rec dbwhtml
|
||||
exampledirs=tests
|
||||
|
||||
[compiler]
|
||||
|
||||
483
fcl/db/dbwhtml.pp
Normal file
483
fcl/db/dbwhtml.pp
Normal file
@ -0,0 +1,483 @@
|
||||
{$mode objfpc}
|
||||
{$H+}
|
||||
unit dbwhtml;
|
||||
|
||||
Interface
|
||||
|
||||
uses sysutils,classes,db,whtml;
|
||||
|
||||
Type
|
||||
THTMLAlign = (haDefault,haLeft,haRight,haCenter); // Compatible with Delphi.
|
||||
|
||||
TTableColumn = Class(TCollectionItem)
|
||||
private
|
||||
FActionUrl: String;
|
||||
FAlign: THTMLAlign;
|
||||
FBGColor: String;
|
||||
FCaptionURL: String;
|
||||
FFieldName : String;
|
||||
FCaption : String;
|
||||
FGetColumn: String;
|
||||
FImgUrl: String;
|
||||
Protected
|
||||
FField : TField; // Filled.
|
||||
Published
|
||||
Property FieldName : String Read FFieldName Write FFieldName;
|
||||
Property Caption : String Read FCaption Write FCaption;
|
||||
Property ImgUrl : String Read FImgUrl Write FImgUrl;
|
||||
Property ActionUrl : String Read FActionUrl Write FActionUrl;
|
||||
Property CaptionURL : String Read FCaptionURL Write FCaptionURL;
|
||||
Property BGColor : String Read FBGColor Write FBGColor;
|
||||
Property Align : THTMLAlign read FAlign Write Falign;
|
||||
end;
|
||||
|
||||
TTableColumns = Class(TCollection)
|
||||
Constructor Create;
|
||||
end;
|
||||
|
||||
THTMLProducer = Class(TComponent)
|
||||
Private
|
||||
FDataset : TDataset;
|
||||
FContents: TMemorySTream;
|
||||
Function GetContent : String;
|
||||
Protected
|
||||
Procedure CheckContents;
|
||||
Procedure WriteString(S : TStream; Const Value : String);
|
||||
Procedure WriteString(S : TStream; Const Fmt : String; Args : Array Of Const);
|
||||
Public
|
||||
Destructor Destroy; override;
|
||||
Procedure ClearContent;
|
||||
Procedure CreateContent; virtual; Abstract;
|
||||
Property Content : String Read GetContent;
|
||||
Published
|
||||
Property Dataset : TDataset Read FDataset Write FDataset;
|
||||
end;
|
||||
|
||||
|
||||
TTableProducer = Class(THTMLProducer)
|
||||
Private
|
||||
FTableColumns : TTableColumns;
|
||||
FBorder : Boolean;
|
||||
Protected
|
||||
Procedure BindColumns;
|
||||
Procedure CreateTableColumns; Virtual;
|
||||
Procedure CreateTableHeader(Stream : TStream);
|
||||
Procedure CreateHeaderCell(C : TTableColumn; Stream : TStream); virtual;
|
||||
Procedure CreateTableRow(Stream : TStream);virtual;
|
||||
Procedure StartTable(Stream : TStream); virtual;
|
||||
Procedure EndTable(Stream : TStream); virtual;
|
||||
Procedure EmitFieldCell(C : TTableColumn; Stream : TStream); virtual;
|
||||
Public
|
||||
Constructor Create(AOwner : TComponent); override;
|
||||
Destructor Destroy; virtual;
|
||||
Procedure Clear;
|
||||
Procedure CreateColumns(FieldList : TStrings);
|
||||
Procedure CreateColumns(FieldList : String);
|
||||
Procedure CreateTable(Stream : TStream);
|
||||
Procedure CreateTable;
|
||||
Procedure CreateContent; override;
|
||||
Published
|
||||
Property Border : Boolean Read FBorder Write FBorder;
|
||||
end;
|
||||
|
||||
TComboBoxProducer = Class(THTMLProducer)
|
||||
private
|
||||
FDatafield: String;
|
||||
FInputName: String;
|
||||
FValue: String;
|
||||
FValueField: String;
|
||||
function GetInputName: String;
|
||||
protected
|
||||
procedure CreateItem(Stream : TStream; VF,DF : TField; Selected : Boolean); virtual;
|
||||
Public
|
||||
Constructor Create(AOwner : TComponent); override;
|
||||
Destructor Destroy; virtual;
|
||||
Procedure CreateComboBox(Stream : TStream);
|
||||
Procedure CreateComboBox;
|
||||
Procedure CreateContent; override;
|
||||
Published
|
||||
Property ValueField : String Read FValueField Write FValueField;
|
||||
Property DataField : String Read FDatafield Write FDataField;
|
||||
Property Value : String Read FValue Write FValue;
|
||||
Property InputName : String Read GetInputName Write FInputName;
|
||||
end;
|
||||
|
||||
TDBHtmlWriter = Class(THTMLWriter)
|
||||
Protected
|
||||
Function CreateTableProducer: TTableProducer; virtual;
|
||||
Public
|
||||
Procedure CreateTable(Dataset : TDataset);
|
||||
Procedure CreateTable(Dataset : TDataset; Producer : TTableProducer);
|
||||
end;
|
||||
|
||||
|
||||
Implementation
|
||||
|
||||
{ TTableColumns }
|
||||
|
||||
constructor TTableColumns.Create;
|
||||
begin
|
||||
inherited Create(TTableColumn);
|
||||
end;
|
||||
|
||||
{ TTableProducer }
|
||||
|
||||
|
||||
procedure TTableProducer.BindColumns;
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
With FTableColumns do
|
||||
For I:=0 to Count-1 do
|
||||
With TTableColumn(Items[I]) do
|
||||
FField:=FDataset.FieldByName(FieldName);
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateTableColumns;
|
||||
begin
|
||||
FTableColumns:=TTableColumns.Create;
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateTableHeader(Stream : TStream);
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
WriteString(Stream,'<TR>');
|
||||
With FTableColumns do
|
||||
For I:=0 to Count-1 do
|
||||
CreateHeaderCell(TTableColumn(Items[I]),Stream);
|
||||
WriteString(Stream,'</TR>'#10);
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateHeaderCell(C: TTableColumn; Stream: TStream);
|
||||
|
||||
Var
|
||||
URL : String;
|
||||
|
||||
begin
|
||||
WriteString(Stream,'<HD>');
|
||||
With C do
|
||||
begin
|
||||
If (FCaptionURL<>'') then
|
||||
begin
|
||||
URL:=Format(FCaptionURL,[FieldName]);
|
||||
URL:=Format('<A HREF="%s">',[URL]);
|
||||
WriteString(Stream,URL);
|
||||
end;
|
||||
WriteString(Stream,Caption);
|
||||
If (FCaptionURL<>'') then
|
||||
WriteString(Stream,'</A>');
|
||||
If (FImgURL<>'') then
|
||||
begin
|
||||
if (FCaptionURL<>'') then
|
||||
WriteString(Stream,URL);
|
||||
WriteString(Stream,'<IMG SRC="%s">',[FImgURL]);
|
||||
If (FCaptionURL<>'') then
|
||||
WriteString(Stream,'</A>');
|
||||
end;
|
||||
end;
|
||||
WriteString(Stream,'</HD>');
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateTableRow(Stream : TStream);
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
WriteString(Stream,'<TR>');
|
||||
With FTableColumns do
|
||||
For I:=0 to Count-1 do
|
||||
EmitFieldCell(TTableColumn(Items[I]),Stream);
|
||||
WriteString(Stream,'</TR>'#10);
|
||||
end;
|
||||
|
||||
procedure TTableProducer.StartTable(Stream: TStream);
|
||||
|
||||
Var
|
||||
S : String;
|
||||
|
||||
begin
|
||||
S:='<TABLE';
|
||||
If Border then
|
||||
S:=S+' BORDER=1';
|
||||
S:=S+'/>';
|
||||
WriteString(Stream,S);
|
||||
end;
|
||||
|
||||
procedure TTableProducer.EndTable(Stream: TStream);
|
||||
begin
|
||||
WriteString(Stream,'</TABLE>'#10);
|
||||
end;
|
||||
|
||||
procedure TTableProducer.EmitFieldCell(C: TTableColumn; Stream: TStream);
|
||||
|
||||
Var
|
||||
URL : String;
|
||||
|
||||
begin
|
||||
WriteString(Stream,'<TD>');
|
||||
With C.FField Do
|
||||
begin
|
||||
URL:=C.ActionURL;
|
||||
If (URL<>'') then
|
||||
begin
|
||||
URL:=Format(C.ActionURL,[AsString]);
|
||||
WriteString(Stream,'<A HREF="%s">',[URL]);
|
||||
end;
|
||||
WriteString(Stream,AsString);
|
||||
If (URL<>'') then
|
||||
WriteString(Stream,'</A>');
|
||||
end;
|
||||
WriteString(Stream,'</TD>');
|
||||
end;
|
||||
|
||||
constructor TTableProducer.Create(AOwner : TComponent);
|
||||
begin
|
||||
Inherited Create(AOwner);
|
||||
CreateTableColumns;
|
||||
end;
|
||||
|
||||
destructor TTableProducer.Destroy;
|
||||
begin
|
||||
FTableColumns.Free;
|
||||
Inherited;
|
||||
end;
|
||||
|
||||
procedure TTableProducer.Clear;
|
||||
begin
|
||||
FTableColumns.Clear;
|
||||
If Assigned(FContents) then
|
||||
FreeAndNil(FContents);
|
||||
FBorder:=False;
|
||||
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateColumns(FieldList: TStrings);
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
FN : String;
|
||||
|
||||
begin
|
||||
For I:=0 to FDataset.FieldCount-1 do
|
||||
begin
|
||||
FN:=FDataset.Fields[I].FieldName;
|
||||
If (FieldList=Nil) or (FieldList.IndexOf(FN)<>-1) then
|
||||
With FTableColumns.Add as TTableColumn do
|
||||
begin
|
||||
FieldName:=FN;
|
||||
Caption:=FDataset.Fields[i].DisplayName;
|
||||
end;
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateColumns(FieldList: String);
|
||||
|
||||
Var
|
||||
L : TStringList;
|
||||
|
||||
begin
|
||||
If (FieldList='') then
|
||||
CreateColumns(Nil)
|
||||
else
|
||||
begin
|
||||
L:=TStringList.Create;
|
||||
try
|
||||
L.CommaText:=FieldList;
|
||||
CreateColumns(L);
|
||||
Finally
|
||||
L.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateTable(Stream: TStream);
|
||||
begin
|
||||
If FTableColumns.Count=0 then
|
||||
CreateColumns(Nil);
|
||||
BindColumns;
|
||||
StartTable(Stream);
|
||||
Try
|
||||
CreateTableHeader(Stream);
|
||||
While Not Dataset.EOF do
|
||||
begin
|
||||
CreateTableRow(Stream);
|
||||
Dataset.Next;
|
||||
end;
|
||||
Finally
|
||||
EndTable(Stream);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateTable;
|
||||
begin
|
||||
CheckContents;
|
||||
CreateTable(FContents);
|
||||
end;
|
||||
|
||||
procedure TTableProducer.CreateContent;
|
||||
begin
|
||||
CreateTable;
|
||||
end;
|
||||
|
||||
|
||||
{ TComboBoxProducer }
|
||||
|
||||
function TComboBoxProducer.GetInputName: String;
|
||||
begin
|
||||
If (FInputName='') then
|
||||
Result:=Name
|
||||
else
|
||||
Result:=FInputName;
|
||||
end;
|
||||
|
||||
constructor TComboBoxProducer.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
end;
|
||||
|
||||
destructor TComboBoxProducer.Destroy;
|
||||
begin
|
||||
Inherited;
|
||||
end;
|
||||
|
||||
procedure TComboBoxProducer.CreateItem(Stream : TStream; VF,DF : TField; Selected : Boolean);
|
||||
|
||||
Const
|
||||
SOptions : Array[Boolean] of String = ('<OPTION','<OPTION SELECTED');
|
||||
|
||||
Var
|
||||
S : String;
|
||||
|
||||
begin
|
||||
WriteString(STream,SOptions[Selected]);
|
||||
If (VF<>Nil) and (VF<>DF) then
|
||||
WriteString(Stream,' VALUE="'+VF.AsString+'"');
|
||||
WriteString(Stream,'>'+DF.AsString+#10);
|
||||
end;
|
||||
|
||||
procedure TComboBoxProducer.CreateComboBox(Stream: TStream);
|
||||
|
||||
Var
|
||||
VF,DF,SF : TField;
|
||||
|
||||
begin
|
||||
DF:=Dataset.FieldByNAme(DataField);
|
||||
if (ValueField<>'') then
|
||||
VF:=DF
|
||||
else
|
||||
VF:=Nil;
|
||||
If (Value='') then
|
||||
SF:=Nil
|
||||
else
|
||||
if VF<>NIl then
|
||||
SF:=VF
|
||||
else
|
||||
SF:=DF;
|
||||
WriteString(Stream,'<SELECT NAME="'+InputName+'">');
|
||||
Try
|
||||
While not Dataset.EOF do
|
||||
begin
|
||||
CreateItem(Stream,SF,DF,((SF<>Nil) and (SF.AsString=Value)));
|
||||
Dataset.Next;
|
||||
end;
|
||||
Finally
|
||||
WriteString(Stream,'</SELECT>');
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TComboBoxProducer.CreateComboBox;
|
||||
begin
|
||||
CheckContents;
|
||||
CreateComboBox(FContents);
|
||||
end;
|
||||
|
||||
procedure TComboBoxProducer.CreateContent;
|
||||
begin
|
||||
CreateComboBox;
|
||||
end;
|
||||
|
||||
{ THTMLProceder }
|
||||
|
||||
function THTMLProducer.GetContent: String;
|
||||
|
||||
begin
|
||||
If Assigned(FContents) then
|
||||
begin
|
||||
SetLength(Result,FContents.Size);
|
||||
If (FContents.Size>0) then
|
||||
Move(FContents,Result[1],FContents.Size);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure THTMLProducer.CheckContents;
|
||||
begin
|
||||
If Assigned(FContents) then
|
||||
FContents.Clear
|
||||
else
|
||||
FContents:=TMemoryStream.Create;
|
||||
end;
|
||||
|
||||
destructor THTMLProducer.Destroy;
|
||||
begin
|
||||
If Assigned(FContents) then
|
||||
FreeAndNil(FContents);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure THTMLProducer.ClearContent;
|
||||
begin
|
||||
If Assigned(FContents) then
|
||||
FContents.Clear;
|
||||
end;
|
||||
|
||||
procedure THTMLProducer.WriteString(S: TStream; const Value: String);
|
||||
|
||||
Var
|
||||
L : Integer;
|
||||
|
||||
begin
|
||||
L:=Length(Value);
|
||||
If L>0 then
|
||||
S.Write(Value[1],L);
|
||||
end;
|
||||
|
||||
procedure THTMLProducer.WriteString(S: TStream; const Fmt: String;
|
||||
Args: array of const);
|
||||
begin
|
||||
WriteString(S,Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
{ TDBHtmlWriter }
|
||||
|
||||
function TDBHtmlWriter.CreateTableProducer: TTableProducer;
|
||||
begin
|
||||
Result:=TTableProducer.Create(Nil);
|
||||
end;
|
||||
|
||||
procedure TDBHtmlWriter.CreateTable(Dataset: TDataset);
|
||||
|
||||
Var
|
||||
P : TTableProducer;
|
||||
|
||||
begin
|
||||
P:=CreateTableProducer;
|
||||
Try
|
||||
CreateTable(Dataset,P);
|
||||
Finally
|
||||
P.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBHtmlWriter.CreateTable(Dataset: TDataset; Producer: TTableProducer);
|
||||
begin
|
||||
Producer.Dataset:=Dataset;
|
||||
Producer.CreateTable(Self.Stream);
|
||||
end;
|
||||
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user