cxhtmlxmltxtexport.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,750 行 · 第 1/4 页

{*******************************************************************}
{                                                                   }
{       Developer Express Cross Platform Component Library          }
{       ExpressExport                                               }
{                                                                   }
{       Copyright (c) 2001-2008 Developer Express Inc.              }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{   The entire contents of this file is protected by U.S. and       }
{   International Copyright Laws. Unauthorized reproduction,        }
{   reverse-engineering, and distribution of all or any portion of  }
{   the code contained in this file is strictly prohibited and may  }
{   result in severe civil and criminal penalties and will be       }
{   prosecuted to the maximum extent possible under the law.        }
{                                                                   }
{   RESTRICTIONS                                                    }
{                                                                   }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES           }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE    }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS   }
{   LICENSED TO DISTRIBUTE THE EXPRESSEXPORT AND ALL                }
{   ACCOMPANYING VCL AND CLX CONTROLS AS PART OF AN EXECUTABLE      }
{   PROGRAM ONLY.                                                   }
{                                                                   }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED      }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE        }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE       }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT  }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                      }
{                                                                   }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON       }
{   ADDITIONAL RESTRICTIONS.                                        }
{                                                                   }
{*******************************************************************}
unit cxHtmlXmlTxtExport;

{$I cxVer.inc}

interface
uses
  SysUtils, Math, Classes,
  Windows,
{$IFDEF DELPHI6} Variants, {$IFNDEF NONDB} FMTBcd, SqlTimSt, {$ENDIF} {$ENDIF}
  cxExport, cxExportStrs, Graphics;

type
  { TcxCustomHtmlXmlTXTExportProvider }
  TcxCustomHtmlXmlTXTExportProvider = class(TcxCustomExportProvider, IcxExportProvider)
  private
    FCache: array of array of TcxCacheItem;
    FColumns: array of Integer;
    FDefaultStyle: TcxCacheCellStyle;
    FInternalCacheList: TInterfaceList;
    FName: string;
    FRows: array of Integer;
    FStyleManager: TcxExportStyleManager;
    function GetCacheItem(ACol, ARow: Integer): TcxCacheItem;
    function GetCellHeight(ACol, ARow: Integer): Integer;
    function GetCellWidth(ACol, ARow: Integer): Integer;
    function GetColumns(ACol: Integer): Integer;
    function GetDefaultStyle: PcxCacheCellStyle;
    function GetHeight: Integer;
    function GetInternalCacheCount: Integer;
    function GetInternalCacheItems(AIndex: Integer): IcxCellInternalCache;
    function GetRows(ARow: Integer): Integer;
    function GetStyleCount: Integer;
    function GetWidth: Integer;
    procedure TestIndex(ACol, ARow: Integer);
    procedure TestCol(ACol: Integer);
    procedure TestRow(ARow: Integer);
    procedure TestStyleIndex(AStyleIndex: Integer);
  protected
    procedure Clear; override;
    function GetCellData(const ACol, ARow: Integer; var AData): Boolean;
    procedure SetData(const ACol, ARow, ADataSize, ADataType: Integer; const AData);
    procedure SetEmptyData(const ACol, ARow, ADataType: Integer);
    procedure Commit; dynamic;
    function GetCacheName: string;
    function GetCellStyle(const ACol, ARow: Integer): PcxCacheCellStyle;
    function GetExportType: Integer;
    function GetExportName: string;
    function GetStyle(AStyleIndex: Integer): PcxCacheCellStyle;
    function RegisterStyle(const AStyle: TcxCacheCellStyle): Integer;
    procedure SetCellDataString(const ACol, ARow: Integer; const AText: string); virtual;
    procedure SetCellDataWideString(const ACol, ARow: Integer; const AText: Widestring); virtual;
    procedure SetCellDataDouble(const ACol, ARow: Integer; const AValue: Double); virtual;
    procedure SetCellDataInteger(const ACol, ARow: Integer; const AValue: Integer); virtual;
    procedure SetCellStyle(const ACol, ARow, AStyleIndex: Integer); overload; virtual;
    procedure SetCellStyle(const ACol, ARow, AExampleCol, AExampleRow: Integer); overload; virtual;
    procedure SetCellStyle(const ACol, ARow: Integer; const AStyle: TcxCacheCellStyle); overload; virtual;
    procedure SetCellStyleEx(const ACol, ARow, H, W: Integer; const AStyleIndex: Integer);
    procedure SetCellUnion(const ACol, ARow: Integer; H, W: Integer);
    procedure SetCellValue(const ACol, ARow: Integer; const AValue: Variant);
    procedure SetColumnWidth(const ACol, AWidth: Integer);
    procedure SetDefaultStyle(const AStyle: TcxCacheCellStyle);
    procedure SetRange(const AColCount, ARowCount: Integer; IsVisible: Boolean = True);
    procedure SetRowHeight(const ARow, AHeight: Integer);
    // export graphic extension
    procedure SetCellDataGraphic(const ACol, ARow: Integer; var AGraphic: TGraphic);
    function SupportGraphic: Boolean; virtual;

    property Cache[ACol, ARow: Integer]: TcxCacheItem read GetCacheItem;
    property Columns[ACol: Integer]: Integer read GetColumns;
    property DefaultStyle: PcxCacheCellStyle read GetDefaultStyle;
    property RowCount: Integer read GetHeight;
    property InternalCacheCount: Integer read GetInternalCacheCount;
    property InternalCacheItems[AIndex: Integer]: IcxCellInternalCache read GetInternalCacheItems;
    property Name: string read FName write FName;
    property Rows[ARow: Integer]: Integer read GetRows;
    property StyleCount: Integer read GetStyleCount;
    property Styles[AIndex: Integer]: PcxCacheCellStyle read GetStyle;
    property CellHeight[ACol, ARow: Integer]: Integer read GetCellHeight;
    property CellWidth[ACol, ARow: Integer]: Integer read GetCellWidth;
    property ColCount: Integer read GetWidth;
  public
    constructor Create(const AFileName: string); override;
    destructor Destroy; override;
  end;

  { TcxCustomExportProviderSupportedCellInternalChache }
  TcxCustomExportProviderSupportedCellInternalChache = class(TcxCustomHtmlXmlTXTExportProvider, IcxCellInternalCache)
  protected
    procedure CommitCache(AStream: TStream; AParam: Pointer); virtual;
    procedure CommitStyle(AStream: TStream; AParam: Pointer); virtual;
    procedure DeleteCacheFromCell(const ACol, ARow: Integer);
    procedure SetCacheIntoCell(const ACol, ARow: Integer; ACache: IcxCellInternalCache);
    procedure SetEmptyCellsStyle;
  end;

  { TcxHTMLExportProvider }
  TcxHTMLExportProvider = class(TcxCustomExportProviderSupportedCellInternalChache)
  private
    procedure CommitHTML(AStream: TStream);
    function GetStyle(AStyle: TcxCacheCellStyle): string;
    function GetScaleRow: string;
  protected
    procedure CommitCache(AStream: TStream; AParam: Pointer); override;
    procedure CommitStyle(AStream: TStream; AParam: Pointer); override;
    function GetContentWidth: Integer;
  public
    procedure Commit; override;
    class function ExportType: Integer; override;
    class function ExportName: string; override;
  end;

  { TcxXMLExportProvider }
  TcxXMLExportProvider = class(TcxCustomExportProviderSupportedCellInternalChache)
  private
    FHideDotsOn: Boolean;
    FXSLFileName: WideString;
    procedure CommitXML(AStream: TStream);
    procedure CommitXSL(AStream: TStream);
    function ConvertTextToXML(const AText: string; ACol, ARow: Integer): string;
    function GetBorderStyle(AStyle: TcxCacheCellStyle): string;
    function GetCellParams(ACol, ARow: Integer): string;
    function GetData(ACol, ARow: Integer): string;
    function GetStyle(AStyle: TcxCacheCellStyle): string;
    procedure HideDots;
    function GetScaleLine: string;
  protected
    procedure CommitCache(AStream: TStream; AParam: Pointer); override;
    procedure CommitStyle(AStream: TStream; AParam: Pointer); override;
  public
    constructor Create(const AFileName: string); override;
    procedure Commit; override;
    class function ExportType: Integer; override;
    class function ExportName: string; override;
  end;

  { TcxTXTExportProvider }
  TcxTXTExportProvider = class(TcxCustomExportProviderSupportedCellInternalChache, IcxExportWithSeparators)
  private
    FBeginString: string;
    FColMaxWidth: array of Integer;
    FEndString: string;
    FIndex: Integer;
    FSeparator: string;
    procedure CalculateColMaxWidth;
    function GetData(ACol, ARow: Integer): string;
  protected
    procedure AddSeparator(const ASeparator: string);
    procedure CommitCache(AStream: TStream; AParam: Pointer); override;
    function SupportGraphic: Boolean; override;
  public
    constructor Create(const AFileName: string); override;
    procedure Commit; override;
    class function ExportType: Integer; override;
    class function ExportName: string; override;
  end;

const
  cxXMLEmptyChar = '.';
  cxExportDefaultEmptyString: string = '&nbsp';

implementation

function HasBorders(ACellStyle: PcxCacheCellStyle): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to 3 do
    Result := Result or (ACellStyle.Borders[I].Width > 0);
end;

function DirExist(const ADirectory: string): Boolean;
{$IFNDEF DELPHI6}
var
  ACode: Integer;
{$ENDIF}
begin
{$IFDEF DELPHI6}
  Result := DirectoryExists(ADirectory);
{$ELSE}
  ACode := GetFileAttributes(PChar(ADirectory));
  Result := (ACode <> -1) and (FILE_ATTRIBUTE_DIRECTORY and ACode <> 0);
{$ENDIF}
end;

function GraphicNeeded(const ADir, AGraphicData: string; AddTags: Boolean = True): string;
var
  F: File;
  AGraphicStream: string;
begin
  GetTextAsGraphicStream(AGraphicData, Result, AGraphicStream);
  if not DirExist(ExtractFileDir(Result)) then
    CreateDir(ExtractFileDir(Result));
  AssignFile(F, Result);
  Rewrite(F, 1);
  try
    BlockWrite(F, AGraphicStream[1], Length(AGraphicStream));
  finally
    CloseFile(F);
  end;
  Delete(Result, 1, Length(ADir));
  while Pos('\', Result) <> 0 do
    Result[Pos('\', Result)] := '/';
  if AddTags then
    Result := '<img src="' + Result + '"></img>';
end;

function GetHTMLColor(AColor: Integer): string;
begin
  Result := 'rgb(' + IntToStr(AColor and $FF) + ',' +
    IntToStr(Byte(AColor shr 8)) + ',' + IntToStr(Byte(AColor shr 16)) +  ')';
end;

function ConvertCRLFSymbols(const AString: string): string;
var
  I: Integer;
begin
  Result := '';
  for I := 1 to Length(AString) do
  begin
    if AString[I] = #13 then
    begin
      if I < Length(AString) then
        if AString[I + 1] = #10 then
        begin
          Result := Result + '<BR>';
          Continue;
        end;
    end
    else if AString[I] = #10 then
    begin
      if I > 1 then
      begin
        if AString[I - 1] <> #13 then
          Result := Result + '<BR>';
      end
      else
        Result := Result + '<BR>';
      Continue;
    end;
    Result := Result + AString[I];
  end;
end;

function ConvertSpecialCharacters(const AString: string): string;
var
  I: Integer;
begin
  Result := '';
  for I := 1 to Length(AString) do
  begin
   if AString[I] = '<' then
     Result := Result + '&lt;'
   else if AString[I] = '>' then
     Result := Result + '&gt;'
   else if AString[I] = '&' then
     Result := Result + '&amp;'
   else if AString[I] = '"' then
     Result := Result + '&quot;'
   else
     Result := Result + AString[I];
  end;
end;

function CheckedUnicodeString(const S: string; ACharset: Integer = 0): string;
var
  I: Integer;
  W: WideString;
begin
  if cxStrUnicodeNeeded(S, True) then
  begin
    W := cxStrToUnicode(S, ACharset);
    Result := '';
    for I := 1 to Length(W) do
      Result := Result + '&#' + IntToStr(Integer(W[I])) + ';';
  end
  else
    Result := S;
end;

function CheckedUnicodeStringW(const S: WideString): string;
var
  I: Integer; 
begin
  if cxUnicodeSupported then
  begin
    Result := '';
    for I := 1 to Length(S) do
      Result := Result + '&#' + IntToStr(Integer(S[I])) + ';';
  end
  else
    Result := cxUnicodeToStr(S);
end;

{ TcxCustomHtmlXmlTXTExportProvider }
constructor TcxCustomHtmlXmlTXTExportProvider.Create(const AFileName: string);
begin
  inherited Create(AFileName);
  FDefaultStyle := DefaultCellStyle;
  FInternalCacheList := TInterfaceList.Create;
  FStyleManager := TcxExportStyleManager.GetInstance(AFileName);
  FName := '';
  UseGraphicImages(True);
end;

destructor TcxCustomHtmlXmlTXTExportProvider.Destroy;
begin
  UseGraphicImages(False);
  FInternalCacheList.Free;
  FStyleManager.Clear;
  inherited Destroy;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.Clear;
var
  I, J: Integer;
begin
  for I := 0 to Length(FCache) - 1 do
    for J := 0 to Length(FCache[I]) - 1 do
    try
      with FCache[I, J] do
        ReallocMem(FCache[I, J].Data, 0);
    finally
      FCache[I, J].Data := nil;
      FCache[I, J].InternalCache.Cache := nil;
      FCache[I, J].InternalCache.Index := -1;
    end;

  FInternalCacheList.Clear;
  SetLength(FCache, 0, 0);
  SetLength(FColumns, 0);
  SetLength(FRows, 0);
end;

function TcxCustomHtmlXmlTXTExportProvider.GetCacheName: string;
begin
  Result := FName;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetCellData(const ACol, ARow: Integer; var AData): Boolean;
begin
  TestIndex(ACol, ARow);

  with FCache[ACol, ARow] do
  begin
    Result := Data <> nil;
    if Result then
      Move(Data^, AData, DataSize);
  end;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetCellStyle(const ACol,
  ARow: Integer): PcxCacheCellStyle;
begin
  TestIndex(ACol, ARow);
  with FCache[ACol, ARow] do
  begin
    if StyleIndex < 0 then
      Result := @FDefaultStyle
    else
      Result := FStyleManager.GetStyle(StyleIndex);
  end;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetExportType: Integer;
begin
  Result := ExportType;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetExportName: string;
begin
  Result := ExportName;
end;

function TcxCustomHtmlXmlTXTExportProvider.RegisterStyle(const AStyle: TcxCacheCellStyle): Integer;
begin
  Result := FStyleManager.RegisterStyle(AStyle)
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellDataString(const ACol, ARow: Integer; const AText: string);
begin
  if AText <> '' then
    SetData(ACol, ARow, Length(AText), cxDataTypeString, AText[1])
  else
    SetEmptyData(ACol, ARow, cxDataTypeString);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellDataWideString(const ACol, ARow: Integer; const AText: Widestring);
begin
  if AText <> '' then
    SetData(ACol, ARow, Length(AText)*2, cxDataTypeWideString, AText[1])
  else
    SetEmptyData(ACol, ARow, cxDataTypeWideString);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellDataDouble(const ACol, ARow: Integer; const AValue: Double);
begin
  SetData(ACol, ARow, Sizeof(Double), cxDataTypeDouble, AValue);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellDataInteger(const ACol, ARow: Integer; const AValue: Integer);
begin
  SetData(ACol, ARow, Sizeof(Integer), cxDataTypeInteger, AValue);
end;