fpc/fcl/db/dbwhtml.pp
2004-10-16 09:20:25 +00:00

713 lines
17 KiB
ObjectPascal

{
$Id$
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2000 by the Free Pascal development team
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
{$H+}
unit dbwhtml;
Interface
uses sysutils,classes,db,whtml;
Type
THTMLAlign = (haDefault,haLeft,haRight,haCenter); // Compatible with Delphi.
THTMLVAlign = (haVDefault,haTop,haMiddle,haBottom,haBaseLine); // Compatible with Delphi.
TGetCellContentsEvent = Procedure (Sender : TObject; Var CellData : String) of object;
TCellAttributesEvent = Procedure (Sender : TObject;
Var BGColor : String;
Var Align : THTMLAlign;
Var VAlign : THTMLValign;
Var CustomAttr : String) of Object;
TRowAttributesEvent = Procedure (Sender : TObject;
Var BGColor : String;
Var Align : THTMLAlign;
Var VAlign : THTMLValign;
Var CustomAttr : String) of Object;
TRowAttributes = Class(TPersistent)
Private
FAlign : THTMLAlign;
FVAlign : THTMLVAlign;
FBGColor : String;
FCustom : String;
Public
Procedure Assign(Source : TPersistent); Override;
Property Align : THTMLAlign Read FAlign Write FAlign;
Property BGColor : String Read FBGColor Write FBGColor;
Property Custom : String Read FCustom Write FCustom;
Property VAlign : THTMLVAlign Read FVAlign Write FVAlign;
end;
TTableColumn = Class(TCollectionItem)
private
FActionUrl: String;
FAlign: THTMLAlign;
FVAlign : THTMLVAlign;
FBGColor: String;
FCaptionURL: String;
FFieldName : String;
FCaption : String;
FGetColumn: String;
FGetCellContent : TGetCellContentsEvent;
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;
Property VAlign : THTMLVAlign Read FValign Write FVAlign;
Property OnGetCellContents : TGetCellContentsEvent Read FGetCellContent Write FGetCellContent;
end;
TTableColumns = Class(TCollection)
Constructor Create;
private
function GetColumn(Index : Integer): TTableColumn;
procedure SetColumn(Index : Integer; const AValue: TTableColumn);
Public
Function FindColumn(ColumnName : String) : TTableColumn;
Function ColumnByName(ColumnName : String) : TTableColumn;
Property Items[Index : Integer] : TTableColumn Read GetColumn Write SetColumn;
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
FGetRowAttrs: TRowAttributesEvent;
FRowAttributes: TRowAttributes;
FTableColumns : TTableColumns;
FBorder : Boolean;
FBGColor : String;
FCurrentRow : Integer;
FCurrentCol : Integer;
FGetCellAttrs : TCellAttributesEvent;
procedure SetRowAttributes(const AValue: TRowAttributes);
Procedure SetTableColumns(Value : TTableColumns);
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;
Function CreateAttr(Const ABGColor : String; A : THTMLAlign; VA : THTMLVAlign; CustomAttr : String) : String;
Procedure Clear;
Procedure CreateColumns(FieldList : TStrings);
Procedure CreateColumns(FieldList : String);
Procedure CreateTable(Stream : TStream);
Procedure CreateTable;
Procedure CreateContent; override;
Property CurrentRow : Integer Read FCurrentRow;
Property CurrentCol : Integer Read FCurrentCol;
Published
Property BGColor : String Read FBGColor Write FBGColor;
Property Border : Boolean Read FBorder Write FBorder;
Property RowAttributes : TRowAttributes Read FRowAttributes Write SetRowAttributes;
Property TableColumns : TTableColumns Read FTableColumns Write SetTableColumns;
Property OnGetCellAttributes : TCellAttributesEvent Read FGetCellAttrs write FGetCellAttrs;
Property OnGetRowAttributes : TRowAttributesEvent Read FGetRowAttrs write FGetRowAttrs;
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;
EDBWriter = Class(Exception);
Implementation
uses dbconst;
{ TTableColumns }
constructor TTableColumns.Create;
begin
inherited Create(TTableColumn);
end;
function TTableColumns.GetColumn(Index : Integer): TTableColumn;
begin
Result:=TTableColumn(Inherited Items[Index]);
end;
procedure TTableColumns.SetColumn(Index : Integer; const AValue: TTableColumn);
begin
Inherited Items[Index]:=AValue;
end;
function TTableColumns.FindColumn(ColumnName: String): TTableColumn;
Var
I : Integer;
begin
Result:=Nil;
I:=Count-1;
While (I>=0) and (CompareText(Items[i].FieldName,ColumnName)<>0) do
Dec(I);
If (I>=0) then
Result:=Items[I];
end;
function TTableColumns.ColumnByName(ColumnName: String): TTableColumn;
begin
Result:=FindColumn(ColumnName);
If (Result=Nil) then
Raise EDBWriter.CreateFmt(SErrColumnNotFound,[ColumnName]);
end;
{ TTableProducer }
procedure TTableProducer.BindColumns;
Var
I : Integer;
begin
With FTableColumns do
For I:=0 to Count-1 do
With TTableColumn(Items[I]) do
If (FieldName<>'') then
FField:=FDataset.FieldByName(FieldName)
else
FField:=Nil;
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
begin
FCurrentCol:=I;
CreateHeaderCell(TTableColumn(Items[I]),Stream);
end;
WriteString(Stream,'</TR>'#10);
end;
procedure TTableProducer.CreateHeaderCell(C: TTableColumn; Stream: TStream);
Var
URL : String;
begin
WriteString(Stream,'<TH>');
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,'</TH>');
end;
procedure TTableProducer.CreateTableRow(Stream : TStream);
Var
I : Integer;
BG : String;
A : THTMLAlign;
VA : THTMLVAlign;
RTAG,CustA : String;
begin
With FRowAttributes do
begin
BG:=FBGColor;
A:=FAlign;
VA:=VAlign;
CustA:=FCustom;
end;
If Assigned(FGetRowAttrs) then
FGetRowAttrs(Self,BG,A,VA,CustA);
RTAG:=CreateAttr(BG,A,VA,CustA);
If (RTAG='') then
RTag:='<TR>'
else
RTag:='<TR '+RTag+'>';
WriteString(Stream,RTag);
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';
If (BGColor<>'') then
S:=S+'BGCOlor="'+BGColor+'"';
S:=S+'>';
WriteString(Stream,S);
end;
procedure TTableProducer.EndTable(Stream: TStream);
begin
WriteString(Stream,'</TABLE>'#10);
end;
Function TTableProducer.CreateAttr(Const ABGColor : String; A : THTMLAlign; VA : THTMLVAlign; CustomAttr : String) : String;
Const
HAligns : Array[THTMLAlign] of string = ('','"left"','"right"','"center"');
VAligns : Array[THTMLVAlign] of string = ('','"top"','"middle"','"bottom"','"baseLine"');
begin
Result:='';
If (ABGColor<>'') then
Result:='BGColor="'+ABGColor+'"';
If (A<>haDefault) then
Result:=Result+' Align='+HAligns[A];
if (VA<>haVDefault) then
Result:=Result+' Align='+VAligns[VA];
If (CustomAttr<>'') then
Result:=Result+' '+CustomAttr;
end;
procedure TTableProducer.EmitFieldCell(C: TTableColumn; Stream: TStream);
Var
URL : String;
BG : String;
A : THTMLAlign;
VA : THTMLVAlign;
CellA,CustA : String;
begin
BG:=C.BGColor;
A:=C.Align;
VA:=C.Valign;
CustA:='';
If Assigned(FGetCellAttrs) then
FGetCellAttrs(Self,BG,A,VA,CustA);
CellA:=CreateAttr(BGColor,A,VA,CustA);
If (CellA='') then
CellA:='<TD>'
else
CellA:='<TD '+CellA+'>';
WriteString(Stream,CellA);
// Reuse for contents.
CellA:='';
If (C.FField<>Nil) then
CellA:=C.FField.AsString;
If Assigned(C.FGetCellContent) then
C.FGetCellContent(Self,CellA);
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,CellA);
If (URL<>'') then
WriteString(Stream,'</A>');
end;
WriteString(Stream,'</TD>');
end;
constructor TTableProducer.Create(AOwner : TComponent);
begin
Inherited Create(AOwner);
FRowAttributes:=TRowAttributes.Create;
CreateTableColumns;
FCurrentRow:=-1;
FCurrentCol:=-1;
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
FCurrentRow:=0;
CreateTableHeader(Stream);
While Not Dataset.EOF do
begin
Inc(FCurrentRow);
CreateTableRow(Stream);
Dataset.Next;
end;
Finally
EndTable(Stream);
FCurrentRow:=-1;
FCurrentCol:=-1;
end;
end;
procedure TTableProducer.CreateTable;
begin
CheckContents;
CreateTable(FContents);
end;
procedure TTableProducer.CreateContent;
begin
CreateTable;
end;
Procedure TTableProducer.SetTableColumns(Value : TTableColumns);
begin
FTableColumns.Assign(Value);
end;
procedure TTableProducer.SetRowAttributes(const AValue: TRowAttributes);
begin
if (FRowAttributes=AValue) then
exit;
FRowAttributes.Assign(AValue);
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:=Dataset.FieldByName(ValueField)
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,VF,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;
{ TRowAttributes }
Procedure TRowAttributes.Assign(Source : TPersistent);
Var
R : TRowAttributes;
begin
If Source is TRowAttributes then
begin
R:=TRowAttributes(Source);
FAlign:=R.FAlign;
FBGColor:=R.FBGColor;
FCustom:=R.FCustom;
FVAlign:=R.FVAlign;
end
else
Inherited Assign(Source)
end;
end.
{
$Log$
Revision 1.7 2004-10-16 09:20:25 michael
+ Moved resourcestrings to dbconst
Revision 1.6 2003/10/28 08:42:01 michael
+ Added ColumnByName method to TTAbleColumns
Revision 1.4 2003/10/03 22:43:17 michael
+ Published tablecolumns property in tableproducer
Revision 1.3 2003/10/03 08:42:22 michael
+ Form support.
Revision 1.2 2003/10/01 21:07:48 michael
+ Added log/header
}