xlsutils2.pas

一个经典的读写Excel的控件

  if Length(S) < 1 then
    Exit;
  i := 1;
  if S[i] = '$' then begin
    Inc(i);
    AbsCol := True;
  end;
  if i > Length(S) then
    Exit;
  if not (S[i] in ['A'..'Z']) then
    Exit;
  Inc(i);
  if i > Length(S) then
    Exit;
  if (S[i] in ['A'..'Z']) then begin
    if not (S[i - 1] in ['A'..'I']) then
      Exit;
    ACol := (Ord(S[i - 1]) - Ord('@')) * 26 + (Ord(S[i]) - Ord('A'));
    if ACol > 255 then
      ACol := 255;
    Inc(i);
    if i > Length(S) then
      Exit;
  end
  else
    ACol := Ord(S[i - 1]) - Ord('A');
  if S[i] = '$' then begin
    Inc(i);
    AbsRow := True;
  end;
  for j := i to Length(S) do begin
    if not (S[j] in ['0'..'9']) then
      Exit;
  end;
  try
    ARow := StrToInt(Copy(S,i,1024)) - 1;
  except
    Exit;
  end;
  Result := True;
end;

function  AreaStrToColRow(S: string; var ACol1,ARow1,ACol2,ARow2: integer; var AbsCol1,AbsRow1,AbsCol2,AbsRow2: boolean): boolean;
var
  p: integer;
begin
  Result := False;
  p := CPos(':',S);
  if p < 1 then
    Exit;
  if not RefStrToColRow(Copy(S,1,p - 1),ACol1,ARow1,AbsCol1,AbsRow1) then
    Exit;
  if not RefStrToColRow(Copy(S,p + 1,MAXINT),ACol2,ARow2,AbsCol2,AbsRow2) then
    Exit;
  Result := True;
end;

function HexToByte(S: string): byte;
begin
  if Length(S) <> 2 then
    raise Exception.Create('Length error in hex string.');
  if S[1] in ['0'..'9'] then
    Result := (Ord(S[1]) - Ord('0')) * 16
  else
    Result := (Ord(S[1]) - Ord('A') + 10) * 16;
  if S[2] in ['0'..'9'] then
    Result := Result + Ord(S[2]) - Ord('0')
  else
    Result := Result + Ord(S[2]) - Ord('A') + 10;
end;

function HexStringToByteArray(S: string; var PBytes: PByteArray): integer;
var
  i,p: integer;
begin
  Result := Length(S) div 2;
  ReAllocMem(PBytes,Result);
  p := 1;
  for i := 0 to Result - 1 do begin
    PBytes[i] := HexToByte(Copy(S,p,2)) ;
    Inc(p,2);
  end;
end;

procedure HexStringToDynByteArray(S: string; var PBytes: TDynByteArray);
var
  i,p,Sz: integer;
begin
  Sz := Length(S) div 2;
  SetLength(PBytes,Sz);
  p := 1;
  for i := 0 to Sz - 1 do begin
    PBytes[i] := HexToByte(Copy(S,p,2)) ;
    Inc(p,2);
  end;
end;

Type
  TFastPosProc = function(
    const aSourceString, aFindString : String;
    const aSourceLen, aFindLen, StartPos : integer
    ) : integer;

function FastPos(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : integer) : integer;
var
  SourceLen : integer;
begin
  SourceLen := aSourceLen;
  SourceLen := SourceLen - aFindLen;
  if (StartPos-1) > SourceLen then begin
    Result := 0;
    Exit;
  end;
  SourceLen := SourceLen - StartPos;
  SourceLen := SourceLen +2;
  asm
    push ESI
    push EDI
    push EBX

    mov EDI, aSourceString
    add EDI, StartPos
    Dec EDI

    mov ESI, aFindString

    mov ECX, SourceLen

    Mov  Al, [ESI]

    @ScaSB:
    Mov  Ah, [EDI]

    cmp  Ah,Al
    jne  @NextChar

    @CompareStrings:
    mov  EBX, aFindLen

    dec  EBX

    @CompareNext:

    mov  Al, [ESI+EBX]

    mov  Ah, [EDI+EBX]

    cmp  Al, Ah
    Jz   @Matches

    Mov  Al, [ESI]
    Jmp  @NextChar

    @Matches:
    Dec  EBX
    Jnz  @CompareNext

    mov  EAX, EDI
    sub  EAX, aSourceString
    inc  EAX
    mov  Result, EAX
    jmp  @TheEnd
    @NextChar:

    Inc  EDI
    dec  ECX
    jnz  @ScaSB

    mov  Result,0

    @TheEnd:
    pop  EBX
    pop  EDI
    pop  ESI
  end;
end;

function FastPosNoCase(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : integer) : integer;
var
  SourceLen : integer;
begin
  SourceLen := aSourceLen;
  SourceLen := SourceLen - aFindLen;
  if (StartPos-1) > SourceLen then begin
    Result := 0;
    Exit;
  end;
  SourceLen := SourceLen - StartPos;
  SourceLen := SourceLen +2;
  asm
    push ESI
    push EDI
    push EBX

    mov EDI, aSourceString
    add EDI, StartPos
    Dec EDI
    mov ESI, aFindString
    mov ECX, SourceLen

    Mov  Al, [ESI]

    and  Al, $df
    @ScaSB:
    Mov  Ah, [EDI]
    and  Ah, $df
    cmp  Ah,Al
    jne  @NextChar

    @CompareStrings:
    mov  EBX, aFindLen
    dec  EBX
    @CompareNext:
    mov  Al, [ESI+EBX]
    mov  Ah, [EDI+EBX]
    and  Al, $df
    and  Ah, $df
    cmp  Al, Ah
    Jz   @Matches
    Mov  Al, [ESI]
    and  Al, $df
    Jmp  @NextChar
    @Matches:
    Dec  EBX
    Jnz  @CompareNext
    mov  EAX, EDI
    sub  EAX, aSourceString
    inc  EAX
    mov  Result, EAX
    jmp  @TheEnd
    @NextChar:
    Inc  EDI
    dec  ECX
    jnz  @ScaSB
    mov  Result,0

    @TheEnd:
    pop  EBX
    pop  EDI
    pop  ESI
  end;
end;

procedure MyMove(const Source; var Dest; Count : Integer);
asm
  cmp   ECX,0
  Je    @JustQuit

  push  ESI
  push  EDI

  mov   ESI, EAX
  mov   EDI, EDX

  @Loop:
  Mov   AL, [ESI]
  Inc   ESI
  mov   [EDI], AL
  Inc   EDI
  Dec   ECX
  Jnz   @Loop


  pop   EDI
  pop   ESI
  @JustQuit:
end;

function FastReplace(var aSourceString : String; const aFindString, aReplaceString : String; CaseSensitive : Boolean = False) : String;
var
  ActualResultLen,
  CurrentPos,
  LastPos,
  BytesToCopy,
  ResultLen,
  FindLen,
  ReplaceLen,
  SourceLen         : Integer;

  FastPosProc       : TFastPosProc;
begin
  if CaseSensitive then
    FastPosProc := FastPOS
  else
    FastPOSProc := FastPOSNoCase;

  Result := '';

  FindLen := Length(aFindString);
  ReplaceLen := Length(aReplaceString);
  SourceLen := Length(aSourceString);


  if ReplaceLen <= FindLen then
    ActualResultLen := SourceLen
  else
    ActualResultLen := SourceLen + (SourceLen * ReplaceLen div FindLen) + ReplaceLen;

  SetLength(Result,ActualResultLen);

  CurrentPos := 1;
  ResultLen := 0;
  LastPos := 1;

  if ReplaceLen > 0 then begin
    repeat
      CurrentPos := FastPosProc(aSourceString, aFindString,SourceLen, FindLen, CurrentPos);

      if CurrentPos = 0 then break;

      BytesToCopy := CurrentPos-LastPos;

      MyMove(aSourceString[LastPos],Result[ResultLen+1], BytesToCopy);

      MyMove(aReplaceString[1],Result[ResultLen+1+BytesToCopy], ReplaceLen);

      ResultLen := ResultLen + BytesToCopy + ReplaceLen;

      CurrentPos := CurrentPos + FindLen;
      LastPos := CurrentPos;
    until false;
  end else begin
    repeat
      CurrentPos := FastPos(aSourceString,
        aFindString, SourceLen, FindLen, CurrentPos);
      if CurrentPos = 0 then break;

      BytesToCopy := CurrentPos-LastPos;

      MyMove(aSourceString[LastPos],
        Result[ResultLen+1], BytesToCopy);
      ResultLen := ResultLen +
        BytesToCopy + ReplaceLen;

      CurrentPos := CurrentPos + FindLen;
      LastPos := CurrentPos;
    until false;
  end;

  Dec(LastPOS);

  SetLength(Result, ResultLen + (SourceLen-LastPos));

  if LastPOS+1 <= SourceLen then
    MyMove(aSourceString[LastPos+1],Result[ResultLen+1],SourceLen-LastPos);
end;

function ExcelStrToWideString(S: string): WideString;
begin
  if Length(S) <= 0 then
    Result := ''
  else begin
    if S[1] = #0 then begin
      Result := Copy(S,2,MAXINT);
    end
    else if S[1] = #1 then begin
      SetLength(Result,(Length(S) - 1) div 2);
      S := Copy(S,2,MAXINT);
      Move(Pointer(S)^,Pointer(Result)^,Length(S) - 1);
    end
    else
      raise Exception.Create('Bad excel string id.');
  end;
end;

function IntToXColor(Value: word): TExcelColor;
begin
  if Value <= Word(High(TExcelColor)) then
    Result := TExcelColor(Value)
  else
    Result := xcAutomatic;
end;

function XColorToTColor(XC: TExcelColor): TColor;
begin
  Result := ExcelColorPalette[Integer(XC)];
end;

function XColorToRGB(XC: TExcelColor): longword;
var
  tmp: longword;
begin
  Result := XColorToTColor(XC);
  tmp := Result and $00FF0000;
  Result := Result + (((Result and $000000FF) shl 16) or tmp);
end;

function BufUnicodeZToWS(Buf: PByteArray; Len: integer): WideString;
begin
  if Len > 0 then begin
    SetLength(Result,(Len div 2) - 1);
    Move(Buf^,Pointer(Result)^,Len - 2);
  end
  else
    Result := '';
end;

function DecodeRK(Value: longint): double;
var
  RK: TRK;
begin
  RK.DW[0] := 0;
//  RK.DW[1] := Value and $FFFFFFFC;
  RK.DW[1] := Value and LongInt($FFFFFFFC);   
  case (Value and $3) of
    0: Result := RK.V;
    1: Result := RK.V / 100;
    2: Result := Integer(RK.DW[1]) / 4;
    3: Result := Integer(RK.DW[1]) / 400;
    else
      Result := RK.V;
  end;
end;

function ClipAreaToSheet(var C1,R1,C2,R2: integer): boolean;
begin
  if (C1 > MAXCOL) or (R1 > MAXROW) or (C2 < 0) or (R2 < 0) then
    Result := False
  else begin
    C1 := Max(C1,0);
    R1 := Max(R1,0);
    C2 := Min(C2,MAXCOL);
    R2 := Min(R2,MAXROW);
    Result := True;
  end;
end;

function TColorToClosestXColor(Color: TColor): TExcelColor;
var
  i,j: integer;
  C: integer;
  R1,G1,B1: byte;
  R2,G2,B2: byte;
  V1,V2: double;
begin
  j := 8;
  R1 := Color and $FF;
  G1 := (Color and $FF00) shr 8;
  B1 := (Color and $FF0000) shr 16;
  V1 := $FFFFFF;
  for i := 8 to 63 do begin
    C := ExcelColorPalette[i];
    R2 := C and $FF;
    G2 := (C and $FF00) shr 8;
    B2 := (C and $FF0000) shr 16;
    V2 := Abs(R1 - R2) + Abs(G1 - G2) + Abs(B1 - B2);
    if Abs(V2) < Abs(V1) then begin
      V1 := V2;
      j := i;
    end;
  end;
  Result := TExcelColor(j);
end;

function MyWideUppercase(S: WideString): WideString;
begin
{$ifdef OLD_COMPILER}
  Result := AnsiUppercase(S);
{$else}
  Result := WideUppercase(S);
{$endif}
end;

end.