tshtmlgridproducer.pas

企业进销存管理系统

{*******************************************************}
{                                                       }
{       ObjectSight Visual Components                   }
{       TopGrid HTML Grid Producer                      }
{                                                       }
{       Copyright (c) 1997 - 2001, ObjectSight          }
{                                                       }
{*******************************************************}

unit tsHTMLGridProducer;

interface

{$INCLUDE TSCmpVer}

uses
  Windows, Messages, SysUtils, Classes, StdCtrls, Graphics, Controls, Forms, Dialogs,
  HTTPApp, DbWeb, TsGrid, TsDbGrid, TsCommon
  {$IFDEF TSVER_V6}, Variants {$ENDIF};

type
  TtsCustomHTMLGridProducer = class;

  TtsHTMLTableAttributes = class(TPersistent)
  private
    FBorder      : Integer;
    FCellPadding : Integer;
    FCellSpacing : Integer;
    FCustom      : String;
    FFrame       : String;
    FImageFilePath : String;
    FBorderColor : TColor;

  protected
  public
    constructor Create(Producer: TtsCustomHTMLGridProducer);
  published
    property Border: Integer read FBorder write FBorder;
    property BorderColor : TColor read FBorderColor write FBorderColor default clNone;
    property CellPadding: Integer read FCellPadding write FCellPadding;
    property CellSpacing: Integer read FCellSpacing write FCellSpacing;
    property Custom: String read FCustom write FCustom;
    property Frame: String read FFrame write FFrame;
    property ImageFilePath: String read FImageFilePath write FImageFilePath;
  end;

  TtsCustomHTMLGridProducer = class(TCustomContentProducer)
  private
    FGrid : TtsBaseGrid;
    FHeader: TStrings;
    FFooter: TStrings;
    FMaxRows : Integer;
    FDrawInfo : TtsDrawInfo;
    FTableAttributes: TtsHTMLTableAttributes;
    FOnCreateContent : TCreateContentEvent;
  protected
    procedure SetHeader(Value : TStrings);
    procedure SetFooter(Value : TStrings);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetTableAttributes(Value: TtsHTMLTableAttributes);
    function DoCreateContent: Boolean;
    function GenerateHTMLTable : String;
    function HeadingHTML : String;

    property DrawInfo: TtsDrawInfo read FDrawInfo write FDrawInfo;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Content : String; override;

    function GridFontName : String;
    function GridWidth(aGrid : TtsBaseGrid) : Integer;
    function HTMLFont(aGrid : TtsBaseGrid) : String;
    function GridFontColor : TColor;
    function GridColor : TColor;
    function GridHeadingColor : TColor;
    function GridHeadingFontColor : TColor;
    function GridHeadingFont : TFont;
    function GridCols : Integer;
    function GridHeadingHeight : Integer;
    function CellFont(dataCol : Integer; dataRow : Variant) : TFont;
    function CellFontName(dataCol : Integer; dataRow : Variant) : String;
    function CellFontColor(dataCol : Integer; dataRow : Variant) : TColor;
    function CellColor(dataCol : Integer; dataRow : Variant) : TColor;
    procedure ConfigDrawInfo;
    function TextCellHTML(iCol : Integer; dataRow : Variant) : String;
    function HTMLHeader(aCol : TtsCol) : String;
    function HTMLCell(aCol : TtsCol; forValue : String) : String;
    function ImageCellHTML(iCol : Integer; dataRow : Variant) : String;
    function CheckCellHTML(iCol : Integer; dataRow : Variant) : String;
    function AdjustCellFormat(sHTML : String; dataCol : Integer; dataRow : Variant) : String;
    function AdjustCellFormatForDrawInfo(sHTML : String) : String;
        
    property Grid: TtsBaseGrid read FGrid write FGrid;
    property Header: TStrings read FHeader write SetHeader;
    property MaxRows: Integer read FMaxRows write FMaxRows default 100;
    property Footer: TStrings read FFooter write SetFooter;
    property TableAttributes: TtsHTMLTableAttributes read FTableAttributes write SetTableAttributes;

    property OnCreateContent: TCreateContentEvent read FOnCreateContent write FOnCreateContent;
  end;

  TtsHTMLGridProducer = class(TtsCustomHTMLGridProducer)
  published
    property Grid;
    property Header;
    property MaxRows;
    property Footer;
    property TableAttributes;

    property OnCreateContent;
  end;

const
    StsHTMLFontStyle = ' style="font-family: ''FONTNAME''; font-size: FNSIZE; background: BGCOLOR; color: FNCOLOR; font-weight: FNBOLD; height: HDHEIGHTpx;"';
    StsHTMLTable     = '<Table cellspacing=CELLSPACE cellpadding=CELLPAD border="BORDERWIDTH" bordercolor= "BORDERCOLOR" frame="TABFRAME" width=TABWIDTH FONTSTYLE>';
    StsHTMLCellStyle = ' style="background-color: BGCOLOR; color: FNCOLOR;"';

function TranslateColor(aColor : TColor) : TColor;
function ColorToHex(Color: TColor): string;

//procedure Register;

implementation

{$R *.dcr}

{procedure Register;
begin
  RegisterComponents('TopGrid', [TtsHTMLGridProducer]);
end; }

function ColorToHex(Color: TColor): string;
var r,g,b: byte;
begin
  r:=GetRValue(Integer(Color));
  g:=GetGValue(Integer(Color));
  b:=GetBValue(Integer(Color));
  Result:=IntToHex(r,2)+IntToHex(g,2)+IntToHex(b,2);
end;

function TranslateColor(aColor : TColor) : TColor;
begin
  Result := aColor;
  case aColor of    //
    clBackGround    : Result := clAqua;
    clBtnFace       : Result := clSilver;
    clActiveCaption : Result := clBlack;
    clInActiveCaption : Result := clBlue;
    clMenu            : Result := clDkGray;
    clWindow          : Result := clWhite;
    clWindowFrame     : Result := clGray;
    clMenuText        : Result := clGreen ;
    clWindowText      : Result := clBlack;
    clCaptionText     : Result := clLtGray ;
    clActiveBorder    : Result := clMaroon;
    clInactiveBorder  : Result := clNavy;
    clAppWorkSpace    : Result := clOlive;
    clHighlight       : Result := clPurple;
    clHighlightText    : Result := clRed;
    clBtnShadow       : Result := clTeal;
    clGrayText        : Result := clWhite;
    clBtnText         : Result := clBlack;
    clInactiveCaptionText  : Result := clYellow;
    clBtnHighlight    : Result := clYellow;
    cl3DdkShadow      : Result := clYellow;
    cl3DLight         : Result := clYellow;
    clInfoText        : Result := clYellow;
    clInfoBk          : Result := clYellow;
  end;    // case
end;

  { TtsHTMLTableAttributes }
constructor TtsHTMLTableAttributes.Create(Producer: TtsCustomHTMLGridProducer);
begin
  inherited Create;
  FBorder := -1;
  FCellPadding := -1;
  FCellSpacing := -1;
  FFrame := 'border';
  FBorderColor := clNone;
end;

  { TtsHTMLGridProducer }
constructor TtsCustomHTMLGridProducer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFooter := TStringList.Create;
  FHeader := TStringList.Create;
  FTableAttributes := TtsHTMLTableAttributes.Create(Self);
  FDrawInfo.Font := TFont.Create;
end;

destructor TtsCustomHTMLGridProducer.Destroy;
begin
  FFooter.Free;
  FHeader.Free;
  FTableAttributes.Free;
  FDrawInfo.Font.Free;
  inherited Destroy;
end;

procedure TtsCustomHTMLGridProducer.SetHeader(Value : TStrings);
begin
  FHeader.Assign(Value);
end;

procedure TtsCustomHTMLGridProducer.SetFooter(Value : TStrings);
begin
  FFooter.Assign(Value);
end;

procedure TtsCustomHTMLGridProducer.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
  begin
    if (AComponent = FGrid) and (FGrid <> nil) then
       FGrid := Nil;
  end;
end;

procedure TtsCustomHTMLGridProducer.SetTableAttributes(Value: TtsHTMLTableAttributes);
begin
  FTableAttributes.Assign(Value);
end;

function TtsCustomHTMLGridProducer.Content: string;
begin
  Result := '';
  if (FGrid <> nil) then
  begin
    if DoCreateContent then
       Result := FHeader.Text + GenerateHTMLTable + FFooter.Text;
  end;
end;

function TtsCustomHTMLGridProducer.GridFontName : String;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).Font.Name
  else
     Result := TtsDbGrid(FGrid).Font.Name;
end;

function TtsCustomHTMLGridProducer.GridColor : TColor;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).Color
  else
     Result := TtsDbGrid(FGrid).Color;
end;

function TtsCustomHTMLGridProducer.GridFontColor : TColor;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).Font.Color
  else
     Result := TtsDbGrid(FGrid).Font.Color;
end;

function TtsCustomHTMLGridProducer.GridHeadingColor : TColor;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).HeadingColor
  else
     Result := TtsDbGrid(FGrid).HeadingColor;
end;

function TtsCustomHTMLGridProducer.GridHeadingFontColor : TColor;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).HeadingFont.Color
  else
     Result := TtsDbGrid(FGrid).HeadingFont.Color;
end;

function TtsCustomHTMLGridProducer.GridHeadingFont : TFont;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).HeadingFont
  else
     Result := TtsDbGrid(FGrid).HeadingFont;
end;

function TtsCustomHTMLGridProducer.GridCols : Integer;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).Cols
  else
     Result := TtsDbGrid(FGrid).Cols;
end;

function TtsCustomHTMLGridProducer.GridHeadingHeight : Integer;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).HeadingHeight
  else
     Result := TtsDbGrid(FGrid).HeadingHeight;
end;

function TtsCustomHTMLGridProducer.CellFont(dataCol : Integer; dataRow : Variant) : TFont;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).CellFont[dataCol, dataRow]
  else
     Result := TtsDbGrid(FGrid).CellFont[dataCol, dataRow];
end;

function TtsCustomHTMLGridProducer.CellFontName(dataCol : Integer; dataRow : Variant) : String;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).CellFont[dataCol, dataRow].Name
  else
     Result := TtsDbGrid(FGrid).CellFont[dataCol, dataRow].Name;
end;

function TtsCustomHTMLGridProducer.CellColor(dataCol : Integer; dataRow : Variant) : TColor;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).CellColor[dataCol, dataRow]
  else
     Result := TtsDbGrid(FGrid).CellColor[dataCol, dataRow];
end;

function TtsCustomHTMLGridProducer.CellFontColor(dataCol : Integer; dataRow : Variant) : TColor;
begin
  if FGrid is TtsGrid then
     Result := TtsGrid(FGrid).CellFont[dataCol, dataRow].Color
  else
     Result := TtsDbGrid(FGrid).CellFont[dataCol, dataRow].Color;
end;

function TtsCustomHTMLGridProducer.DoCreateContent: Boolean;
begin
  Result := True;
  if Assigned(FOnCreateContent) then
     FOnCreateContent(Self, Result);
end;

procedure TtsCustomHTMLGridProducer.ConfigDrawInfo;
begin
  FDrawInfo.Color := GridColor;
  FDrawInfo.Font.Color := GridFontColor;
  FDrawInfo.Font.Name := GridFontName;
end;

function TtsCustomHTMLGridProducer.CheckCellHTML(iCol : Integer; dataRow : Variant) : String;
var sChecked, sCloseP : String;
    theCol : TtsCol;
begin
  Result := '<td>';
  sChecked := '';
  sCloseP := '';
  if FGrid is TtsGrid then
  begin
    theCol := TtsGrid(FGrid).Col[iCol];
    if TtsGrid(FGrid).CellCheckBoxState[iCol, dataRow] = cbChecked then
       sChecked := 'Checked';
  end
  else
  begin
    theCol := TtsDbGrid(FGrid).Col[iCol];
    if (VarToStr(TtsDbGrid(FGrid).Cell[iCol, dataRow]) <> '') and
       (VarToStr(TtsDbGrid(FGrid).Cell[iCol, dataRow]) <> '0') then
       sChecked := 'Checked';
  end;
  if theCol.Alignment = taCenter then
  begin
     Result := Result + '<p align="center">';