david
111d889bc6
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.DevExpressVCL@32 05c56307-c608-d34a-929d-697000501d7a
1013 lines
30 KiB
ObjectPascal
1013 lines
30 KiB
ObjectPascal
|
|
{*******************************************************************}
|
|
{ }
|
|
{ Developer Express Cross Platform Component Library }
|
|
{ ExpressExport }
|
|
{ }
|
|
{ Copyright (c) 2001-2009 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
|
|
Windows, Classes, SysUtils, Math, Graphics, dxCore, cxExportStrs;
|
|
|
|
type
|
|
EcxExportData = class(EdxException);
|
|
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..64 - 1] of Byte;
|
|
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 = '';
|
|
cxDataTypeAnsiString = Integer($00000001);
|
|
cxDataTypeWideString = Integer($00000002);
|
|
cxDataTypeDouble = Integer($00000003);
|
|
cxDataTypeInteger = Integer($00000004);
|
|
cxDataTypeGraphic = Integer($00000005);
|
|
|
|
cxDataTypeString = cxDataTypeAnsiString;
|
|
|
|
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;
|
|
|
|
function cxExtractFileNameExW(const AFileName: WideString): WideString;
|
|
begin
|
|
Result := CopyEx(AFileName, GetLastDelimiterPos(AFileName, '\'));
|
|
end;
|
|
|
|
function cxExtractFilePathExW(const AFileName: WideString): WideString;
|
|
begin
|
|
Result := CopyEx(AFileName, 1, GetLastDelimiterPos(AFileName, '\') - 1);
|
|
end;
|
|
|
|
function cxValidateFileName(const AFileName: string): WideString;
|
|
begin
|
|
Result := cxValidateFileNameW(cxStrToUnicode(AFileName));
|
|
end;
|
|
|
|
function cxValidateFileNameW(const AFileName: WideString): WideString;
|
|
begin
|
|
Result := AFileName;
|
|
while Pos('/', Result) <> 0 do
|
|
Result[Pos('/', Result)] := '\';
|
|
end;
|
|
|
|
procedure UseGraphicImages(AUse: Boolean);
|
|
begin
|
|
if AUse then
|
|
Inc(GraphicRef)
|
|
else
|
|
Dec(GraphicRef);
|
|
if GraphicRef = 0 then
|
|
GraphicCount := 0;
|
|
end;
|
|
|
|
function CreateDefaultCellStyle: TcxCacheCellStyle;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
with Result do
|
|
begin
|
|
AlignText := catCenter;
|
|
FillChar(FontName, SizeOf(FontName), 0);
|
|
dxStringToBytes('Tahoma', FontName);
|
|
FontStyle := [];
|
|
FontColor := cxBtnTextColor;
|
|
FontSize := 8;
|
|
FontCharSet := 0;
|
|
for I := 0 to 3 do
|
|
begin
|
|
Borders[I].IsDefault := False;
|
|
Borders[I].Width := 1;
|
|
Borders[I].Color := cxBtnShadowColor;
|
|
end;
|
|
BrushStyle := cbsSolid;
|
|
BrushBkColor := cxWindowColor;
|
|
BrushFgColor := cxBlackColor;
|
|
end;
|
|
end;
|
|
|
|
function cxColorToRGB(const AColor: Integer): Integer;
|
|
type
|
|
TRGB = packed record
|
|
R, G, B, A: Byte;
|
|
end;
|
|
|
|
begin
|
|
Result := cxGetRgbColor(AColor);
|
|
if IsNativeColor then Exit;
|
|
with TRGB(cxGetRgbColor(AColor)) do
|
|
begin
|
|
if AColor < 0 then
|
|
Result := R shl 16 + G shl 8 + B;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF WIN32}
|
|
|
|
function cxGetCodePageFromCharset(ACharset: Integer): Integer;
|
|
begin
|
|
case ACharset of
|
|
THAI_CHARSET:
|
|
Result := 874;
|
|
SHIFTJIS_CHARSET:
|
|
Result := 932;
|
|
GB2312_CHARSET:
|
|
Result := 936;
|
|
HANGEUL_CHARSET, JOHAB_CHARSET:
|
|
Result := 949;
|
|
CHINESEBIG5_CHARSET:
|
|
Result := 950;
|
|
EASTEUROPE_CHARSET:
|
|
Result := 1250;
|
|
RUSSIAN_CHARSET:
|
|
Result := 1251;
|
|
GREEK_CHARSET:
|
|
Result := 1253;
|
|
TURKISH_CHARSET:
|
|
Result := 1254;
|
|
HEBREW_CHARSET:
|
|
Result := 1255;
|
|
ARABIC_CHARSET:
|
|
Result := 1256;
|
|
BALTIC_CHARSET:
|
|
Result := 1257;
|
|
else
|
|
Result := 0
|
|
end;
|
|
end;
|
|
|
|
function cxUnicodeToStr(const AText: WideString; ACharset: Integer = 0): string;
|
|
begin
|
|
Result := dxWideStringToString(AText, cxGetCodePageFromCharset(ACharset));
|
|
end;
|
|
|
|
function cxStrToUnicode(const AText: string; ACharset: Integer = 0): Widestring;
|
|
begin
|
|
Result := dxStringToWideString(AText, cxGetCodePageFromCharset(ACharset));
|
|
end;
|
|
{$ELSE}
|
|
function cxStrToUnicode(const AText: string; ACharset: Integer = 0): Widestring;
|
|
begin
|
|
Result := AText;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function cxStrUnicodeNeeded(const AText: string; ACheckNormal: Boolean = False): Boolean;
|
|
var
|
|
I: Integer;
|
|
const
|
|
ANormal = ['0'..'9', ':', ';', '*', '+', ',', '-', '.', '/', '!', ' ',
|
|
'A'..'Z', 'a'..'z', '_', '(', ')'];
|
|
begin
|
|
Result := False;
|
|
for I := 1 to Length(AText) do
|
|
if (Byte(AText[I]) > $7F) or (ACheckNormal and not dxCharInSet(AText[I], ANormal)) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end
|
|
end;
|
|
|
|
function GetHashCode(const Buffer; Count: Integer): Integer; assembler;
|
|
asm
|
|
MOV ECX, EDX
|
|
MOV EDX, EAX
|
|
XOR EAX, EAX
|
|
@@1: ROL EAX, 5
|
|
XOR AL, [EDX]
|
|
INC EDX
|
|
DEC ECX
|
|
JNE @@1
|
|
end;
|
|
|
|
function GetGraphicFileName(const AFileName, AExt: string): string;
|
|
begin
|
|
Result := ChangeFileExt(AFileName, '.images') + '\' + ChangeFileExt(
|
|
ExtractFileName(AFileName), '') + '_' + IntToStr(GraphicCount) + '.' + AExt;
|
|
Inc(GraphicCount);
|
|
end;
|
|
|
|
function PrepareGraphic(AGraphic: TGraphic): TGraphic;
|
|
begin
|
|
Result := AGraphic;
|
|
if not SupportGraphic(cxExportGraphicClass) then
|
|
begin
|
|
Result := cxExportGraphicClass.Create;
|
|
try
|
|
try
|
|
Result.Assign(AGraphic);
|
|
except
|
|
Result.Free;
|
|
Result := AGraphic;
|
|
end;
|
|
finally
|
|
if Result <> AGraphic then
|
|
AGraphic.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function SupportGraphic(AGraphic: TGraphic): Boolean;
|
|
begin
|
|
Result := SupportGraphic(TGraphicClass(AGraphic.ClassType));
|
|
end;
|
|
|
|
function SupportGraphic(AGraphicClass: TGraphicClass): Boolean;
|
|
begin
|
|
Result := (AGraphicClass <> nil) and
|
|
(AGraphicClass.InheritsFrom(TBitmap) or
|
|
AGraphicClass.InheritsFrom(TMetaFile));
|
|
end;
|
|
|
|
procedure GetGraphicAsText(const AFileName: string;
|
|
var AGraphic: TGraphic; var AGraphicText: string);
|
|
var
|
|
L: Integer;
|
|
AName: string;
|
|
AMemStream: TMemoryStream;
|
|
begin
|
|
AGraphic := PrepareGraphic(AGraphic);
|
|
AName := GetGraphicFileName(AFileName,
|
|
GraphicExtension(TGraphicClass(AGraphic.ClassType)));
|
|
AMemStream := TMemoryStream.Create;
|
|
try
|
|
AGraphic.SaveToStream(AMemStream);
|
|
L := Length(AName);
|
|
SetLength(AGraphicText, AMemStream.Size + L + SizeOf(L));
|
|
Move(L, AGraphicText[1], SizeOf(L));
|
|
Move(AName[1], AGraphicText[1 + SizeOf(L)], L);
|
|
Move(AMemStream.Memory^, AGraphicText[1 + SizeOf(L) + L], AMemStream.Size);
|
|
finally
|
|
AMemStream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure GetTextAsGraphicStream(const AText: string; var AFileName, AStream: string);
|
|
var
|
|
L: Integer;
|
|
begin
|
|
Move(AText[1], L, SizeOf(L));
|
|
SetLength(AFileName, L);
|
|
Move(AText[1 + SizeOf(L)], AFileName[1], L);
|
|
SetLength(AStream, Length(AText) - SizeOf(L) - L);
|
|
Move(AText[1 + SizeOf(L) + L], AStream[1], Length(AStream));
|
|
end;
|
|
|
|
{$IFNDEF DELPHI5}
|
|
procedure FreeAndNil(var Obj);
|
|
var
|
|
Temp: TObject;
|
|
begin
|
|
Temp := TObject(Obj);
|
|
Pointer(Obj) := nil;
|
|
Temp.Free;
|
|
end;
|
|
|
|
function Supports(Instance: TObject; const Intf: TGUID; out Inst): Boolean;
|
|
begin
|
|
Result := (Instance <> nil) and Instance.GetInterface(Intf, Inst);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{ TcxExport }
|
|
class function TcxExport.Provider(AExportType: Integer;
|
|
const AFileName: string): TcxCustomExportProvider;
|
|
begin
|
|
Result := GetExportClassByType(AExportType).Create(AFileName);
|
|
end;
|
|
|
|
class procedure TcxExport.SupportExportTypes(
|
|
EnumSupportTypes: TcxEnumExportTypes);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Length(RegisteredClasses) - 1 do
|
|
begin
|
|
with RegisteredClasses[I] do
|
|
EnumSupportTypes(ExportType, ExportName);
|
|
end;
|
|
end;
|
|
|
|
class procedure TcxExport.SupportTypes(EnumFunc: TcxEnumTypes);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Length(RegisteredClasses) - 1 do
|
|
EnumFunc(RegisteredClasses[I].ExportType);
|
|
end;
|
|
|
|
class function TcxExport.RegisterProviderClass(AProviderClass: TcxExportProviderClass): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := False;
|
|
if AProviderClass = nil then
|
|
Exit;
|
|
for I := 0 to Length(RegisteredClasses) - 1 do
|
|
begin
|
|
if (AProviderClass.ExportType = RegisteredClasses[I].ExportType) or
|
|
(AProviderClass = RegisteredClasses[I]) then Exit;
|
|
end;
|
|
I := Length(RegisteredClasses);
|
|
SetLength(RegisteredClasses, I + 1);
|
|
RegisteredClasses[I] := AProviderClass;
|
|
Result := True;
|
|
end;
|
|
|
|
class function TcxExport.GetExportClassByType(
|
|
AExportType: Integer): TcxExportProviderClass;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Length(RegisteredClasses) - 1 do
|
|
begin
|
|
if RegisteredClasses[I].ExportType = AExportType then
|
|
begin
|
|
Result := RegisteredClasses[I];
|
|
Exit;
|
|
end;
|
|
end;
|
|
raise EcxExportData.CreateFmt(cxGetResString(@scxUnsupportedExport), [AExportType]);
|
|
end;
|
|
|
|
{ TcxCustomExportProvider }
|
|
constructor TcxCustomExportProvider.Create(const AFileName: string);
|
|
begin
|
|
FFileName := cxValidateFileName(AFileName);
|
|
end;
|
|
|
|
procedure TcxCustomExportProvider.BeforeDestruction;
|
|
begin
|
|
Clear;
|
|
end;
|
|
|
|
class function TcxCustomExportProvider.ExportType: Integer;
|
|
begin
|
|
Result := -1;
|
|
end;
|
|
|
|
class function TcxCustomExportProvider.ExportName: string;
|
|
begin
|
|
Result := '';
|
|
end;
|
|
|
|
procedure TcxCustomExportProvider.Clear;
|
|
begin
|
|
end;
|
|
|
|
{ TcxExportStyleManager }
|
|
constructor TcxExportStyleManager.Create;
|
|
begin
|
|
raise EcxExportData.Create(cxGetResString(@scxStyleManagerCreate));
|
|
end;
|
|
|
|
destructor TcxExportStyleManager.Destroy;
|
|
begin
|
|
if FRefCount <> 0 then
|
|
raise EcxExportData.Create(cxGetResString(@scxStyleManagerKill));
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TcxExportStyleManager.Clear;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Dec(FRefCount);
|
|
if FRefCount = 0 then
|
|
begin
|
|
try
|
|
for I := 0 to FStyles.Count - 1 do
|
|
FreeMem(PcxCacheCellStyle(FStyles[I]));
|
|
if StylesCache.Find(FFileName, I) then
|
|
StylesCache.Delete(I);
|
|
finally
|
|
FStyles.Free;
|
|
Destroy;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
class function TcxExportStyleManager.GetInstance(
|
|
const AFileName: string): TcxExportStyleManager;
|
|
var
|
|
AIndex: Integer;
|
|
begin
|
|
if StylesCache.Find(AFileName, AIndex) then
|
|
begin
|
|
Result := TcxExportStyleManager(StylesCache.Objects[AIndex]);
|
|
Result.RegisterStyle(DefaultCellStyle);
|
|
Inc(Result.FRefCount);
|
|
end
|
|
else
|
|
Result := CreateInstance(AFileName);
|
|
end;
|
|
|
|
function TcxExportStyleManager.GetStyle(const AIndex: Integer): PcxCacheCellStyle;
|
|
begin
|
|
Result := FStyles[AIndex];
|
|
end;
|
|
|
|
function TcxExportStyleManager.RegisterStyle(
|
|
const AStyle: TcxCacheCellStyle): Integer;
|
|
var
|
|
I: Integer;
|
|
NewStyleItem, AStylePtr: PcxCacheCellStyle;
|
|
begin
|
|
AStylePtr := @AStyle;
|
|
AStylePtr^.HashCode :=
|
|
cxExport.GetHashCode(AStyle, SizeOf(TcxCacheCellStyle) - SizeOf(Integer));
|
|
for I := 0 to FStyles.Count - 1 do
|
|
if StyleCompare(FStyles[I], @AStyle) then
|
|
begin
|
|
Result := I;
|
|
Exit;
|
|
end;
|
|
New(NewStyleItem);
|
|
NewStyleItem^ := AStylePtr^;
|
|
Result := FStyles.Add(NewStyleItem);
|
|
end;
|
|
|
|
function TcxExportStyleManager.GetCount: Integer;
|
|
begin
|
|
Result := FStyles.Count;
|
|
end;
|
|
|
|
function TcxExportStyleManager.GetItem(AIndex: Integer): TcxCacheCellStyle;
|
|
begin
|
|
Result := GetStyle(AIndex)^;
|
|
end;
|
|
|
|
constructor TcxExportStyleManager.CreateInstance(const AFileName: string);
|
|
begin
|
|
FStyles := TList.Create;
|
|
StylesCache.AddObject(AFileName, Self);
|
|
FFileName := AFileName;
|
|
FRefCount := 1;
|
|
end;
|
|
|
|
function TcxExportStyleManager.StyleCompare(
|
|
const AStyle1, AStyle2: PcxCacheCellStyle): Boolean;
|
|
begin
|
|
Result := (AStyle1.HashCode = AStyle2.HashCode) and
|
|
CompareMem(AStyle1, AStyle2, SizeOf(TcxCacheCellStyle) - SizeOf(Integer));
|
|
end;
|
|
|
|
constructor TFileStreamEx.Create(const FileName: string; Mode: Word);
|
|
{$IFDEF DELPHI6}
|
|
var
|
|
AName: WideString;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF DELPHI6}
|
|
if cxUnicodeSupported then
|
|
begin
|
|
AName := cxStrToUnicode(FileName);
|
|
FHandle := Integer(CreateFileW(PWideChar(AName), GENERIC_READ or GENERIC_WRITE,
|
|
0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0));
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
inherited Create(FileName, Mode);
|
|
end;
|
|
|
|
function CompareValues(AItem1, AItem2: Pointer): Integer;
|
|
begin
|
|
Result := Integer(AItem1) - Integer(AItem2);
|
|
end;
|
|
|
|
{ TcxExportIntList }
|
|
|
|
procedure TcxExportIntList.Add(AValue: Integer);
|
|
begin
|
|
if Capacity - Count < 2 then
|
|
if Count * 2 < 1024 then
|
|
Capacity := 1024
|
|
else
|
|
Capacity := Count * 2;
|
|
inherited Add(Pointer(AValue));
|
|
end;
|
|
|
|
procedure TcxExportIntList.AddPairs(AValue1, AValue2: Integer);
|
|
begin
|
|
if Capacity - Count < 2 then
|
|
if Count * 2 < 1024 then
|
|
Capacity := 1024
|
|
else
|
|
Capacity := Count * 2;
|
|
inherited Add(Pointer(AValue1));
|
|
inherited Add(Pointer(AValue2));
|
|
end;
|
|
|
|
function TcxExportIntList.Last: Integer;
|
|
begin
|
|
Result := Integer(inherited Last);
|
|
end;
|
|
|
|
function TcxExportIntList.First: Integer;
|
|
begin
|
|
Result := Integer(inherited First);
|
|
end;
|
|
|
|
function TcxExportIntList.GetItem(AIndex: Integer): Integer;
|
|
begin
|
|
Result := Integer(List^[AIndex]);
|
|
end;
|
|
|
|
procedure TcxExportIntList.SetItem(AIndex, AValue: Integer);
|
|
begin
|
|
Integer(List^[AIndex]) := AValue
|
|
end;
|
|
|
|
{ TcxExportScale }
|
|
|
|
procedure TcxExportScale.Arrange;
|
|
var
|
|
AIndex, I: Integer;
|
|
begin
|
|
Sort(@CompareValues);
|
|
AIndex := 0;
|
|
for I := 1 to Count - 1 do
|
|
begin
|
|
if List^[AIndex] <> List^[I] then
|
|
Inc(AIndex);
|
|
List^[AIndex] := List^[I];
|
|
end;
|
|
if Count > 0 then
|
|
Count := AIndex + 1;
|
|
end;
|
|
|
|
function TcxExportScale.IndexOf(AItem: Integer): Integer;
|
|
begin
|
|
Result := IndexOfEx(AItem, 0, VisibleCount);
|
|
end;
|
|
|
|
function TcxExportScale.IndexOfEx(AValue, AFirstIndex, ALastIndex: Integer): Integer;
|
|
var
|
|
L, H, I, C: Integer;
|
|
begin
|
|
Result := -1;
|
|
// binary search
|
|
L := AFirstIndex;
|
|
H := ALastIndex;
|
|
while L <= H do
|
|
begin
|
|
I := (L + H) shr 1;
|
|
C := Integer(List^[I]) - AValue;
|
|
if C < 0 then
|
|
L := I + 1
|
|
else
|
|
begin
|
|
H := I - 1;
|
|
if C = 0 then
|
|
begin
|
|
Result := I;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
if Result = - 1 then
|
|
Error(@cxExportListIndexError, AValue);
|
|
end;
|
|
|
|
procedure TcxExportScale.GetPosition(
|
|
AValue1, AValue2: Integer; out AIndex1, AIndex2: Integer);
|
|
begin
|
|
AIndex1 := IndexOf(AValue1);
|
|
AIndex2 := IndexOfEx(AValue2, AIndex1, Count - 1);
|
|
end;
|
|
|
|
procedure TcxExportScale.GetPositionEx(AValue1, AValue2,
|
|
AFirstIndex, ALastIndex: Integer; out AIndex1, AIndex2: Integer);
|
|
begin
|
|
AIndex1 := IndexOfEx(AValue1, AFirstIndex, ALastIndex);
|
|
AIndex2 := IndexOfEx(AValue2, AIndex1, ALastIndex);
|
|
end;
|
|
|
|
function TcxExportScale.GetVisibleCount: Integer;
|
|
begin
|
|
Result := Count;
|
|
Dec(Result);
|
|
end;
|
|
|
|
function TcxExportScale.GetDelta(AIndex: Integer): Integer;
|
|
begin
|
|
Result := Integer(List^[AIndex + 1]) - Integer(List^[AIndex]);
|
|
end;
|
|
|
|
function GetCurrencyFormat: string;
|
|
|
|
function GetCharString(C: Char; ACount: Integer): string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := '';
|
|
for I := 1 to ACount do
|
|
Result := Result + C;
|
|
end;
|
|
|
|
function GetPositiveCurrencyFormat(const AFormat, ACurrStr: string): string;
|
|
begin
|
|
if Length(ACurrStr) > 0 then
|
|
case Sysutils.CurrencyFormat of
|
|
0: Result := ACurrStr + AFormat; { '$1' }
|
|
1: Result := AFormat + ACurrStr; { '1$' }
|
|
2: Result := ACurrStr + ' ' + AFormat; { '$ 1' }
|
|
3: Result := AFormat + ' ' + ACurrStr; { '1 $' }
|
|
end;
|
|
end;
|
|
|
|
function GetNegativeCurrencyFormat(const AFormat, ACurrStr: string): string;
|
|
begin
|
|
case Sysutils.NegCurrFormat of
|
|
0: Result := '(' + ACurrStr + AFormat + ')';
|
|
1: Result := '-' + ACurrStr + AFormat;
|
|
2: Result := ACurrStr + '-' + AFormat;
|
|
3: Result := ACurrStr + AFormat + '-';
|
|
4: Result := '(' + AFormat + ACurrStr + ')';
|
|
5: Result := '-' + AFormat + ACurrStr;
|
|
6: Result := AFormat + '-' + ACurrStr;
|
|
7: Result := AFormat + ACurrStr + '-';
|
|
8: Result := '-' + AFormat + ' ' + ACurrStr;
|
|
9: Result := '-' + ACurrStr + ' ' + AFormat;
|
|
10: Result := AFormat + ' ' + ACurrStr + '-';
|
|
11: Result := ACurrStr + ' ' + AFormat + '-';
|
|
12: Result := ACurrStr + ' ' + '-' + AFormat;
|
|
13: Result := AFormat + '-' + ' ' + ACurrStr;
|
|
14: Result := '(' + ACurrStr + ' ' + AFormat + ')';
|
|
15: Result := '(' + AFormat + ' ' + ACurrStr + ')';
|
|
end;
|
|
end;
|
|
|
|
var
|
|
ACurrStr: string;
|
|
I: Integer;
|
|
C: Char;
|
|
begin
|
|
if CurrencyDecimals > 0 then
|
|
Result := GetCharString('0', CurrencyDecimals)
|
|
else
|
|
Result := '';
|
|
Result := ',0.' + Result;
|
|
ACurrStr := '';
|
|
for I := 1 to Length(CurrencyString) do
|
|
begin
|
|
C := CurrencyString[I];
|
|
if (C = ',') or (C = '.') then
|
|
ACurrStr := ACurrStr + '''' + C + ''''
|
|
else
|
|
ACurrStr := ACurrStr + C;
|
|
end;
|
|
Result := GetPositiveCurrencyFormat(Result, ACurrStr) + ';' +
|
|
GetNegativeCurrencyFormat(Result, ACurrStr);
|
|
end;
|
|
|
|
procedure cxExportInit(AGetResString: TcxGetResourceStringProc;
|
|
AColorProc: Pointer; AIsNativeColor: Boolean);
|
|
begin
|
|
cxGetResString := AGetResString;
|
|
cxGetRgbColor := AColorProc;
|
|
IsNativeColor := AIsNativeColor;
|
|
cxUnicodeSupported := IsWin2KOrLater;
|
|
{$IFDEF WIN32}
|
|
cxWindowColor := Windows.GetSysColor(COLOR_WINDOW);
|
|
cxBtnTextColor := Windows.GetSysColor(COLOR_BTNTEXT);
|
|
cxBtnFaceColor := Windows.GetSysColor(COLOR_BTNFACE);
|
|
cxBtnShadowColor := Windows.GetSysColor(COLOR_BTNSHADOW);
|
|
{$ELSE}
|
|
cxWindowColor := cxColorToRGB(clWindow);
|
|
cxBtnTextColor := cxColorToRGB(clBtnText);
|
|
cxBtnFaceColor := cxColorToRGB(clBtnFace);
|
|
cxBtnShadowColor := ColorToRGB(clBtnShadow);
|
|
{$ENDIF}
|
|
FreeAndNil(StylesCache);
|
|
StylesCache := TStringList.Create;
|
|
DefaultCellStyle := CreateDefaultCellStyle;
|
|
cxExportCurrencyFormat := GetCurrencyFormat;
|
|
end;
|
|
|
|
initialization
|
|
StylesCache := nil;
|
|
|
|
finalization
|
|
FreeAndNil(StylesCache);
|
|
|
|
end.
|