cxexport.pas

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

{*******************************************************************}
{                                                                   }
{       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 cxExport;

{$I cxVer.inc}

interface

uses
  Classes, SysUtils, Math,
  {$IFDEF WIN32}
  Windows,
  {$ENDIF}
  Graphics, cxExportStrs;

type
  EcxExportData = class(Exception);
  TcxExportProviderClass = class of TcxCustomExportProvider;
  TcxCustomExportProvider = class;
  IcxCellInternalCache = interface;

  PWord =^Word;
  PInteger =^Integer;
  PIntArray = ^TIntArray;
  TIntArray = array[0..MaxInt div SizeOf(Integer) - 1] of Integer;

  { Define  CX  style items }            
  TcxAlignText = (catLeft, catCenter, catRight);
  TcxBrushStyle = (cbsClear, cbsSolid);
  TcxFontStyle = (cfsBold, cfsItalic, cfsUnderline, cfsStrikeOut);
  TcxFontStyles = set of TcxFontStyle;

  { TcxCellBorders }
  TcxCellBorders = packed record
    IsDefault: Boolean;
    Width: Integer;
    Color: Integer;
  end;

  { TcxCacheCellStyle }
  PcxCacheCellStyle = ^TcxCacheCellStyle;
  TcxCacheCellStyle = packed record
    AlignText: TcxAlignText;
    FontName: array[0..32] of Char;
    FontStyle: TcxFontStyles;
    FontColor: Integer;
    FontSize: Integer;
    FontCharset: Integer;
    Borders: array[0..3] of TcxCellBorders;
    BrushStyle: TcxBrushStyle;
    BrushBkColor: Integer;
    BrushFgColor: Integer;
    HashCode: Integer;
  end;

  { TcxCellInternalCache }
  TcxCellInternalCache = record
    Cache: IcxCellInternalCache;
    Index: Integer;
  end;

  { TcxCacheItem }
  TcxCacheItem = record
    InternalCache: TcxCellInternalCache;
    Data: Pointer;
    DataSize: Integer;
    DataType: Integer;
    StyleIndex: Integer;
    IsHidden: Boolean;
    case IsUnion: Boolean of
      False:();
      True: (Width, Height: Integer);
  end;

  TcxEnumExportTypes = procedure(const AExportType: Integer; const AExportName: string);
  TcxEnumTypes = procedure(const AExportType: Integer);

  { IcxCellInternalCache }
  IcxCellInternalCache = interface
  ['{DEF62C25-0B11-4BD0-AE25-BABF7EDD7883}']
    procedure CommitCache(AStream: TStream; AParam: Pointer);
    procedure CommitStyle(AStream: TStream; AParam: Pointer);
    procedure DeleteCacheFromCell(const ACol, ARow: Integer);
    procedure SetCacheIntoCell(const ACol, ARow: Integer; ACache: IcxCellInternalCache);
  end;

  { TcxExportProvider }
  IcxExportProvider = interface
  ['{442A08A8-CDDA-4FD6-8E15-9D8BD34554F6}']
    procedure Commit;
    function GetCellStyle(const ACol, ARow: Integer): PcxCacheCellStyle;
    function GetStyle(AStyleIndex: Integer): PcxCacheCellStyle;
    function RegisterStyle(const AStyle: TcxCacheCellStyle): Integer;
    procedure SetCellDataDouble(const ACol, ARow: Integer; const AValue: Double);
    procedure SetCellDataInteger(const ACol, ARow: Integer; const AValue: Integer);
    procedure SetCellDataString(const ACol, ARow: Integer; const AText: string);
    procedure SetCellDataWideString(const ACol, ARow: Integer; const AText: Widestring);
    procedure SetCellStyle(const ACol, ARow, AStyleIndex: Integer); overload;
    procedure SetCellStyle(const ACol, ARow, AExampleCol, AExampleRow: Integer); overload;
    procedure SetCellStyle(const ACol, ARow: Integer; const AStyle: TcxCacheCellStyle); overload;
    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;
  end;

  { IcxExportWithSeparators }
  IcxExportWithSeparators = interface
  ['{0E2919A6-8B49-49D7-B55B-B44B6DECF2E5}']
    procedure AddSeparator(const ASeparator: string);
  end;

  { TcxCustomExportProvider }
  TcxCustomExportProvider = class(TInterfacedObject)
  private
    FFileName: WideString;
  protected
    procedure Clear; dynamic;
    property FileName: WideString read FFileName;
  public
    constructor Create(const AFileName: string); virtual;
    procedure BeforeDestruction; override;
    class function ExportType: Integer; virtual;
    class function ExportName: string; virtual;
  end;

  { TcxExport }
  TcxExport = class
  protected
    class function GetExportClassByType(
      AExportType: Integer): TcxExportProviderClass; virtual;
  public
    class function Provider(AExportType: Integer;
      const AFileName: string): TcxCustomExportProvider;
    class procedure SupportExportTypes(EnumSupportTypes: TcxEnumExportTypes);
    class procedure SupportTypes(EnumFunc: TcxEnumTypes);
    class function RegisterProviderClass(AProviderClass: TcxExportProviderClass): Boolean;
  end;

  { TcxExportStyleManager }
  TcxExportStyleManager = class
  private
    FRefCount: Integer;
    FStyles: TList;
    FFileName: string;
    constructor CreateInstance(const AFileName: string);
    function GetCount: Integer;
    function GetItem(AIndex: Integer): TcxCacheCellStyle;
    function StyleCompare(const AStyle1, AStyle2: PcxCacheCellStyle): Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    class function GetInstance(const AFileName: string): TcxExportStyleManager;
    function GetStyle(const AIndex: Integer): PcxCacheCellStyle;
    function RegisterStyle(const AStyle: TcxCacheCellStyle): Integer;
    property Items[AIndex: Integer]: TcxCacheCellStyle read GetItem; default;
    property Count: Integer read GetCount;
  end;

  { TFileStreamEx }
  
  TFileStreamEx = class(TFileStream)
  public
    constructor Create(const FileName: string; Mode: Word); overload;
  end;

  TFileStreamClass = class of TFileStream;

  { TcxExportIntList }

  TcxExportIntList = class(TList)
  private
    function GetItem(AIndex: Integer): Integer;
    procedure SetItem(AIndex, AValue: Integer);
  public
    procedure Add(AValue: Integer);
    procedure AddPairs(AValue1, AValue2: Integer);
    function Last: Integer;
    function First: Integer;

    property Items[Index: Integer]: Integer read GetItem write SetItem; default;
  end;

  { TcxExportScale }
  
  TcxExportScale = class(TcxExportIntList)
  private
    function GetVisibleCount: Integer;
    function GetDelta(AIndex: Integer): Integer;
  public
    procedure Arrange;
    function IndexOf(AItem: Integer): Integer;
    function IndexOfEx(AValue, AFirstIndex, ALastIndex: Integer): Integer;
    procedure GetPosition(AValue1, AValue2: Integer; out AIndex1, AIndex2: Integer);
    procedure GetPositionEx(AValue1, AValue2, AFirstIndex, ALastIndex: Integer; out AIndex1, AIndex2: Integer);

    property Delta[Index: Integer]: Integer read GetDelta;
    property VisibleCount: Integer read GetVisibleCount;
  end;

  TcxColorToRgbProc = function(AColor: Integer): Integer;
  TcxGetResourceStringProc = function(const ResString: Pointer): string;

// unicode supported function prototypes

function cxUnicodeToStr(const AText: WideString; ACharset: Integer = 0): string;
function cxStrToUnicode(const AText: string; ACharset: Integer = 0): Widestring;
function cxStrUnicodeNeeded(const AText: string; ACheckNormal: Boolean = False): Boolean;

function cxChangeFileExtExW(const AFileName: WideString; const ANewExt: string): WideString;
function cxExtractFileNameEx(const AFileName: string): WideString;
function cxExtractFileNameExW(const AFileName: WideString): WideString;
function cxExtractFilePathExW(const AFileName: WideString): WideString;
function cxValidateFileName(const AFileName: string): WideString;
function cxValidateFileNameW(const AFileName: WideString): WideString;

{$IFNDEF DELPHI5}
procedure FreeAndNil(var Obj);
function Supports(Instance: TObject; const Intf: TGUID; out Inst): Boolean;
{$ENDIF}

function cxColorToRGB(const AColor: Integer): Integer;
function GetHashCode(const Buffer; Count: Integer): Integer;

function SupportGraphic(AGraphic: TGraphic): Boolean; overload;
function SupportGraphic(AGraphicClass: TGraphicClass): Boolean; overload;

procedure GetGraphicAsText(const AFileName: string;
  var AGraphic: TGraphic; var AGraphicText: string);
procedure GetTextAsGraphicStream(const AText: string; var AFileName, AStream: string);

procedure cxExportInit(AGetResString: TcxGetResourceStringProc;
  AColorProc: Pointer; AIsNativeColor: Boolean);

procedure UseGraphicImages(AUse: Boolean);

var
  DefaultCellStyle: TcxCacheCellStyle;
  cxFileStreamClass: TFileStreamClass = TFileStreamEx;
  cxBlackColor: Integer;
  cxWindowColor: Integer;
  cxBtnTextColor: Integer;
  cxBtnShadowColor: Integer;
  cxBtnFaceColor: Integer;
  cxGetResString: TcxGetResourceStringProc;
  cxUnicodeSupported: Boolean;

const
  cxExportGraphicClass: TGraphicClass = TBitmap;
  cxExportToBinary = Integer($FFFFFFFF);
  cxExportToHtml   = Integer($00000002);
  cxExportToXml    = Integer($00000003);
  cxExportToText   = Integer($00000004);
  cxExportToExcel  = Integer($00000001);

  cxExportCurrencyFormat: string = '';
  cxDataTypeString     = Integer($00000001);
  cxDataTypeWideString = Integer($00000002);
  cxDataTypeDouble     = Integer($00000003);
  cxDataTypeInteger    = Integer($00000004);
  cxDataTypeGraphic    = Integer($00000005);

resourcestring
  cxExportListIndexError = 'List index out of bounds (%d)';
implementation
var
  StylesCache: TStringList;
  RegisteredClasses: array of TcxExportProviderClass;
  cxGetRgbColor: TcxColorToRgbProc;
  IsNativeColor: Boolean;
  GraphicCount: Integer;
  GraphicRef: Integer;

function CopyEx(const ASource: WideString; AFrom: Integer; ACount: Integer = MaxInt): WideString;
begin
  Result := '';
  ACount := Min(Length(ASource) - AFrom + 1, ACount);
  if ACount <= 0 then Exit;
  SetLength(Result, ACount);
  Move(ASource[AFrom], Result[1], ACount * SizeOf(WideChar));
end;

function GetLastDelimiterPos(const AFileName: WideString; ADelimiter: WideChar): Integer;
begin
  Result := Length(AFileName);
  if Result = 0 then Exit;
  while (Result > 1) and (AFileName[Result] <> ADelimiter) do
    Dec(Result);
  if AFileName[Result] = ADelimiter then
    Inc(Result);
end;

function cxChangeFileExtExW(const AFileName: WideString; const ANewExt: string): WideString;
var
  APos: Integer;
begin
  APos := GetLastDelimiterPos(AFileName, '.');
  if APos <= 1 then
    Result := AFileName
  else
    Result := CopyEx(AFileName, 1, APos - 2);
  Result := Result + cxStrToUnicode(ANewExt); 
end;

function cxExtractFileNameEx(const AFileName: string): Widestring;
begin
  Result := cxExtractFileNameExW(cxStrToUnicode(AFileName));
end;