xlsutils2.pas

一个经典的读写Excel的控件

unit XLSUtils2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$I XLSRWII2.inc}

{$B-}

interface

uses Classes, SysUtils, Windows, BIFFRecsII2, Graphics, Math;

type PRecPTGS = ^TRecPTGS;
     TRecPTGS = packed record
     Size: word;
     PTGS: PByteArray;
     end;

type PWordBool = ^WordBool;
type TByte8Array = array[0..7] of byte;
type TByte4Array = array[0..3] of byte;

{$ifdef OLD_COMPILER}
type PWord = ^word;
type PInteger = ^integer;
{$endif}

type TDynByteArray = array of byte;

type PLongWordArray = ^TLongWordArray;
     TLongWordArray = array[0..8191] of Longword;

type TFormulaNameType = (ntName,ntExternName,ntExternSheet,ntCurrBook,ntCellValue);

type TFormulaValType = (fvFloat,fvBoolean,fvError,fvString,fvRef,fvArea,fvExtRef,fvExtArea);
const TFormulaValTypeRef = [fvRef,fvArea,fvExtRef,fvExtArea];

type TFormulaValue = record
     // String memory is handled by the compiler, can therefore not be in the
     // variant part.
     vString:  WideString;
     case ValType: TFormulaValType of
       fvFloat   : (vFloat:   double);
       fvBoolean : (vBoolean: boolean);
       fvError   : (vError:   TCellError);
       fvString  : (xvString:  boolean);
       // Col,Row
       fvRef     : (vRef:     array[0..1] of word);
       // Col1,Row1,Col2,Row2
       fvArea    : (vArea:    array[0..3] of word);
       // Col,Row,Sheet
       fvExtRef  : (vExtRef:  array[0..2] of word);
       // Col1,Row1,Col2,Row2,Sheet
       fvExtArea : (vExtArea: array[0..4] of word);
     end;

type TIntegerEvent      = procedure (Sender: TObject; Value: integer) of object;
type TColRowSizeEvent   = procedure(Sender: TObject; ColRow,FormatIndex,Size: integer) of object;
// FuncName is the name of the function. Args are the functions arguments, from
// left to right. If the function don't have any arguments, the array size is
// zero. Result is the result of the calculation. If the function not can be
// calculated, set Result to NULL
type TFunctionEvent     = procedure(Sender: TObject; FuncName: string; Args: array of TFormulaValue; var Result: TFormulaValue) of object;
type TPasswordEvent     = procedure(Sender: TObject; var Password: WideString) of object;
type TFormulaErrorEvent = procedure(Sender: TObject; ErrorId: integer; ErrorStr: WideString) of object;

const ExcelPictureTypes: array[0..6] of string = ('wmf','emf','pic','jpg','jpeg','png','bmp');
const ExcelPictureTypesFilter: string = 'Picture files|*.wmf;*.emf;*.pic;*.jpg;*.jpeg;*.png;*.bmp|All files (*.*)|*.*';


procedure FVClear(var FV: TFormulaValue);
procedure FVSetFloat(var FV: TFormulaValue; Value: double);
procedure FVSetBoolean(var FV: TFormulaValue; Value: boolean);
procedure FVSetError(var FV: TFormulaValue; Value: TCellError);
procedure FVSetString(var FV: TFormulaValue; Value: WideString);
procedure FVSetRef(var FV: TFormulaValue; Col,Row: word);
procedure FVSetArea(var FV: TFormulaValue; Col1,Row1,Col2,Row2: word);
procedure FVSetXRef(var FV: TFormulaValue; Col,Row,Sheet: word);
procedure FVSetXArea(var FV: TFormulaValue; Col1,Row1,Col2,Row2,Sheet: word);
function  FVGetVariant(FV: TFormulaValue): Variant;
function  FVCompare(FV1,FV2: TFormulaValue; var Res: double): boolean;

function  GetHashCode(const Buffer; Count: Integer): Word; assembler;
function  CPos(C: char; S: string): integer;
function  WCPos(C: WideChar; S: WideString): integer;
function  ColRowToRC(Col, Row: integer): longword;
procedure SplitRC(RC: integer; var Col,Row: integer);
procedure NormalizeArea(var C1,R1,C2,R2: integer);
function  IsMultybyteString(S: string): boolean;
function  ToMultibyte1bHeader(S: string): string;
function  UnicodeStorageSize(S: string): integer;
function  UnicodeStringLen(S: string): integer;
function  ExcelStrToString(P: PByteArray; CharCount: integer): string;
function  ByteStrToWideString(P: PByteArray; CharCount: integer): WideString;
procedure WideStringToByteStr(S: WideString; P: PByteArray);
function  HexToByte(S: string): byte;
function  HexStringToByteArray(S: string; var PBytes: PByteArray): integer;
procedure HexStringToDynByteArray(S: string; var PBytes: TDynByteArray);
function  ErrorCodeToText(Code: integer): WideString;
function  ErrorCodeToCellError(Code: integer): TCellError;
function  CellErrorToErrorCode(Error: TCellError): byte;
function  ColRowToRefStr(ACol,ARow: integer; AbsCol,AbsRow: boolean): string;
function  AreaToRefStr(Col1,Row1,Col2,Row2: integer; AbsCol1,AbsRow1,AbsCol2,AbsRow2: boolean): string;
function  RefStrToColRow(S: string; var ACol,ARow: word; var AbsCol,AbsRow: boolean): boolean; overload;
function  RefStrToColRow(S: string; var ACol,ARow: integer; var AbsCol,AbsRow: boolean): boolean; overload;
function  RefStrToColRow(S: string; var ACol,ARow: integer): boolean; overload;
function  AreaStrToColRow(S: string; var ACol1,ARow1,ACol2,ARow2: integer; var AbsCol1,AbsRow1,AbsCol2,AbsRow2: boolean): boolean;
function  FastReplace(var aSourceString : String; const aFindString, aReplaceString : String; CaseSensitive : Boolean = False) : String;
function  ExcelStrToWideString(S: string): WideString;
function  IntToXColor(Value: word): TExcelColor;
function  XColorToTColor(XC: TExcelColor): TColor;
function  XColorToRGB(XC: TExcelColor): longword;
function  BufUnicodeZToWS(Buf: PByteArray; Len: integer): WideString;
function  DecodeRK(Value: longint): double;
function  ClipAreaToSheet(var C1,R1,C2,R2: integer): boolean;
function  TColorToClosestXColor(Color: TColor): TExcelColor;
function  MyWideUppercase(S: WideString): WideString;

var
  XLS_DebugMode: boolean = False;

implementation

procedure FVClear(var FV: TFormulaValue);
begin
  FV.ValType := fvError;
  FV.vError := errError;
end;

procedure FVSetFloat(var FV: TFormulaValue; Value: double);
begin
  FV.ValType := fvFloat;
  FV.vFloat := Value;
end;

procedure FVSetBoolean(var FV: TFormulaValue; Value: boolean);
begin
  FV.ValType := fvBoolean;
  FV.vBoolean := Value;
end;

procedure FVSetError(var FV: TFormulaValue; Value: TCellError);
begin
  FV.ValType := fvError;
  FV.vError := Value;
end;

procedure FVSetString(var FV: TFormulaValue; Value: WideString);
begin
  FV.ValType := fvString;
  FV.vString := Value;
end;

procedure FVSetRef(var FV: TFormulaValue; Col,Row: word);
begin
  FV.ValType := fvRef;
  FV.vRef[0] := Col;
  FV.vRef[1] := Row;
end;

procedure FVSetArea(var FV: TFormulaValue; Col1,Row1,Col2,Row2: word);
begin
  FV.ValType := fvArea;
  FV.vArea[0] := Col1;
  FV.vArea[1] := Row1;
  FV.vArea[2] := Col2;
  FV.vArea[3] := Row2;
end;

procedure FVSetXRef(var FV: TFormulaValue; Col,Row,Sheet: word);
begin
  FV.ValType := fvExtRef;
  FV.vExtRef[0] := Col;
  FV.vExtRef[1] := Row;
  FV.vExtRef[2] := Sheet;
end;

procedure FVSetXArea(var FV: TFormulaValue; Col1,Row1,Col2,Row2,Sheet: word);
begin
  FV.ValType := fvExtArea;
  FV.vExtArea[0] := Col1;
  FV.vExtArea[1] := Row1;
  FV.vExtArea[2] := Col2;
  FV.vExtArea[3] := Row2;
  FV.vExtArea[4] := Sheet;
end;

function  FVGetVariant(FV: TFormulaValue): Variant;
begin
  case FV.ValType of
    fvFloat    : Result := FV.vFloat;
    fvBoolean  : Result := FV.vBoolean;
    fvError    : Result := CellErrorNames[Integer(FV.vError)];
    fvString   : Result := FV.vString;
    fvRef      : Result := ColRowToRefStr(FV.vRef[0],FV.vRef[1],False,False);
    fvArea     : Result := AreaToRefStr(FV.vArea[0],FV.vArea[1],FV.vArea[2],FV.vArea[3],False,False,False,False);
    // Sheet name is not included
    fvExtRef   : Result := ColRowToRefStr(FV.vExtRef[0],FV.vExtRef[1],False,False);
    fvExtArea  : Result := AreaToRefStr(FV.vExtArea[0],FV.vExtArea[1],FV.vExtArea[2],FV.vExtArea[3],False,False,False,False);
  end;
end;

function FVCompare(FV1,FV2: TFormulaValue; var Res: double): boolean;
begin
  Result := (FV1.ValType <> fvError) and (FV2.ValType <> fvError) and (FV1.ValType = FV2.ValType);
  if not Result then
    Exit;
  if FV1.ValType in TFormulaValTypeRef then
    raise Exception.Create('Illegal value in comparision');
  case FV1.ValType of
    fvFloat   : Res := FV1.vFloat - FV2.vFloat;
    fvBoolean : Res := Integer(FV1.vBoolean = FV2.vBoolean);
{$ifdef OLD_COMPILER}
    fvString  : Res := AnsiCompareStr(AnsiUppercase(FV1.vString),AnsiUppercase(FV2.vString));
{$else}
    fvString  : Res := WideCompareStr(MyWideUppercase(FV1.vString),WideUppercase(FV2.vString));
{$endif}
  end;
end;

function GetHashCode(const Buffer; Count: Integer): Word; assembler;
asm
        CMP     EDX,0
        JNE     @@2
        MOV     EAX,0
        JMP     @@3
@@2:
        MOV     ECX,EDX
        MOV     EDX,EAX
        XOR     EAX,EAX
@@1:    ROL     AX,5
        XOR     AL,[EDX]
        INC     EDX
        DEC     ECX
        JNE     @@1
@@3:
end;

function CPos(C: char; S: string): integer;
begin
  for Result := 1 to Length(S) do begin
    if S[Result] = C then
      Exit;
  end;
  Result := -1;
end;

function  WCPos(C: WideChar; S: WideString): integer;
begin
  for Result := 1 to Length(S) do begin
    if S[Result] = C then
      Exit;
  end;
  Result := -1;
end;

function ColRowToRC(Col, Row: integer): longword;
begin
  Result := (Row shl 8) + (Col and $000000FF);
end;

procedure SplitRC(RC: integer; var Col,Row: integer);
begin
  Col := RC and $000000FF;
  Row := RC shr 8;
end;

procedure NormalizeArea(var C1,R1,C2,R2: integer);
var
  T: integer;
begin
  if C1 > C2 then begin
    T := C1;
    C1 := C2;
    C2 := T;
  end;
  if R1 > R2 then begin
    T := R1;
    R1 := R2;
    R2 := T;
  end;
end;

function IsMultybyteString(S: string): boolean;
begin
  Result := (Length(S) > 0) and (S[1] = #1);
end;

function ToMultibyte1bHeader(S: string): string;
begin
  Result := #0 + S
end;

function UnicodeStorageSize(S: string): integer;
begin
  if S = '' then
    Result := 0
  else if S[1] = #0 then
    Result := Length(S) + 1
  else
    Result := Length(S) * 2 + 1;
end;

function UnicodeStringLen(S: string): integer;
begin
  if S = '' then
    Result := 0
  else if S[1] = #0 then
    Result := Length(S) - 1
  else
    Result := (Length(S) - 1) div 2;
end;

function ExcelStrToString(P: PByteArray; CharCount: integer): string;
begin
  if P[0] = 0 then begin
    SetLength(Result,CharCount + 1);
    Move(P[1],Result[2],CharCount);
    Result[1] := #0;
  end
  else begin
    SetLength(Result,CharCount * 2 + 1);
    Move(P[1],Result[2],CharCount * 2);
    Result[1] := #1;
  end;
end;

function ByteStrToWideString(P: PByteArray; CharCount: integer): WideString;
var
  i: integer;
begin
  SetLength(Result,CharCount);
  if CharCount <= 0  then
    Exit
  else if P[0] = 1 then begin
    P := PByteArray(Integer(P) + 1);
    Move(P^,Pointer(Result)^,CharCount * 2);
  end
  else begin
    for i := 1 to CharCount do
      Result[i] := WideChar(P[i]);
  end;
end;

procedure WideStringToByteStr(S: WideString; P: PByteArray);
begin
  P[0] := 1;
  Move(Pointer(S)^,P[1],Length(S) * 2);
end;

function ErrorCodeToText(Code: integer): WideString;
begin
  case Code of
    $00: Result := CellErrorNames[1];
    $07: Result := CellErrorNames[2];
    $0F: Result := CellErrorNames[3];
    $17: Result := CellErrorNames[4];
    $1D: Result := CellErrorNames[5];
    $24: Result := CellErrorNames[6];
    $2A: Result := CellErrorNames[7];
    else Result := '#???';
  end;
end;

function ErrorCodeToCellError(Code: integer): TCellError;
var
  V: byte;
begin
  case Code of
    $00: V := 1;
    $07: V := 2;
    $0F: V := 3;
    $17: V := 4;
    $1D: V := 5;
    $24: V := 6;
    $2A: V := 7;
    else V := 0;
  end;
  Result := TCellError(V);
end;

function CellErrorToErrorCode(Error: TCellError): byte;
begin
  case Error of
    errError: Result := $2A;
    errNull:  Result := $00;
    errDiv0:  Result := $07;
    errValue: Result := $0F;
    errRef:   Result := $17;
    errName:  Result := $1D;
    errNum:   Result := $24;
    errNA:    Result := $2A;
    else
      Result := $2A;
  end;
end;

function ColRowToRefStr(ACol,ARow: integer; AbsCol,AbsRow: boolean): string;
begin
  Inc(ARow);
  if AbsCol then begin
    if ACol < 26 then Result := '$' + Char(Ord('A') + ACol)
    else Result := '$' + Char(Ord('@') + ACol div 26) + Char(Ord('A') + ACol mod 26);
  end
  else begin
    if ACol < 26 then Result := Char(Ord('A') + ACol)
    else Result := Char(Ord('@') + ACol div 26) + Char(Ord('A') + ACol mod 26);
  end;
  if AbsRow then
    Result := Result + '$' + IntToStr(ARow)
  else
    Result := Result + IntToStr(ARow);
end;

function AreaToRefStr(Col1,Row1,Col2,Row2: integer; AbsCol1,AbsRow1,AbsCol2,AbsRow2: boolean): string;
begin
  Result := ColRowToRefStr(Col1,Row1,AbsCol1,AbsRow1) + ':' + ColRowToRefStr(Col2,Row2,AbsCol2,AbsRow2);
end;

function RefStrToColRow(S: string; var ACol,ARow: integer; var AbsCol,AbsRow: boolean): boolean;
var
  wCol,wRow: word;
begin
//  Result := (ACol >= 0) and (ACol <= MAXCOL) and (ARow >= 0) and (ARow <= MAXROW);
//  if Result then begin
    wCol := 0;
    wRow := 0;
    Result := RefStrToColRow(S,wCol,wRow,AbsCol,AbsRow);
    ACol := wCol;
    ARow := wRow;
//  end;
end;

function RefStrToColRow(S: string; var ACol,ARow: integer): boolean; overload;
var
  AbsCol,AbsRow: boolean;
begin
  Result := RefStrToColRow(S,ACol,ARow,AbsCol,AbsRow);
end;

function RefStrToColRow(S: string; var ACol,ARow: word; var AbsCol,AbsRow: boolean): boolean;
var
  i,j: integer;
begin
  AbsCol := False;
  AbsRow := False;
  Result := False;