xlsstream2.pas

一个经典的读写Excel的控件

    FWrittenBytes := 0;
    Dec(Count,WBytes);
    P := Pointer(Integer(P) + WBytes);
    CheckCONTINUEWrite(P^,Count);
  end
  else begin
    IntWrite(Buffer,Count);
    Inc(FWrittenBytes,Count);
  end;
end;

function TXLSStream.Seek(Offset: Longint; Origin: Word): integer;
var
  Pos: largeint;
begin
  if FStream = Nil then begin
    case Origin of
      soFromBeginning:
        OleCheck(OleStream.Seek(Offset,STREAM_SEEK_SET,Pos));
      soFromCurrent:
        OleCheck(OleStream.Seek(Offset,STREAM_SEEK_CUR,Pos));
      soFromEnd:
        OleCheck(OleStream.Seek(Offset,STREAM_SEEK_END,Pos));
    end;
    Result := Pos;
  end
  else
    Result := FStream.Seek(Offset,Origin);
end;

function TXLSStream.Pos: longint;
begin
  Result := Seek(0,1);
end;

function TXLSStream.OpenRead(const Filename: WideString): TExcelVersion;
begin
  if (FSourceStream <> Nil) or (StgIsStorageFile(PWideChar(Filename)) = S_OK) then
    Result := OpenOLEStreamRead(PWideChar(Filename))
  else
    Result := OpenFileStreamRead(Filename);
end;

procedure TXLSStream.OpenWrite(const Filename: WideString; Version: TExcelVersion);
begin
  Close;
  if Version >= xvExcel50 then begin
    if Assigned(FTargetStream) then begin
      OleCheck(CreateILockBytesOnHGlobal(0, True, FLockBytes));
      OleCheck(StgCreateDocfileOnILockBytes(FLockBytes, STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, OleStorage));
    end
    else begin
      if Filename = '' then
        raise Exception.Create('Filename is missing');
      OleCheck(StgCreateDocfile(PWideChar(Filename), STGM_DIRECT or STGM_READWRITE or STGM_CREATE or STGM_SHARE_EXCLUSIVE, 0, OleStorage));
    end;
    if FExtraObjects <> Nil then
      FExtraObjects.WriteStreams(OleStorage);
    if Version = xvExcel50 then
      OleStorage.CreateStream('Book',STGM_DIRECT or STGM_WRITE or STGM_CREATE or STGM_SHARE_EXCLUSIVE,0,0,OleStream)
//      OleCheck(OleStorage.CreateStream('Book',STGM_DIRECT or STGM_WRITE or STGM_CREATE or STGM_SHARE_EXCLUSIVE,0,0,OleStream))
    else
      // STGM_READWRITE for encrypted files
      OleCheck(OleStorage.CreateStream('Workbook',STGM_DIRECT or STGM_READWRITE or STGM_CREATE or STGM_SHARE_EXCLUSIVE,0,0,OleStream));
//      OleCheck(OleStorage.CreateStream('Workbook',STGM_DIRECT or STGM_WRITE or STGM_CREATE or STGM_SHARE_EXCLUSIVE,0,0,OleStream));
  end
  else begin
    if Assigned(FTargetStream) then
      FStream := FTargetStream
    else
      FStream := TFileStream.Create(Filename,fmCreate);
  end;
end;

procedure TXLSStream.WriteStorageToDestStream;
var
  DataHandle: HGLOBAL;
  Buffer: Pointer;
begin
  OleCheck(FLockBytes.Flush);
  OleCheck(GetHGlobalFromILockBytes(FLockBytes, DataHandle));
  Buffer := GlobalLock(DataHandle);
  try
    FTargetStream.WriteBuffer(Buffer^, GlobalSize(DataHandle));
  finally
    GlobalUnlock(DataHandle);
  end;
end;

procedure TXLSStream.BeginCONTINUEWrite(MaxRecSize: integer);
begin
  FMaxBytesWrite := MaxRecSize;
  FWrittenBytes := 0;
  FWriteCONTINUEPos := Pos;
end;

procedure TXLSStream.EndCONTINUEWrite;
var
  V: word;
begin
  if FWrittenBytes > 0 then begin
    Seek(FWriteCONTINUEPos + 2,soFromBeginning);
    V := FWrittenBytes;
    IntWrite(V,SizeOf(word));
    Seek(0,soFromEnd);
  end;
  FMaxBytesWrite := -1;
end;

procedure TXLSStream.WLWord(Value: longword);
begin
  IntWrite(Value,SizeOf(longword));
end;

procedure TXLSStream.WWord(Value: word);
begin
  IntWrite(Value,SizeOf(word));
end;

procedure TXLSStream.WByte(Value: byte);
begin
  IntWrite(Value,SizeOf(byte));
end;

procedure TXLSStream.WriteUnicodeStr16(Value: string);
var
  L: word;
begin
  if Length(Value) <= 0 then
    WWord(0)
  else begin
    if Value[1] = #1 then
      L := (Length(Value) - 1) div 2
    else
      L := Length(Value) - 1;
    WWord(L);
    Write(Pointer(Value)^,Length(Value));
  end;
end;

procedure TXLSStream.WriteUnicodeStr8(Value: string);
var
  L: byte;
begin
  if Length(Value) <= 0 then
    WByte(0)
  else begin
    if Value[1] = #1 then
      L := (Length(Value) - 1) div 2
    else
      L := Length(Value) - 1;
    WByte(L);
    Write(Pointer(Value)^,Length(Value));
  end;
end;

procedure TXLSStream.WriteWideString(Value: WideString);
begin
  WWord(Length(Value));
  if Value <> '' then begin
    WByte(1);
    Write(Pointer(Value)^,Length(Value) * 2);
  end
end;

function TXLSStream.ReadWideString(Length: integer; var Str: WideString): integer;
var
  B: byte;
  S: string;
begin
  Read(B,1);
  if B = 1 then begin
    SetLength(Str,Length);
    Read(Pointer(Str)^,Length * 2);
    Result := Length * 2 + 1;
  end
  else begin
    SetLength(S,Length);
    Read(Pointer(S)^,Length);
    Str := S;
    Result := Length+ 1;
  end;
end;

procedure TXLSStream.BeginCONTINUERead;
begin
  FReadCONTINUEActive := True;
  FReadCONTINUEPos := 0;
end;

procedure TXLSStream.EndCONTINUERead;
begin
  FReadCONTINUEActive := False;
  FReadCONTINUEPos := 0;
end;

function TXLSStream.SetReadDecrypt(FILEPASS: PRecFILEPASS; Password: WideString): boolean;
begin
  Result := VerifyPassword(FILEPASS,Password);
  if Result then begin
    FIsEncrypted := True;
    FNextReKeyBlock := -1;
    EncryptSkipBytes(0,Pos);
  end;
end;

procedure TXLSStream.EncryptSkipBytes(Start, Count: integer);
var
  Buf: array[0..EncryptReKeyBlockSz - 1] of byte;
  Block: integer;
begin
  Block := (Start + Count) div EncryptReKeyBlockSz;
  if Block <> FNextReKeyBlock then begin
    FNextReKeyBlock := Block;
    MakeKey(FNextReKeyBlock,FMD5Ctx,FRC4Key);
    Count := (Start + Count) mod EncryptReKeyBlockSz;
  end;
  RC4(@Buf,Count,FRC4Key);
end;

procedure TXLSStream.Decrypt(Buffer: PByteArray; Count: integer);
var
  p,Step: integer;
begin
  p := Pos - Count;
  while FNextReKeyBlock <> ((p + Count) div EncryptReKeyBlockSz) do begin
    Step := EncryptReKeyBlockSz - (p mod EncryptReKeyBlockSz);
    RC4(Buffer,Step,FRC4Key);
    Buffer := PByteArray(Integer(Buffer) + Step);
    Inc(p,Step);
    Dec(Count,Step);
    Inc(FNextReKeyBlock);
    MakeKey(FNextReKeyBlock,FMD5Ctx,FRC4Key);
  end;
  RC4(Buffer,Count,FRC4Key);
end;

procedure TXLSStream.MakeKey(Block: longword; ctxVal: TMD5Context; var Key: TRC4Key);
var
  Ctx: TMD5Context;
  PWArray: array[0..63] of byte;
  MD5: TMD5;
begin
  FillChar(PWarray,SizeOf(PWArray),0);

  Move(ctxVal.Digest[0],PWArray[0],5);

  PWArray[5] := Byte(Block and $FF);
  PWArray[6] := Byte((Block shr 8) and $FF);
  PWArray[7] := Byte((Block shr 16) and $FF);
  PWArray[8] := Byte((Block shr 24) and $FF);
  PWArray[9] := $80;
  PWArray[56] := $48;

  MD5 := TMD5.Create;
  try
    MD5.Init(Ctx);
    MD5.Update(Ctx,@PWArray,64);
    MD5.Store(Ctx);
  finally
    MD5.Free;
  end;
  RC4PrepareKey(@Ctx.Digest,16,Key);
end;

function TXLSStream.VerifyPassword(FILEPASS: PRecFILEPASS; Password: WideString): boolean;
var
  i: integer;
  PWArray: array[0..63] of byte;
  Ctx1,Ctx2: TMD5Context;
  Salt: array[0..63] of byte;
  HashedSalt: array[0..63] of byte;
  MD5: TMD5;
  Offset,KeyOffset: integer;
  ToCopy: longword;
begin
  // What is the max password length? How does Excel deal with passwords
  // exceeding max length?
  Password := Copy(Password,1,(Length(PWArray) div 2) - 1);
  FillChar(PWarray,SizeOf(PWArray),0);
  for i := 1 to Length(Password) do
    PWordArray(@PWarray)[i - 1] := Word(Password[i]);
  PWarray[Length(Password) * 2] := $80;
  PWarray[56] := Length(Password) shl 4;

  MD5 := TMD5.Create;
  try
    MD5.Init(Ctx1);
    MD5.Update(Ctx1,@PWArray,64);
    MD5.Store(Ctx1);

    Offset := 0;
    KeyOffset := 0;
    ToCopy := 5;

    MD5.Init(FMD5Ctx);
    while Offset <> 16 do begin
      if (64 - Offset) < 5 then
        ToCopy := 64 - Offset;

      Move(Ctx1.Digest[KeyOffset],PWArray[Offset],ToCopy);
      Inc(Offset,ToCopy);

      if Offset = 64 then begin
        MD5.Update(FMD5Ctx,@PWArray,64);
        KeyOffset := ToCopy;
        ToCopy := 5 - ToCopy;
        Offset := 0;
        Continue;
      end;

      KeyOffset := 0;
      ToCopy := 5;
      Move(FILEPASS.DocId,PWArray[Offset],16);
      Inc(Offset,16);
    end;
    PWArray[16] := $80;
    FillChar(PWArray[17],47,0);
    PWArray[56] := $80;
    PWArray[57] := $0A;

    MD5.Update(FMD5Ctx,@PWArray, 64);
    MD5.Store(FMD5Ctx);

//    WriteBuf(@ctxVal.Digest,16);

    MakeKey (0,FMD5Ctx,FRC4Key);

    Move(FILEPASS.Salt,Salt,SizeOf(FILEPASS.Salt));
    RC4(@Salt,16,FRC4Key);
    Move(FILEPASS.HashedSalt,HashedSalt,16);
    RC4(@HashedSalt,16,FRC4Key);

    Salt[16] := $80;
    FillChar(Salt[17],47,0);
    Salt[56] := $80;

    MD5.Init(Ctx2);
    MD5.Update(Ctx2,@Salt,64);
    MD5.Store(Ctx2);

    Result := CompareMem(@Ctx2.Digest,@HashedSalt,16);
  finally
    MD5.Free;
  end;
end;

procedure TXLSStream.WriteFile(RecId, Length: word; Filename: string);
var
  S: string;
  B: byte;
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(Filename,fmOpenRead);
  try
    WriteHeader(RecId,Length);
    SetLength(S,3);
    while (Length > 0) and (Stream.Read(Pointer(S)^,3) = 3) do begin
      B := 0;
      if S[1] in ['0'..'9'] then
        B := (Byte(S[1]) - Byte('0')) shl 4
      else if S[1] in ['A'..'F'] then
        B := (Byte(S[1]) - Byte('A') + 10) shl 4;
      if S[2] in ['0'..'9'] then
        B := B + (Byte(S[2]) - Byte('0'))
      else if S[2] in ['A'..'F'] then
        B := B + (Byte(S[2]) - Byte('A') + 10);
      WByte(B);
      Dec(Length);
    end;
  finally
    Stream.Free;
  end;
end;

function TXLSStream.PeekHeader: word;
var
  Header: TBIFFHeader;
begin
  if Read(Header,SizeOf(TBIFFHeader)) = SizeOf(TBIFFHeader) then begin
    Result := Header.RecID;
    Seek(-SizeOf(TBIFFHeader),soFromCurrent);
  end
  else
    Result := 0;
end;

procedure TXLSStream.WriteCONTINUE(RecId: word; const Buffer; Count: Integer);
var
  P: PByteArray;
  L,L2: integer;
begin
  WWord(RecId);
  if Count > MAXRECSZ_97 then begin
    WWord(MAXRECSZ_97);
    Write(Buffer,MAXRECSZ_97);
    P := PByteArray(Integer(@Buffer) + MAXRECSZ_97);
    L := Count - MAXRECSZ_97;
    while L > 0 do begin
      WWord(BIFFRECID_CONTINUE);
      if L > MAXRECSZ_97 then
        L2 := MAXRECSZ_97
      else
        L2 := L;
      Write(L2,2);
      Write(P^,L2);
      P := PByteArray(Integer(P) + L2);
      Dec(L,MAXRECSZ_97);
    end;
  end
  else begin
    WWord(Count);
    if Count > 0 then
      Write(Buffer,Count);
  end;
end;

procedure TXLSStream.WriteCellArea(Area: TRecCellArea);
begin
  WWord(Area.Row1);
  WWord(Area.Row2);
  WWord(Area.Col1);
  WWord(Area.Col2);
end;

procedure TXLSStream.CreatePassword(FILEPASS: PRecFILEPASS; Password: WideString);
var
  i: integer;
  PWArray: array[0..63] of byte;
  Ctx1,Ctx2: TMD5Context;
  Salt: array[0..63] of byte;
  HashedSalt: array[0..63] of byte;
  MD5: TMD5;
  Offset,KeyOffset: integer;
  ToCopy: longword;
begin
  FillChar(PWarray,SizeOf(PWArray),0);
  for i := 1 to Length(Password) do
    PWordArray(@PWarray)[i - 1] := Word(Password[i]);
  PWarray[Length(Password) * 2] := $80;
  PWarray[56] := Length(Password) shl 4;

  MD5 := TMD5.Create;
  try
    MD5.Init(Ctx1);
    MD5.Update(Ctx1,@PWArray,64);
    MD5.Store(Ctx1);

    Offset := 0;
    KeyOffset := 0;
    ToCopy := 5;

    MD5.Init(FMD5Ctx);
    while Offset <> 16 do begin
      if (64 - Offset) < 5 then
        ToCopy := 64 - Offset;

      Move(Ctx1.Digest[KeyOffset],PWArray[Offset],ToCopy);
      Inc(Offset,ToCopy);

      if Offset = 64 then begin
        MD5.Update(FMD5Ctx,@PWArray,64);
        KeyOffset := ToCopy;
        ToCopy := 5 - ToCopy;
        Offset := 0;
        Continue;
      end;

      KeyOffset := 0;
      ToCopy := 5;
      Move(PWArray[Offset],FILEPASS.DocId,16);
      Inc(Offset,16);
    end;
    PWArray[16] := $80;
    FillChar(PWArray[17],47,0);
    PWArray[56] := $80;
    PWArray[57] := $0A;

    MD5.Update(FMD5Ctx,@PWArray, 64);
    MD5.Store(FMD5Ctx);

//    WriteBuf(@ctxVal.Digest,16);

    MakeKey (0,FMD5Ctx,FRC4Key);

    Move(FILEPASS.Salt,Salt,SizeOf(FILEPASS.Salt));
    RC4(@Salt,16,FRC4Key);
    Move(FILEPASS.HashedSalt,HashedSalt,16);
    RC4(@HashedSalt,16,FRC4Key);

    Salt[16] := $80;
    FillChar(Salt[17],47,0);
    Salt[56] := $80;

    MD5.Init(Ctx2);
    MD5.Update(Ctx2,@Salt,64);
    MD5.Store(Ctx2);

//    Result := CompareMem(@Ctx2.Digest,@HashedSalt,16);
  finally
    MD5.Free;
  end;
end;

procedure TXLSStream.EncryptFile(Password: WideString);
var
  Header: TBIFFHeader;
  PBuf: PByteArray;
begin
  GetMem(PBuf,MAXRECSZ_97);
  try
    Seek(0,soFromBeginning);
    ReadHeader(Header);
    Read(PBuf^,Header.Length);
    ReadHeader(Header);
    if Header.RecID <> BIFFRECID_FILEPASS then
      raise Exception.Create('Record FILEPASS missing');
    CreatePassword(PRecFILEPASS(PBuf),Password);
//    Read(PBuf^,Header.Length);
  finally
    FreeMem(PBuf);
  end;
end;

function TXLSStream.Seek3(Offset: Integer; Origin: Word): longint;
begin
  Result := Seek(Offset,Origin);
end;

end.