SevenZip.pas BUG修改版

原始版本: Henri Gourvest <hgourvest@gmail.com> 1.2版本
BUG修改:
1.对于文件名中带有空格的文件, 无法压缩, 原因是1488行, 压缩调用的是TStringList.Delimiter 来拆分文件字符串, 而空格是默认分行符, 导致文件名错误
2.解压缩函数, 如果目标文件已存在并且为只读属性时, 报错, 原因是1105行创建文件流的时候直接使用了TFileStream.Create(path, fmCreate)导致
3.解压缩函数, 解决如果是空文件夹不会被创建的问题
功能增加:
1.增加了一个WorkPath变量, 用于指定7z.dll文件的绝对路径
2.增加了一个解压缩过程中文件释放失败时的回调T7zProgressExceptCallback, 支持忽略/重试/取消
(********************************************************************************)

(*                        7-ZIP DELPHI API                                      *)

(*                                                                              *)

(* The contents of this file are subject to the Mozilla Public License Version  *)

(* 1.1 (the "License"); you may not use this file except in compliance with the *)

(* License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ *)

(*                                                                              *)

(* Software distributed under the License is distributed on an "AS IS" basis,   *)

(* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *)

(* the specific language governing rights and limitations under the License.    *)

(*                                                                              *)

(* Unit owner : Henri Gourvest <hgourvest@gmail.com>                            *)

(* V1.2.1                                                                       *)

(********************************************************************************)

(*

2017-06-08 刘志林 修改

BUG修改:

1.对于文件名中带有空格的文件, 无法压缩, 原因是1488行, 压缩调用的是TStringList.Delimiter 来拆分文件字符串, 而空格是默认分行符, 导致文件名错误

2.解压缩函数, 如果目标文件已存在并且为只读属性时, 报错, 原因是1105行 创建文件流的时候直接使用了TFileStream.Create(path, fmCreate)导致

3.解压缩函数, 解决如果是空文件夹不会被创建的问题

功能增加:

1.增加了一个WorkPath变量, 用于指定7z.dll文件的绝对路径

2.增加了一个解压缩过程中文件释放失败时的回调T7zProgressExceptCallback, 支持忽略/重试/取消

*)

unit SevenZIP;

{$ALIGN ON}

{$MINENUMSIZE 4}

{$WARN SYMBOL_PLATFORM OFF}    

interface

uses SysUtils, Windows, ActiveX, Classes, Contnrs;

type

  PVarType = ^TVarType;

  PCardArray = ^TCardArray;

  TCardArray = array[..MaxInt div SizeOf(Cardinal) - ] of Cardinal;

{$IFNDEF UNICODE}

  UnicodeString = WideString;

{$ENDIF}

//******************************************************************************

// PropID.h

//******************************************************************************

const

  kpidNoProperty       = ;

  kpidHandlerItemIndex = ;

  kpidPath             = ;  // VT_BSTR

  kpidName             = ;  // VT_BSTR

  kpidExtension        = ;  // VT_BSTR

  kpidIsFolder         = ;  // VT_BOOL

  kpidSize             = ;  // VT_UI8

  kpidPackedSize       = ;  // VT_UI8

  kpidAttributes       = ;  // VT_UI4

  kpidCreationTime     = ; // VT_FILETIME

  kpidLastAccessTime   = ; // VT_FILETIME

  kpidLastWriteTime    = ; // VT_FILETIME

  kpidSolid            = ; // VT_BOOL

  kpidCommented        = ; // VT_BOOL

  kpidEncrypted        = ; // VT_BOOL

  kpidSplitBefore      = ; // VT_BOOL

  kpidSplitAfter       = ; // VT_BOOL

  kpidDictionarySize   = ; // VT_UI4

  kpidCRC              = ; // VT_UI4

  kpidType             = ; // VT_BSTR

  kpidIsAnti           = ; // VT_BOOL

  kpidMethod           = ; // VT_BSTR

  kpidHostOS           = ; // VT_BSTR

  kpidFileSystem       = ; // VT_BSTR

  kpidUser             = ; // VT_BSTR

  kpidGroup            = ; // VT_BSTR

  kpidBlock            = ; // VT_UI4

  kpidComment          = ; // VT_BSTR

  kpidPosition         = ; // VT_UI4

  kpidPrefix           = ; // VT_BSTR

  kpidNumSubDirs       = ; // VT_UI4

  kpidNumSubFiles      = ; // VT_UI4

  kpidUnpackVer        = ; // VT_UI1

  kpidVolume           = ; // VT_UI4

  kpidIsVolume         = ; // VT_BOOL

  kpidOffset           = ; // VT_UI8

  kpidLinks            = ; // VT_UI4

  kpidNumBlocks        = ; // VT_UI4

  kpidNumVolumes       = ; // VT_UI4

  kpidTimeType         = ; // VT_UI4

  kpidBit64            = ; // VT_BOOL

  kpidBigEndian        = ; // VT_BOOL

  kpidCpu              = ; // VT_BSTR

  kpidPhySize          = ; // VT_UI8

  kpidHeadersSize      = ; // VT_UI8

  kpidChecksum         = ; // VT_UI4

  kpidCharacts         = ; // VT_BSTR

  kpidVa               = ; // VT_UI8

  kpidTotalSize        = $; // VT_UI8

  kpidFreeSpace        = kpidTotalSize + ; // VT_UI8

  kpidClusterSize      = kpidFreeSpace + ; // VT_UI8

  kpidVolumeName       = kpidClusterSize + ; // VT_BSTR

  kpidLocalName        = $; // VT_BSTR

  kpidProvider         = kpidLocalName + ; // VT_BSTR

  kpidUserDefined      = $;

//******************************************************************************

// IProgress.h

//******************************************************************************

type

  IProgress = interface(IUnknown)

  ['{23170F69-40C1-278A-0000-000000050000}']

    function SetTotal(total: Int64): HRESULT; stdcall;

    function SetCompleted(completeValue: PInt64): HRESULT; stdcall;

  end;

//******************************************************************************

// IPassword.h

//******************************************************************************

  ICryptoGetTextPassword = interface(IUnknown)

  ['{23170F69-40C1-278A-0000-000500100000}']

    function CryptoGetTextPassword(var password: TBStr): HRESULT; stdcall;

  end;

  ICryptoGetTextPassword2 = interface(IUnknown)

  ['{23170F69-40C1-278A-0000-000500110000}']

    function CryptoGetTextPassword2(passwordIsDefined: PInteger; var password: TBStr): HRESULT; stdcall;

  end;

//******************************************************************************

// IStream.h

// "23170F69-40C1-278A-0000-000300xx0000"

//******************************************************************************

  ISequentialInStream = interface(IUnknown)

  ['{23170F69-40C1-278A-0000-000300010000}']

    function Read(data: Pointer; size: Cardinal; processedSize: PCardinal): HRESULT; stdcall;

    (*

    Out: if size != 0, return_value = S_OK and (*processedSize == 0),

      then there are no more bytes in stream.

    if (size > 0) && there are bytes in stream,

    this function must read at least 1 byte.

    This function is allowed to read less than number of remaining bytes in stream.

    You must call Read function in loop, if you need exact amount of data

    *)

  end;

  ISequentialOutStream = interface(IUnknown)

  ['{23170F69-40C1-278A-0000-000300020000}']

    function Write(data: Pointer; size: Cardinal; processedSize: PCardinal): HRESULT; stdcall;

    (*

    if (size > 0) this function must write at least 1 byte.

    This function is allowed to write less than "size".

    You must call Write function in loop, if you need to write exact amount of data

    *)

  end;

  IInStream = interface(ISequentialInStream)

  ['{23170F69-40C1-278A-0000-000300030000}']

    function Seek(offset: Int64; seekOrigin: Cardinal; newPosition: PInt64): HRESULT; stdcall;

  end;

  IOutStream = interface(ISequentialOutStream)

  ['{23170F69-40C1-278A-0000-000300040000}']

    function Seek(offset: Int64; seekOrigin: Cardinal; newPosition: PInt64): HRESULT; stdcall;

    function SetSize(newSize: Int64): HRESULT; stdcall;

  end;

  IStreamGetSize = interface(IUnknown)

  ['{23170F69-40C1-278A-0000-000300060000}']

    function GetSize(size: PInt64): HRESULT; stdcall;

  end;

  IOutStreamFlush = interface(IUnknown)

  ['{23170F69-40C1-278A-0000-000300070000}']

    function Flush: HRESULT; stdcall;

  end;

//******************************************************************************

// IArchive.h

//******************************************************************************

// MIDL_INTERFACE("23170F69-40C1-278A-0000-000600xx0000")

//#define ARCHIVE_INTERFACE_SUB(i, base,  x) \

//DEFINE_GUID(IID_ ## i, \

//0x23170F69, 0x40C1, 0x278A, 0x00, 0x00, 0x00, 0x06, 0x00, x, 0x00, 0x00); \

//struct i: public base

//#define ARCHIVE_INTERFACE(i, x) ARCHIVE_INTERFACE_SUB(i, IUnknown, x)

type

// NFileTimeType

  NFileTimeType = (

    kWindows = ,

    kUnix,

    kDOS

  );

// NArchive::

  NArchive = (

    kName = ,          // string

    kClassID,           // GUID

    kExtension,         // string  zip rar gz

    kAddExtension,      // sub archive: tar

    kUpdate,            // bool

    kKeepName,          // bool

    kStartSignature,    // string[4] ex: PK.. 7z.. Rar!

    kFinishSignature,

    kAssociate

  );

// NArchive::NExtract::NAskMode

  NAskMode = (

    kExtract = ,

    kTest,

    kSkip

  );

// NArchive::NExtract::NOperationResult

  NExtOperationResult = (

    kOK = ,

    kUnSupportedMethod,

    kDataError,

    kCRCError

  );

// NArchive::NUpdate::NOperationResult

  NUpdOperationResult = (

    kOK_   = ,

    kError

  );

  IArchiveOpenCallback = interface

  ['{23170F69-40C1-278A-0000-000600100000}']

    function SetTotal(files, bytes: PInt64): HRESULT; stdcall;

    function SetCompleted(files, bytes: PInt64): HRESULT; stdcall;

  end;

  IArchiveExtractCallback = interface(IProgress)

  ['{23170F69-40C1-278A-0000-000600200000}']

    function GetStream(index: Cardinal; var outStream: ISequentialOutStream;

        askExtractMode: NAskMode): HRESULT; stdcall;

    // GetStream OUT: S_OK - OK, S_FALSE - skeep this file

    function PrepareOperation(askExtractMode: NAskMode): HRESULT; stdcall;

    function SetOperationResult(resultEOperationResult: NExtOperationResult): HRESULT; stdcall;

  end;

  IArchiveOpenVolumeCallback = interface

  ['{23170F69-40C1-278A-0000-000600300000}']

    function GetProperty(propID: PROPID; var value: OleVariant): HRESULT; stdcall;

    function GetStream(const name: PWideChar; var inStream: IInStream): HRESULT; stdcall;

  end;

  IInArchiveGetStream = interface

  ['{23170F69-40C1-278A-0000-000600400000}']

    function GetStream(index: Cardinal; var stream: ISequentialInStream ): HRESULT; stdcall;

  end;

  IArchiveOpenSetSubArchiveName = interface

  ['{23170F69-40C1-278A-0000-000600500000}']

    function SetSubArchiveName(name: PWideChar): HRESULT; stdcall;

  end;

  IInArchive = interface

  ['{23170F69-40C1-278A-0000-000600600000}']

    function Open(stream: IInStream; const maxCheckStartPosition: PInt64;

        openArchiveCallback: IArchiveOpenCallback): HRESULT; stdcall;

    function Close: HRESULT; stdcall;

    function GetNumberOfItems(var numItems: CArdinal): HRESULT; stdcall;

    function GetProperty(index: Cardinal; propID: PROPID; var value: OleVariant): HRESULT; stdcall;

    function Extract(indices: PCardArray; numItems: Cardinal;

        testMode: Integer; extractCallback: IArchiveExtractCallback): HRESULT; stdcall;

    // indices must be sorted

    // numItems = 0xFFFFFFFF means all files

    // testMode != 0 means "test files operation"

    function GetArchiveProperty(propID: PROPID; var value: OleVariant): HRESULT; stdcall;

    function GetNumberOfProperties(numProperties: PCardinal): HRESULT; stdcall;

    function GetPropertyInfo(index: Cardinal;

        name: PBSTR; propID: PPropID; varType: PVarType): HRESULT; stdcall;

    function GetNumberOfArchiveProperties(var numProperties: Cardinal): HRESULT; stdcall;

    function GetArchivePropertyInfo(index: Cardinal;

        name: PBSTR; propID: PPropID; varType: PVARTYPE): HRESULT; stdcall;

  end;

  IArchiveUpdateCallback = interface(IProgress)

  ['{23170F69-40C1-278A-0000-000600800000}']

    function GetUpdateItemInfo(index: Cardinal;

        newData: PInteger; // 1 - new data, 0 - old data

        newProperties: PInteger; // 1 - new properties, 0 - old properties

        indexInArchive: PCardinal // -1 if there is no in archive, or if doesn't matter

        ): HRESULT; stdcall;

    function GetProperty(index: Cardinal; propID: PROPID; var value: OleVariant): HRESULT; stdcall;

    function GetStream(index: Cardinal; var inStream: ISequentialInStream): HRESULT; stdcall;

    function SetOperationResult(operationResult: Integer): HRESULT; stdcall;

  end;

  IArchiveUpdateCallback2 = interface(IArchiveUpdateCallback)

  ['{23170F69-40C1-278A-0000-000600820000}']

    function GetVolumeSize(index: Cardinal; size: PInt64): HRESULT; stdcall;

    function GetVolumeStream(index: Cardinal; var volumeStream: ISequentialOutStream): HRESULT; stdcall;

  end;

  IOutArchive = interface

  ['{23170F69-40C1-278A-0000-000600A00000}']

    function UpdateItems(outStream: ISequentialOutStream; numItems: Cardinal;

      updateCallback: IArchiveUpdateCallback): HRESULT; stdcall;

    function GetFileTimeType(type_: PCardinal): HRESULT; stdcall;

  end;

  ISetProperties = interface

  ['{23170F69-40C1-278A-0000-000600030000}']

    function SetProperties(names: PPWideChar; values: PPROPVARIANT; numProperties: Integer): HRESULT; stdcall;

  end;

//******************************************************************************

// ICoder.h

// "23170F69-40C1-278A-0000-000400xx0000"

//******************************************************************************

  ICompressProgressInfo = interface

  ['{23170F69-40C1-278A-0000-000400040000}']

    function SetRatioInfo(inSize, outSize: PInt64): HRESULT; stdcall;

  end;

  ICompressCoder = interface

  ['{23170F69-40C1-278A-0000-000400050000}']

  function Code(inStream, outStream: ISequentialInStream;

      inSize, outSize: PInt64;

      progress: ICompressProgressInfo): HRESULT; stdcall;

  end;

  ICompressCoder2 = interface

  ['{23170F69-40C1-278A-0000-000400180000}']

  function Code(var inStreams: ISequentialInStream;

      var inSizes: PInt64;

      numInStreams: Cardinal;

      var outStreams: ISequentialOutStream;

      var outSizes: PInt64;

      numOutStreams: Cardinal;

      progress: ICompressProgressInfo): HRESULT; stdcall;

  end;

const

//NCoderPropID::

  kDictionarySize    = $;

  kUsedMemorySize    = kDictionarySize + ;

  kOrder             = kUsedMemorySize + ;

  kPosStateBits      = $;

  kLitContextBits    = kPosStateBits + ;

  kLitPosBits        = kLitContextBits + ;

  kNumFastBytes      = $;

  kMatchFinder       = kNumFastBytes + ;

  kMatchFinderCycles = kMatchFinder + ;

  kNumPasses         = $;

  kAlgorithm         = $;

  kMultiThread       = $;

  kNumThreads        = kMultiThread + ;

  kEndMarker         = $;

type

  ICompressSetCoderProperties = interface

  ['{23170F69-40C1-278A-0000-000400200000}']

    function SetCoderProperties(propIDs: PPropID;

      properties: PROPVARIANT; numProperties: Cardinal): HRESULT; stdcall;

  end;

(*

CODER_INTERFACE(ICompressSetCoderProperties, 0x21)

{

  STDMETHOD(SetDecoderProperties)(ISequentialInStream *inStream) PURE;

};

*)

  ICompressSetDecoderProperties2 = interface

  ['{23170F69-40C1-278A-0000-000400220000}']

    function SetDecoderProperties2(data: PByte; size: Cardinal): HRESULT; stdcall;

  end;

  ICompressWriteCoderProperties = interface

  ['{23170F69-40C1-278A-0000-000400230000}']

    function WriteCoderProperties(outStreams: ISequentialOutStream): HRESULT; stdcall;

  end;

  ICompressGetInStreamProcessedSize = interface

  ['{23170F69-40C1-278A-0000-000400240000}']

    function GetInStreamProcessedSize(value: PInt64): HRESULT; stdcall;

  end;

  ICompressSetCoderMt = interface

  ['{23170F69-40C1-278A-0000-000400250000}']

    function SetNumberOfThreads(numThreads: Cardinal): HRESULT; stdcall;

  end;

  ICompressGetSubStreamSize = interface

  ['{23170F69-40C1-278A-0000-000400300000}']

    function GetSubStreamSize(subStream: Int64; value: PInt64): HRESULT; stdcall;

  end;

  ICompressSetInStream = interface

  ['{23170F69-40C1-278A-0000-000400310000}']

    function SetInStream(inStream: ISequentialInStream): HRESULT; stdcall;

    function ReleaseInStream: HRESULT; stdcall;

  end;

  ICompressSetOutStream = interface

  ['{23170F69-40C1-278A-0000-000400320000}']

    function SetOutStream(outStream: ISequentialOutStream): HRESULT; stdcall;

    function ReleaseOutStream: HRESULT; stdcall;

  end;

  ICompressSetInStreamSize = interface

  ['{23170F69-40C1-278A-0000-000400330000}']

    function SetInStreamSize(inSize: PInt64): HRESULT; stdcall;

  end;

  ICompressSetOutStreamSize = interface

  ['{23170F69-40C1-278A-0000-000400340000}']

    function SetOutStreamSize(outSize: PInt64): HRESULT; stdcall;

  end;

  ICompressFilter = interface

  ['{23170F69-40C1-278A-0000-000400400000}']

    function Init: HRESULT; stdcall;

    function Filter(data: PByte; size: Cardinal): Cardinal; stdcall;

    // Filter return outSize (Cardinal)

    // if (outSize <= size): Filter have converted outSize bytes

    // if (outSize > size): Filter have not converted anything.

    //      and it needs at least outSize bytes to convert one block

    //      (it's for crypto block algorithms).

  end;

  ICryptoProperties = interface

  ['{23170F69-40C1-278A-0000-000400800000}']

    function SetKey(Data: PByte; size: Cardinal): HRESULT; stdcall;

    function SetInitVector(data: PByte; size: Cardinal): HRESULT; stdcall;

  end;

  ICryptoSetPassword = interface

  ['{23170F69-40C1-278A-0000-000400900000}']

    function CryptoSetPassword(data: PByte; size: Cardinal): HRESULT; stdcall;

  end;

  ICryptoSetCRC = interface

  ['{23170F69-40C1-278A-0000-000400A00000}']

    function CryptoSetCRC(crc: Cardinal): HRESULT; stdcall;

  end;

//////////////////////

// It's for DLL file

//NMethodPropID::

  NMethodPropID = (

    kID = ,

    kName_,

    kDecoder,

    kEncoder,

    kInStreams,

    kOutStreams,

    kDescription,

    kDecoderIsAssigned,

    kEncoderIsAssigned

  );

//******************************************************************************

// CLASSES

//******************************************************************************

  T7zPasswordCallback = function(sender: Pointer; var password: UnicodeString): HRESULT; stdcall;

  T7zGetStreamCallBack = function(sender: Pointer; index: Cardinal;

    var outStream: ISequentialOutStream): HRESULT; stdcall;

  T7zProgressCallback = function(sender: Pointer; total: boolean; value: int64): HRESULT; stdcall;

  NECallBack = (

    EC_RETRY = ,

    EC_IGNORE,

    EC_CANCEL

  );

  T7zProgressExceptCallback = function(sender: Pointer; AFile: UnicodeString): NECallBack; stdcall;

  I7zInArchive = interface

  ['{022CF785-3ECE-46EF-9755-291FA84CC6C9}']

    procedure OpenFile(const filename: string); stdcall;

    procedure OpenStream(stream: IInStream); stdcall;

    procedure Close; stdcall;

    function GetNumberOfItems: Cardinal; stdcall;

    function GetItemPath(const index: integer): UnicodeString; stdcall;

    function GetItemName(const index: integer): UnicodeString; stdcall;

    function GetItemSize(const index: integer): Cardinal; stdcall;

    function GetItemIsFolder(const index: integer): boolean; stdcall;

    function GetInArchive: IInArchive;

    procedure ExtractItem(const item: Cardinal; Stream: TStream; test: longbool); stdcall;

    procedure ExtractItems(items: PCardArray; count: cardinal; test: longbool;

      sender: pointer; callback: T7zGetStreamCallBack); stdcall;

    procedure ExtractAll(test: longbool; sender: pointer; callback: T7zGetStreamCallBack); stdcall;

    procedure ExtractTo(const path: string); stdcall;

    procedure SetPasswordCallback(sender: Pointer; callback: T7zPasswordCallback); stdcall;

    procedure SetPassword(const password: UnicodeString); stdcall;

    procedure SetProgressCallback(sender: Pointer; callback: T7zProgressCallback); stdcall;

    procedure SetProgressExceptCallback(sender: Pointer; callback: T7zProgressExceptCallback); stdcall;

    procedure SetClassId(const classid: TGUID);

    function GetClassId: TGUID;

    property ClassId: TGUID read GetClassId write SetClassId;

    property NumberOfItems: Cardinal read GetNumberOfItems;

    property ItemPath[const index: integer]: UnicodeString read GetItemPath;

    property ItemName[const index: integer]: UnicodeString read GetItemName;

    property ItemSize[const index: integer]: Cardinal read GetItemSize;

    property ItemIsFolder[const index: integer]: boolean read GetItemIsFolder;

    property InArchive: IInArchive read GetInArchive;

  end;

  I7zOutArchive = interface

  ['{BAA9D5DC-9FF4-4382-9BFD-EC9065BD0125}']

    procedure AddStream(Stream: TStream; Ownership: TStreamOwnership; Attributes: Cardinal;

      CreationTime, LastWriteTime: TFileTime; const Path: UnicodeString;

      IsFolder, IsAnti: boolean); stdcall;

    procedure AddFile(const Filename: TFileName; const Path: UnicodeString); stdcall;

    procedure AddFiles(const Dir, Path, Willcards: string; recurse: boolean); stdcall;

    procedure SaveToFile(const FileName: TFileName); stdcall;

    procedure SaveToStream(stream: TStream); stdcall;

    procedure SetProgressCallback(sender: Pointer; callback: T7zProgressCallback); stdcall;

    procedure CrearBatch; stdcall;

    procedure SetPassword(const password: UnicodeString); stdcall;

    procedure SetPropertie(name: UnicodeString; value: OleVariant); stdcall;

    procedure SetClassId(const classid: TGUID);

    function GetClassId: TGUID;

    property ClassId: TGUID read GetClassId write SetClassId;

  end;

  I7zCodec = interface

  ['{AB48F772-F6B1-411E-907F-1567DB0E93B3}']

  end;

  T7zStream = class(TInterfacedObject, IInStream, IStreamGetSize,

    ISequentialOutStream, ISequentialInStream, IOutStream, IOutStreamFlush)

  private

    FStream: TStream;

    FOwnership: TStreamOwnership;

  protected

    function Read(data: Pointer; size: Cardinal; processedSize: PCardinal): HRESULT; stdcall;

    function Seek(offset: Int64; seekOrigin: Cardinal; newPosition: Pint64): HRESULT; stdcall;

    function GetSize(size: PInt64): HRESULT; stdcall;

    function SetSize(newSize: Int64): HRESULT; stdcall;

    function Write(data: Pointer; size: Cardinal; processedSize: PCardinal): HRESULT; stdcall;

    function Flush: HRESULT; stdcall;

  public

    constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference);

    destructor Destroy; override;

  end;

  // I7zOutArchive property setters

type

  TZipCompressionMethod = (mzCopy, mzDeflate, mzDeflate64, mzBZip2);

  T7zCompressionMethod = (m7Copy, m7LZMA, m7BZip2, m7PPMd, m7Deflate, m7Deflate64);

                                                                                              //  ZIP 7z GZIP BZ2

  procedure SetCompressionLevel(Arch: I7zOutArchive; level: Cardinal);                        //   X   X   X   X

  procedure SetMultiThreading(Arch: I7zOutArchive; ThreadCount: Cardinal);                    //   X   X       X

  procedure SetCompressionMethod(Arch: I7zOutArchive; method: TZipCompressionMethod);         //   X

  procedure SetDictionnarySize(Arch: I7zOutArchive; size: Cardinal); // < 32                  //   X           X

  procedure SetDeflateNumPasses(Arch: I7zOutArchive; pass: Cardinal);                         //   X       X   X

  procedure SetNumFastBytes(Arch: I7zOutArchive; fb: Cardinal);                               //   X       X

  procedure SetNumMatchFinderCycles(Arch: I7zOutArchive; mc: Cardinal);                       //   X       X

  procedure SevenZipSetCompressionMethod(Arch: I7zOutArchive; method: T7zCompressionMethod);  //       X

  procedure SevenZipSetBindInfo(Arch: I7zOutArchive; const bind: UnicodeString);                 //       X

  procedure SevenZipSetSolidSettings(Arch: I7zOutArchive; solid: boolean);                    //       X

  procedure SevenZipRemoveSfxBlock(Arch: I7zOutArchive; remove: boolean);                     //       X

  procedure SevenZipAutoFilter(Arch: I7zOutArchive; auto: boolean);                           //       X

  procedure SevenZipCompressHeaders(Arch: I7zOutArchive; compress: boolean);                  //       X

  procedure SevenZipCompressHeadersFull(Arch: I7zOutArchive; compress: boolean);              //       X

  procedure SevenZipEncryptHeaders(Arch: I7zOutArchive; Encrypt: boolean);                    //       X

  procedure SevenZipVolumeMode(Arch: I7zOutArchive; Mode: boolean);                           //       X

  // filetime util functions

  function DateTimeToFileTime(dt: TDateTime): TFileTime;

  function FileTimeToDateTime(ft: TFileTime): TDateTime;

  function CurrentFileTime: TFileTime;

  // constructors

  function CreateInArchive(const classid: TGUID): I7zInArchive;

  function CreateOutArchive(const classid: TGUID): I7zOutArchive;

const

  CLSID_CFormatZip      : TGUID = '{23170F69-40C1-278A-1000-000110010000}'; // zip jar xpi

  CLSID_CFormatBZ2      : TGUID = '{23170F69-40C1-278A-1000-000110020000}'; // bz2 bzip2 tbz2 tbz

  CLSID_CFormatRar      : TGUID = '{23170F69-40C1-278A-1000-000110030000}'; // rar r00

  CLSID_CFormatArj      : TGUID = '{23170F69-40C1-278A-1000-000110040000}'; // arj

  CLSID_CFormatZ        : TGUID = '{23170F69-40C1-278A-1000-000110050000}'; // z taz

  CLSID_CFormatLzh      : TGUID = '{23170F69-40C1-278A-1000-000110060000}'; // lzh lha

  CLSID_CFormat7z       : TGUID = '{23170F69-40C1-278A-1000-000110070000}'; // 7z

  CLSID_CFormatCab      : TGUID = '{23170F69-40C1-278A-1000-000110080000}'; // cab

  CLSID_CFormatNsis     : TGUID = '{23170F69-40C1-278A-1000-000110090000}';

  CLSID_CFormatLzma     : TGUID = '{23170F69-40C1-278A-1000-0001100A0000}'; // lzma lzma86

  CLSID_CFormatPe       : TGUID = '{23170F69-40C1-278A-1000-000110DD0000}';

  CLSID_CFormatElf      : TGUID = '{23170F69-40C1-278A-1000-000110DE0000}';

  CLSID_CFormatMacho    : TGUID = '{23170F69-40C1-278A-1000-000110DF0000}';

  CLSID_CFormatUdf      : TGUID = '{23170F69-40C1-278A-1000-000110E00000}'; // iso

  CLSID_CFormatXar      : TGUID = '{23170F69-40C1-278A-1000-000110E10000}'; // xar

  CLSID_CFormatMub      : TGUID = '{23170F69-40C1-278A-1000-000110E20000}';

  CLSID_CFormatHfs      : TGUID = '{23170F69-40C1-278A-1000-000110E30000}';

  CLSID_CFormatDmg      : TGUID = '{23170F69-40C1-278A-1000-000110E40000}'; // dmg

  CLSID_CFormatCompound : TGUID = '{23170F69-40C1-278A-1000-000110E50000}'; // msi doc xls ppt

  CLSID_CFormatWim      : TGUID = '{23170F69-40C1-278A-1000-000110E60000}'; // wim swm

  CLSID_CFormatIso      : TGUID = '{23170F69-40C1-278A-1000-000110E70000}'; // iso

  CLSID_CFormatBkf      : TGUID = '{23170F69-40C1-278A-1000-000110E80000}';

  CLSID_CFormatChm      : TGUID = '{23170F69-40C1-278A-1000-000110E90000}'; // chm chi chq chw hxs hxi hxr hxq hxw lit

  CLSID_CFormatSplit    : TGUID = '{23170F69-40C1-278A-1000-000110EA0000}'; //

  CLSID_CFormatRpm      : TGUID = '{23170F69-40C1-278A-1000-000110EB0000}'; // rpm

  CLSID_CFormatDeb      : TGUID = '{23170F69-40C1-278A-1000-000110EC0000}'; // deb

  CLSID_CFormatCpio     : TGUID = '{23170F69-40C1-278A-1000-000110ED0000}'; // cpio

  CLSID_CFormatTar      : TGUID = '{23170F69-40C1-278A-1000-000110EE0000}'; // tar

  CLSID_CFormatGZip     : TGUID = '{23170F69-40C1-278A-1000-000110EF0000}'; // gz gzip tgz tpz

var

  WorkPath: string; {工作路径，查找dll用}

implementation

const

  MAXCHECK : int64 = ( shl );

  ZipCompressionMethod: array[TZipCompressionMethod] of UnicodeString = ('COPY', 'DEFLATE', 'DEFLATE64', 'BZIP2');

  SevCompressionMethod: array[T7zCompressionMethod] of UnicodeString = ('COPY', 'LZMA', 'BZIP2', 'PPMD', 'DEFLATE', 'DEFLATE64');

function DateTimeToFileTime(dt: TDateTime): TFileTime;

var

  st: TSystemTime;

begin

  DateTimeToSystemTime(dt, st);

  if not (SystemTimeToFileTime(st, Result) and LocalFileTimeToFileTime(Result, Result))

    then RaiseLastOSError;

end;

function FileTimeToDateTime(ft: TFileTime): TDateTime;

var

  st: TSystemTime;

begin

  if not (FileTimeToLocalFileTime(ft, ft) and FileTimeToSystemTime(ft, st)) then

    RaiseLastOSError;

  Result := SystemTimeToDateTime(st);

end;

function CurrentFileTime: TFileTime;

begin

  GetSystemTimeAsFileTime(Result);

end;

procedure RINOK(const hr: HRESULT);

begin

  if hr <> S_OK then

    raise Exception.Create(SysErrorMessage(hr));

end;

procedure SetCardinalProperty(arch: I7zOutArchive; const name: UnicodeString; card: Cardinal);

var

  value: OleVariant;

begin

  TPropVariant(value).vt := VT_UI4;

  TPropVariant(value).ulVal := card;

  arch.SetPropertie(name, value);

end;

procedure SetBooleanProperty(arch: I7zOutArchive; const name: UnicodeString; bool: boolean);

begin

  case bool of

    true: arch.SetPropertie(name, 'ON');

    false: arch.SetPropertie(name, 'OFF');

  end;

end;

procedure SetCompressionLevel(Arch: I7zOutArchive; level: Cardinal);

begin

  SetCardinalProperty(arch, 'X', level);

end;

procedure SetMultiThreading(Arch: I7zOutArchive; ThreadCount: Cardinal);

begin

  SetCardinalProperty(arch, 'MT', ThreadCount);

end;

procedure SetCompressionMethod(Arch: I7zOutArchive; method: TZipCompressionMethod);

begin

  Arch.SetPropertie('M', ZipCompressionMethod[method]);

end;

procedure SetDictionnarySize(Arch: I7zOutArchive; size: Cardinal);

begin

  SetCardinalProperty(arch, 'D', size);

end;

procedure SetDeflateNumPasses(Arch: I7zOutArchive; pass: Cardinal);

begin

  SetCardinalProperty(arch, 'PASS', pass);

end;

procedure SetNumFastBytes(Arch: I7zOutArchive; fb: Cardinal);

begin

  SetCardinalProperty(arch, 'FB', fb);

end;

procedure SetNumMatchFinderCycles(Arch: I7zOutArchive; mc: Cardinal);

begin

  SetCardinalProperty(arch, 'MC', mc);

end;

procedure SevenZipSetCompressionMethod(Arch: I7zOutArchive; method: T7zCompressionMethod);

begin

  Arch.SetPropertie('', SevCompressionMethod[method]);

end;

procedure SevenZipSetBindInfo(Arch: I7zOutArchive; const bind: UnicodeString);

begin

  arch.SetPropertie('B', bind);

end;

procedure SevenZipSetSolidSettings(Arch: I7zOutArchive; solid: boolean);

begin

  SetBooleanProperty(Arch, 'S', solid);

end;

procedure SevenZipRemoveSfxBlock(Arch: I7zOutArchive; remove: boolean);

begin

  SetBooleanProperty(arch, 'RSFX', remove);

end;

procedure SevenZipAutoFilter(Arch: I7zOutArchive; auto: boolean);

begin

  SetBooleanProperty(arch, 'F', auto);

end;

procedure SevenZipCompressHeaders(Arch: I7zOutArchive; compress: boolean);

begin

  SetBooleanProperty(arch, 'HC', compress);

end;

procedure SevenZipCompressHeadersFull(Arch: I7zOutArchive; compress: boolean);

begin

  SetBooleanProperty(arch, 'HCF', compress);

end;

procedure SevenZipEncryptHeaders(Arch: I7zOutArchive; Encrypt: boolean);

begin

  SetBooleanProperty(arch, 'HE', Encrypt);

end;

procedure SevenZipVolumeMode(Arch: I7zOutArchive; Mode: boolean);

begin

  SetBooleanProperty(arch, 'V', Mode);

end;

type

  T7zPlugin = class(TInterfacedObject)

  private

    FHandle: THandle;

    FCreateObject: function(const clsid, iid :TGUID; var outObject): HRESULT; stdcall;

  public

    constructor Create(const lib: string); virtual;

    destructor Destroy; override;

    procedure CreateObject(const clsid, iid :TGUID; var obj);

  end;

  T7zCodec = class(T7zPlugin, I7zCodec, ICompressProgressInfo)

  private

    FGetMethodProperty: function(index: Cardinal; propID: NMethodPropID; var value: OleVariant): HRESULT; stdcall;

    FGetNumberOfMethods: function(numMethods: PCardinal): HRESULT; stdcall;

    function GetNumberOfMethods: Cardinal;

    function GetMethodProperty(index: Cardinal; propID: NMethodPropID): OleVariant;

    function GetName(const index: integer): string;

  protected

    function SetRatioInfo(inSize, outSize: PInt64): HRESULT; stdcall;

  public

    function GetDecoder(const index: integer): ICompressCoder;

    function GetEncoder(const index: integer): ICompressCoder;

    constructor Create(const lib: string); override;

    property MethodProperty[index: Cardinal; propID: NMethodPropID]: OleVariant read GetMethodProperty;

    property NumberOfMethods: Cardinal read GetNumberOfMethods;

    property Name[const index: integer]: string read GetName;

  end;

  T7zArchive = class(T7zPlugin)

  private

    FGetHandlerProperty: function(propID: NArchive; var value: OleVariant): HRESULT; stdcall;

    FClassId: TGUID;

    procedure SetClassId(const classid: TGUID);

    function GetClassId: TGUID;

  public

    function GetHandlerProperty(const propID: NArchive): OleVariant;

    function GetLibStringProperty(const Index: NArchive): string;

    function GetLibGUIDProperty(const Index: NArchive): TGUID;

    constructor Create(const lib: string); override;

    property HandlerProperty[const propID: NArchive]: OleVariant read GetHandlerProperty;

    property Name: string index kName read GetLibStringProperty;

    property ClassID: TGUID read GetClassId write SetClassId;

    property Extension: string index kExtension read GetLibStringProperty;

  end;

  T7zInArchive = class(T7zArchive, I7zInArchive, IProgress, IArchiveOpenCallback,

    IArchiveExtractCallback, ICryptoGetTextPassword, IArchiveOpenVolumeCallback,

    IArchiveOpenSetSubArchiveName)

  private

    FInArchive: IInArchive;

    FPasswordCallback: T7zPasswordCallback;

    FPasswordSender: Pointer;

    FProgressCallback: T7zProgressCallback;

    FProgressSender: Pointer;

    FProgressExceptCallback: T7zProgressExceptCallback;

    FProgressExceptSender: Pointer;

    FStream: TStream;

    FPasswordIsDefined: Boolean;

    FPassword: UnicodeString;

    FSubArchiveMode: Boolean;

    FSubArchiveName: UnicodeString;

    FExtractCallBack: T7zGetStreamCallBack;

    FExtractSender: Pointer;

    FExtractPath: string;

    function GetInArchive: IInArchive;

    function GetItemProp(const Item: Cardinal; prop: PROPID): OleVariant;

  protected

    // I7zInArchive

    procedure OpenFile(const filename: string); stdcall;

    procedure OpenStream(stream: IInStream); stdcall;

    procedure Close; stdcall;

    function GetNumberOfItems: Cardinal; stdcall;

    function GetItemPath(const index: integer): UnicodeString; stdcall;

    function GetItemName(const index: integer): UnicodeString; stdcall;

    function GetItemSize(const index: integer): Cardinal; stdcall; stdcall;

    function GetItemIsFolder(const index: integer): boolean; stdcall;

    procedure ExtractItem(const item: Cardinal; Stream: TStream; test: longbool); stdcall;

    procedure ExtractItems(items: PCardArray; count: cardinal; test: longbool; sender: pointer; callback: T7zGetStreamCallBack); stdcall;

    procedure SetPasswordCallback(sender: Pointer; callback: T7zPasswordCallback); stdcall;

    procedure SetProgressCallback(sender: Pointer; callback: T7zProgressCallback); stdcall;

    procedure SetProgressExceptCallback(sender: Pointer; callback: T7zProgressExceptCallback); stdcall;

    procedure ExtractAll(test: longbool; sender: pointer; callback: T7zGetStreamCallBack); stdcall;

    procedure ExtractTo(const path: string); stdcall;

    procedure SetPassword(const password: UnicodeString); stdcall;

    // IArchiveOpenCallback

    function SetTotal(files, bytes: PInt64): HRESULT; overload; stdcall;

    function SetCompleted(files, bytes: PInt64): HRESULT; overload; stdcall;

    // IProgress

    function SetTotal(total: Int64): HRESULT;  overload; stdcall;

    function SetCompleted(completeValue: PInt64): HRESULT; overload; stdcall;

    // IArchiveExtractCallback

    function GetStream(index: Cardinal; var outStream: ISequentialOutStream;

      askExtractMode: NAskMode): HRESULT; overload; stdcall;

    function PrepareOperation(askExtractMode: NAskMode): HRESULT; stdcall;

    function SetOperationResult(resultEOperationResult: NExtOperationResult): HRESULT; overload; stdcall;

    // ICryptoGetTextPassword

    function CryptoGetTextPassword(var password: TBStr): HRESULT; stdcall;

    // IArchiveOpenVolumeCallback

    function GetProperty(propID: PROPID; var value: OleVariant): HRESULT; overload; stdcall;

    function GetStream(const name: PWideChar; var inStream: IInStream): HRESULT; overload; stdcall;

    // IArchiveOpenSetSubArchiveName

    function SetSubArchiveName(name: PWideChar): HRESULT; stdcall;

  public

    constructor Create(const lib: string); override;

    destructor Destroy; override;

    property InArchive: IInArchive read GetInArchive;

  end;

  T7zOutArchive = class(T7zArchive, I7zOutArchive, IArchiveUpdateCallback, ICryptoGetTextPassword2)

  private

    FOutArchive: IOutArchive;

    FBatchList: TObjectList;

    FProgressCallback: T7zProgressCallback;

    FProgressSender: Pointer;

    FPassword: UnicodeString;

    function GetOutArchive: IOutArchive;

  protected

    // I7zOutArchive

    procedure AddStream(Stream: TStream; Ownership: TStreamOwnership;

      Attributes: Cardinal; CreationTime, LastWriteTime: TFileTime;

      const Path: UnicodeString; IsFolder, IsAnti: boolean); stdcall;

    procedure AddFile(const Filename: TFileName; const Path: UnicodeString); stdcall;

    procedure AddFiles(const Dir, Path, Willcards: string; recurse: boolean); stdcall;

    procedure SaveToFile(const FileName: TFileName); stdcall;

    procedure SaveToStream(stream: TStream); stdcall;

    procedure SetProgressCallback(sender: Pointer; callback: T7zProgressCallback); stdcall;

    procedure CrearBatch; stdcall;

    procedure SetPassword(const password: UnicodeString); stdcall;

    procedure SetPropertie(name: UnicodeString; value: OleVariant); stdcall;

    // IProgress

    function SetTotal(total: Int64): HRESULT; stdcall;

    function SetCompleted(completeValue: PInt64): HRESULT; stdcall;

    // IArchiveUpdateCallback

    function GetUpdateItemInfo(index: Cardinal;

        newData: PInteger; // 1 - new data, 0 - old data

        newProperties: PInteger; // 1 - new properties, 0 - old properties

        indexInArchive: PCardinal // -1 if there is no in archive, or if doesn't matter

        ): HRESULT; stdcall;

    function GetProperty(index: Cardinal; propID: PROPID; var value: OleVariant): HRESULT; stdcall;

    function GetStream(index: Cardinal; var inStream: ISequentialInStream): HRESULT; stdcall;

    function SetOperationResult(operationResult: Integer): HRESULT; stdcall;

    // ICryptoGetTextPassword2

    function CryptoGetTextPassword2(passwordIsDefined: PInteger; var password: TBStr): HRESULT; stdcall;

  public

    constructor Create(const lib: string); override;

    destructor Destroy; override;

    property OutArchive: IOutArchive read GetOutArchive;

  end;

function CreateInArchive(const classid: TGUID): I7zInArchive;

begin

  Result := T7zInArchive.Create(WorkPath + '7z.dll');

  Result.ClassId := classid;

end;

function CreateOutArchive(const classid: TGUID): I7zOutArchive;

begin

  Result := T7zOutArchive.Create(WorkPath + '7z.dll');

  Result.ClassId := classid;

end;

{ T7zPlugin }

constructor T7zPlugin.Create(const lib: string);

begin

  FHandle := LoadLibrary(PChar(lib));

  if FHandle =  then

    raise exception.CreateFmt('Error loading library %s', [lib]);

  FCreateObject := GetProcAddress(FHandle, 'CreateObject');

  if not (Assigned(FCreateObject)) then

  begin

    FreeLibrary(FHandle);

    raise Exception.CreateFmt('%s is not a 7z library', [lib]);

  end;

end;

destructor T7zPlugin.Destroy;

begin

  FreeLibrary(FHandle);

  inherited;

end;

procedure T7zPlugin.CreateObject(const clsid, iid: TGUID; var obj);

var

  hr: HRESULT;

begin

  hr := FCreateObject(clsid, iid, obj);

  if failed(hr) then

    raise Exception.Create(SysErrorMessage(hr));

end;

{ T7zCodec }

constructor T7zCodec.Create(const lib: string);

begin

  inherited;

  FGetMethodProperty := GetProcAddress(FHandle, 'GetMethodProperty');

  FGetNumberOfMethods := GetProcAddress(FHandle, 'GetNumberOfMethods');

  if not (Assigned(FGetMethodProperty) and Assigned(FGetNumberOfMethods)) then

  begin

    FreeLibrary(FHandle);

    raise Exception.CreateFmt('%s is not a codec library', [lib]);

  end;

end;

function T7zCodec.GetDecoder(const index: integer): ICompressCoder;

var

  v: OleVariant;

begin

  v := MethodProperty[index, kDecoder];

  CreateObject(TPropVariant(v).puuid^, ICompressCoder, Result);

end;

function T7zCodec.GetEncoder(const index: integer): ICompressCoder;

var

  v: OleVariant;

begin

  v := MethodProperty[index, kEncoder];

  CreateObject(TPropVariant(v).puuid^, ICompressCoder, Result);

end;

function T7zCodec.GetMethodProperty(index: Cardinal;

  propID: NMethodPropID): OleVariant;

var

  hr: HRESULT;

begin

  hr := FGetMethodProperty(index, propID, Result);

  if Failed(hr) then

    raise Exception.Create(SysErrorMessage(hr));

end;

function T7zCodec.GetName(const index: integer): string;

begin

  Result := MethodProperty[index, kName_];

end;

function T7zCodec.GetNumberOfMethods: Cardinal;

var

  hr: HRESULT;

begin

  hr := FGetNumberOfMethods(@Result);

  if Failed(hr) then

    raise Exception.Create(SysErrorMessage(hr));

end;

function T7zCodec.SetRatioInfo(inSize, outSize: PInt64): HRESULT;

begin

  Result := S_OK;

end;

{ T7zInArchive }

procedure T7zInArchive.Close; stdcall;

begin

  FPasswordIsDefined := false;

  FSubArchiveMode := false;

  FInArchive.Close;

  FInArchive := nil;

end;

constructor T7zInArchive.Create(const lib: string);

begin

  inherited;

  FPasswordCallback := nil;

  FPasswordSender := nil;

  FPasswordIsDefined := false;

  FSubArchiveMode := false;

  FExtractCallBack := nil;

  FExtractSender := nil;

end;

destructor T7zInArchive.Destroy;

begin

  FInArchive := nil;

  inherited;

end;

function T7zInArchive.GetInArchive: IInArchive;

begin

  if FInArchive = nil then

    CreateObject(ClassID, IInArchive, FInArchive);

  Result := FInArchive;

end;

function T7zInArchive.GetItemPath(const index: integer): UnicodeString; stdcall;

begin

  Result := UnicodeString(GetItemProp(index, kpidPath));

end;

function T7zInArchive.GetNumberOfItems: Cardinal; stdcall;

begin

  RINOK(FInArchive.GetNumberOfItems(Result));

end;

procedure T7zInArchive.OpenFile(const filename: string); stdcall;

var

  strm: IInStream;

begin

  strm := T7zStream.Create(TFileStream.Create(filename, fmOpenRead or fmShareDenyNone), soOwned);

  try

    RINOK(

      InArchive.Open(

        strm,

          @MAXCHECK, self as IArchiveOpenCallBack

        )

      );

  finally

    strm := nil;

  end;

end;

procedure T7zInArchive.OpenStream(stream: IInStream); stdcall;

begin

  RINOK(InArchive.Open(stream, @MAXCHECK, self as IArchiveOpenCallBack));

end;

function T7zInArchive.GetItemIsFolder(const index: integer): boolean; stdcall;

begin

  Result := Boolean(GetItemProp(index, kpidIsFolder));

end;

function T7zInArchive.GetItemProp(const Item: Cardinal;

  prop: PROPID): OleVariant;

begin

  FInArchive.GetProperty(Item, prop, Result);

end;

procedure T7zInArchive.ExtractItem(const item: Cardinal; Stream: TStream; test: longbool); stdcall;

begin

  FStream := Stream;

  try

    if test then

      RINOK(FInArchive.Extract(@item, , , self as IArchiveExtractCallback)) else

      RINOK(FInArchive.Extract(@item, , , self as IArchiveExtractCallback));

  finally

    FStream := nil;

  end;

end;

function T7zInArchive.GetStream(index: Cardinal;

  var outStream: ISequentialOutStream; askExtractMode: NAskMode): HRESULT;

var

  nPath: string;

  nDefFileAttr: Cardinal;

  nFileStream: TFileStream;

  nECR: NECallBack;

begin

  Result := S_FALSE;

  if askExtractMode = kExtract then

  begin

    if FStream <> nil then

      outStream := T7zStream.Create(FStream, soReference) as ISequentialOutStream

    else if assigned(FExtractCallback) then

    begin

      Result := FExtractCallBack(FExtractSender, index, outStream);

      Exit;

    end

    else if FExtractPath <> '' then

    begin

      if GetItemIsFolder(index) then

      begin

        nPath := FExtractPath + GetItemPath(index);

        ForceDirectories(nPath);

      end

      else

      begin

        nPath := FExtractPath + GetItemPath(index);

        ForceDirectories(ExtractFilePath(nPath));

        nDefFileAttr := ;

        if FileExists(nPath) then

        begin

          nDefFileAttr := GetFileAttributes(PChar(nPath));

          if nDefFileAttr <> FILE_ATTRIBUTE_NORMAL then

            SetFileAttributes(PChar(nPath), FILE_ATTRIBUTE_NORMAL);

        end;

        repeat

          try

            nFileStream := TFileStream.Create(nPath, fmCreate);

          except

            FreeAndNil(nFileStream);

            if not Assigned(FProgressExceptCallback) then

              nECR := EC_CANCEL

            else

              nECR := FProgressExceptCallback(FProgressExceptSender, nPath);

          end;

        until (nFileStream <> nil) or (nECR <> EC_RETRY);

        if nFileStream = nil then

        begin

          if nECR = EC_CANCEL then

            Exit;

        end

        else

        begin

          outStream := T7zStream.Create(nFileStream, soOwned);

          if (nDefFileAttr <> ) and (nDefFileAttr <> FILE_ATTRIBUTE_NORMAL) then

            SetFileAttributes(PChar(nPath), nDefFileAttr);

        end;

      end;

    end;

  end;

  Result := S_OK;

end;

function T7zInArchive.PrepareOperation(askExtractMode: NAskMode): HRESULT;

begin

  Result := S_OK;

end;

function T7zInArchive.SetCompleted(completeValue: PInt64): HRESULT;

begin

  if Assigned(FProgressCallback) and (completeValue <> nil) then

    Result := FProgressCallback(FProgressSender, false, completeValue^) else

    Result := S_OK;

end;

function T7zInArchive.SetCompleted(files, bytes: PInt64): HRESULT;

begin

  Result := S_OK;

end;

function T7zInArchive.SetOperationResult(

  resultEOperationResult: NExtOperationResult): HRESULT;

begin

  Result := S_OK;

end;

function T7zInArchive.SetTotal(total: Int64): HRESULT;

begin

  if Assigned(FProgressCallback) then

    Result := FProgressCallback(FProgressSender, true, total) else

    Result := S_OK;

end;

function T7zInArchive.SetTotal(files, bytes: PInt64): HRESULT;

begin

  Result := S_OK;

end;

function T7zInArchive.CryptoGetTextPassword(var password: TBStr): HRESULT;

var

  wpass: UnicodeString;

begin

  if FPasswordIsDefined then

  begin

    password := SysAllocString(PWideChar(FPassword));

    Result := S_OK;

  end else

  if Assigned(FPasswordCallback) then

  begin

    Result := FPasswordCallBack(FPasswordSender, wpass);

    if Result = S_OK then

    begin

      password := SysAllocString(PWideChar(wpass));

      FPasswordIsDefined := True;

      FPassword := wpass;

    end;

  end else

    Result := S_FALSE;

end;

function T7zInArchive.GetProperty(propID: PROPID;

  var value: OleVariant): HRESULT;

begin

  Result := S_OK;

end;

function T7zInArchive.GetStream(const name: PWideChar;

  var inStream: IInStream): HRESULT;

begin

  Result := S_OK;

end;

procedure T7zInArchive.SetPasswordCallback(sender: Pointer;

  callback: T7zPasswordCallback); stdcall;

begin

  FPasswordSender := sender;

  FPasswordCallback := callback;

end;

function T7zInArchive.SetSubArchiveName(name: PWideChar): HRESULT;

begin

  FSubArchiveMode := true;

  FSubArchiveName := name;

  Result := S_OK;

end;

function T7zInArchive.GetItemName(const index: integer): UnicodeString; stdcall;

begin

  Result := UnicodeString(GetItemProp(index, kpidName));

end;

function T7zInArchive.GetItemSize(const index: integer): Cardinal; stdcall;

begin

  Result := Cardinal(GetItemProp(index, kpidSize));

end;

procedure T7zInArchive.ExtractItems(items: PCardArray; count: cardinal; test: longbool;

  sender: pointer; callback: T7zGetStreamCallBack); stdcall;

begin

  FExtractCallBack := callback;

  FExtractSender := sender;

  try

    if test then

      RINOK(FInArchive.Extract(items, count, , self as IArchiveExtractCallback)) else

      RINOK(FInArchive.Extract(items, count, , self as IArchiveExtractCallback));

  finally

    FExtractCallBack := nil;

    FExtractSender := nil;

  end;

end;

procedure T7zInArchive.SetProgressCallback(sender: Pointer;

  callback: T7zProgressCallback); stdcall;

begin

  FProgressSender := sender;

  FProgressCallback := callback;

end;

procedure T7zInArchive.SetProgressExceptCallback(sender: Pointer;

  callback: T7zProgressExceptCallback);

begin

  FProgressExceptSender := sender;

  FProgressExceptCallback := callback;

end;

procedure T7zInArchive.ExtractAll(test: longbool; sender: pointer;

  callback: T7zGetStreamCallBack);

begin

  FExtractCallBack := callback;

  FExtractSender := sender;

  try

    if test then

      RINOK(FInArchive.Extract(nil, $FFFFFFFF, , self as IArchiveExtractCallback)) else

      RINOK(FInArchive.Extract(nil, $FFFFFFFF, , self as IArchiveExtractCallback));

  finally

    FExtractCallBack := nil;

    FExtractSender := nil;

  end;

end;

procedure T7zInArchive.ExtractTo(const path: string);

begin

  FExtractPath := IncludeTrailingPathDelimiter(path);

  try

    RINOK(FInArchive.Extract(nil, $FFFFFFFF, , self as IArchiveExtractCallback));

  finally

    FExtractPath := '';

  end;

end;

procedure T7zInArchive.SetPassword(const password: UnicodeString);

begin

  FPassword := password;

  FPasswordIsDefined :=  FPassword <> '';

end;

{ T7zArchive }

constructor T7zArchive.Create(const lib: string);

begin

  inherited;

  FGetHandlerProperty := GetProcAddress(FHandle, 'GetHandlerProperty');

  if not Assigned(FGetHandlerProperty) then

  begin

    FreeLibrary(FHandle);

    raise Exception.CreateFmt('%s is not a Format library', [lib]);

  end;

  FClassId := GUID_NULL;

end;

function T7zArchive.GetClassId: TGUID;

begin

  Result := FClassId;

end;

function T7zArchive.GetHandlerProperty(const propID: NArchive): OleVariant;

var

  hr: HRESULT;

begin

  hr := FGetHandlerProperty(propID, Result);

  if Failed(hr) then

    raise Exception.Create(SysErrorMessage(hr));

end;

function T7zArchive.GetLibGUIDProperty(const Index: NArchive): TGUID;

var

  v: OleVariant;

begin

  v := HandlerProperty[index];

  Result := TPropVariant(v).puuid^;

end;

function T7zArchive.GetLibStringProperty(const Index: NArchive): string;

begin

  Result := HandlerProperty[Index];

end;

procedure T7zArchive.SetClassId(const classid: TGUID);

begin

  FClassId := classid;

end;

{ T7zStream }

constructor T7zStream.Create(Stream: TStream; Ownership: TStreamOwnership);

begin

  inherited Create;

  FStream := Stream;

  FOwnership := Ownership;

end;

destructor T7zStream.destroy;

begin

  if FOwnership = soOwned then

  begin

    FStream.Free;

    FStream := nil;

  end;

  inherited;

end;

function T7zStream.Flush: HRESULT;

begin

  Result := S_OK;

end;

function T7zStream.GetSize(size: PInt64): HRESULT;

begin

  if size <> nil then

    size^ := FStream.Size;

  Result := S_OK;

end;

function T7zStream.Read(data: Pointer; size: Cardinal;

  processedSize: PCardinal): HRESULT;

var

  len: integer;

begin

  len := FStream.Read(data^, size);

  if processedSize <> nil then

    processedSize^ := len;

  Result := S_OK;

end;

function T7zStream.Seek(offset: Int64; seekOrigin: Cardinal;

  newPosition: PInt64): HRESULT;

begin

  FStream.Seek(offset, TSeekOrigin(seekOrigin));

  if newPosition <> nil then

    newPosition^ := FStream.Position;

  Result := S_OK;

end;

function T7zStream.SetSize(newSize: Int64): HRESULT;

begin

  FStream.Size := newSize;

  Result := S_OK;

end;

function T7zStream.Write(data: Pointer; size: Cardinal;

  processedSize: PCardinal): HRESULT;

var

  len: integer;

begin

  len := FStream.Write(data^, size);

  if processedSize <> nil then

    processedSize^ := len;

  Result := S_OK;

end;

type

  TSourceMode = (smStream, smFile);

  T7zBatchItem = class

    SourceMode: TSourceMode;

    Stream: TStream;

    Attributes: Cardinal;

    CreationTime, LastWriteTime: TFileTime;

    Path: UnicodeString;

    IsFolder, IsAnti: boolean;

    FileName: TFileName;

    Ownership: TStreamOwnership;

    Size: Cardinal;

    destructor Destroy; override;

  end;

destructor T7zBatchItem.Destroy;

begin

  if (Ownership = soOwned) and (Stream <> nil) then

    Stream.Free;

  inherited;

end;

{ T7zOutArchive }

procedure T7zOutArchive.AddFile(const Filename: TFileName; const Path: UnicodeString);

var

  item: T7zBatchItem;

  Handle: THandle;

begin

  if not FileExists(Filename) then exit;

  item := T7zBatchItem.Create;

  Item.SourceMode := smFile;

  item.Stream := nil;

  item.FileName := Filename;

  item.Path := Path;

  Handle := FileOpen(Filename, fmOpenRead or fmShareDenyNone);

  GetFileTime(Handle, @item.CreationTime, nil, @item.LastWriteTime);

  item.Size := GetFileSize(Handle, nil);

  CloseHandle(Handle);

  item.Attributes := GetFileAttributes(PChar(Filename));

  item.IsFolder := false;

  item.IsAnti := False;

  item.Ownership := soOwned;

  FBatchList.Add(item);

end;

procedure T7zOutArchive.AddFiles(const Dir, Path, Willcards: string; recurse: boolean);

var

  lencut: integer;

  willlist: TStringList;

  zedir: string;

  procedure Traverse(p: string);

  var

    f: TSearchRec;

    i: integer;

    item: T7zBatchItem;

  begin

    if recurse then

    begin

      if FindFirst(p + '*.*', faDirectory, f) =  then

      repeat

        if (f.Name[] <> '.') then

          Traverse(IncludeTrailingPathDelimiter(p + f.Name));

      until FindNext(f) <> ;

      SysUtils.FindClose(f);

    end;

    for i :=  to willlist.Count -  do

    begin

      if FindFirst(p + willlist[i], faReadOnly or faHidden or faSysFile or faArchive, f) =  then

      repeat

        item := T7zBatchItem.Create;

        Item.SourceMode := smFile;

        item.Stream := nil;

        item.FileName := p + f.Name;

        item.Path := copy(item.FileName, lencut, length(item.FileName) - lencut + );

        if path <> '' then

          item.Path := IncludeTrailingPathDelimiter(path) + item.Path;

        item.CreationTime := f.FindData.ftCreationTime;

        item.LastWriteTime := f.FindData.ftLastWriteTime;

        item.Attributes := f.FindData.dwFileAttributes;

        item.Size := f.Size;

        item.IsFolder := false;

        item.IsAnti := False;

        item.Ownership := soOwned;

        FBatchList.Add(item);

      until FindNext(f) <> ;

      SysUtils.FindClose(f);

    end;

  end;

  procedure _Delimiter;

  var

    i, s, x, l: Integer;

    nStr: string;

  begin

    s := ;

    l := Length(Willcards);

    for i :=  to l do

    begin

      if Willcards[i] = ';' then

      begin

        willlist.Add(Copy(Willcards, s, i - s));

        s := i + ;

      end;

    end;

    if s < l then

      willlist.Add(Copy(Willcards, s, l - s + ));

  end;

begin

  willlist := TStringList.Create;

  try

    _Delimiter;

    zedir := IncludeTrailingPathDelimiter(Dir);

    lencut := Length(zedir) + ;

    Traverse(zedir);

  finally

    willlist.Free;

  end;

end;

procedure T7zOutArchive.AddStream(Stream: TStream; Ownership: TStreamOwnership;

  Attributes: Cardinal; CreationTime, LastWriteTime: TFileTime;

  const Path: UnicodeString; IsFolder, IsAnti: boolean); stdcall;

var

  item: T7zBatchItem;

begin

  item := T7zBatchItem.Create;

  Item.SourceMode := smStream;

  item.Attributes := Attributes;

  item.CreationTime := CreationTime;

  item.LastWriteTime := LastWriteTime;

  item.Path := Path;

  item.IsFolder := IsFolder;

  item.IsAnti := IsAnti;

  item.Stream := Stream;

  item.Size := Stream.Size;

  item.Ownership := Ownership;

  FBatchList.Add(item);

end;

procedure T7zOutArchive.CrearBatch;

begin

  FBatchList.Clear;

end;

constructor T7zOutArchive.Create(const lib: string);

begin

  inherited;

  FBatchList := TObjectList.Create;

  FProgressCallback := nil;

  FProgressSender := nil;

end;

function T7zOutArchive.CryptoGetTextPassword2(passwordIsDefined: PInteger;

  var password: TBStr): HRESULT;

begin

  if FPassword <> '' then

  begin

   passwordIsDefined^ := ;

   password := SysAllocString(PWideChar(FPassword));

  end else

    passwordIsDefined^ := ;

  Result := S_OK;

end;

destructor T7zOutArchive.Destroy;

begin

  FOutArchive := nil;

  FBatchList.Free;

  inherited;

end;

function T7zOutArchive.GetOutArchive: IOutArchive;

begin

  if FOutArchive = nil then

    CreateObject(ClassID, IOutArchive, FOutArchive);

  Result := FOutArchive;

end;

function T7zOutArchive.GetProperty(index: Cardinal; propID: PROPID;

  var value: OleVariant): HRESULT;

var

  item: T7zBatchItem;

begin

  item := T7zBatchItem(FBatchList[index]);

  case propID of

    kpidAttributes:

      begin

        TPropVariant(Value).vt := VT_UI4;

        TPropVariant(Value).ulVal := item.Attributes;

      end;

    kpidLastWriteTime:

      begin

        TPropVariant(value).vt := VT_FILETIME;

        TPropVariant(value).filetime := item.LastWriteTime;

      end;

    kpidPath:

      begin

        if item.Path <> '' then

          value := item.Path;

      end;

    kpidIsFolder: Value := item.IsFolder;

    kpidSize:

      begin

        TPropVariant(Value).vt := VT_UI8;

        TPropVariant(Value).uhVal.QuadPart := item.Size;

      end;

    kpidCreationTime:

      begin

        TPropVariant(value).vt := VT_FILETIME;

        TPropVariant(value).filetime := item.CreationTime;

      end;

    kpidIsAnti: value := item.IsAnti;

  else

   // beep(0,0);

  end;

  Result := S_OK;

end;

function T7zOutArchive.GetStream(index: Cardinal;

  var inStream: ISequentialInStream): HRESULT;

var

  item: T7zBatchItem;

begin

  item := T7zBatchItem(FBatchList[index]);

  case item.SourceMode of

    smFile: inStream := T7zStream.Create(TFileStream.Create(item.FileName, fmOpenRead or fmShareDenyNone), soOwned);

    smStream:

      begin

        item.Stream.Seek(, soFromBeginning);

        inStream := T7zStream.Create(item.Stream);

      end;

  end;

  Result := S_OK;

end;

function T7zOutArchive.GetUpdateItemInfo(index: Cardinal; newData,

  newProperties: PInteger; indexInArchive: PCardinal): HRESULT;

begin

  newData^ := ;

  newProperties^ := ;

  indexInArchive^ := CArdinal(-);

  Result := S_OK;

end;

procedure T7zOutArchive.SaveToFile(const FileName: TFileName);

var

  f: TFileStream;

begin

  f := TFileStream.Create(FileName, fmCreate);

  try

    SaveToStream(f);

  finally

    f.free;

  end;

end;

procedure T7zOutArchive.SaveToStream(stream: TStream);

var

  strm: ISequentialOutStream;

begin

  strm := T7zStream.Create(stream);

  try

    RINOK(OutArchive.UpdateItems(strm, FBatchList.Count, self as IArchiveUpdateCallback));

  finally

    strm := nil;

  end;

end;

function T7zOutArchive.SetCompleted(completeValue: PInt64): HRESULT;

begin

  if Assigned(FProgressCallback) and (completeValue <> nil) then

    Result := FProgressCallback(FProgressSender, false, completeValue^) else

    Result := S_OK;

end;

function T7zOutArchive.SetOperationResult(

  operationResult: Integer): HRESULT;

begin

  Result := S_OK;

end;

procedure T7zOutArchive.SetPassword(const password: UnicodeString);

begin

  FPassword := password;

end;

procedure T7zOutArchive.SetProgressCallback(sender: Pointer;

  callback: T7zProgressCallback);

begin

  FProgressCallback := callback;

  FProgressSender := sender;

end;

procedure T7zOutArchive.SetPropertie(name: UnicodeString;

  value: OleVariant);

var

  intf: ISetProperties;

  p: PWideChar;

begin

  intf := OutArchive as ISetProperties;

  p := PWideChar(name);

  RINOK(intf.SetProperties(@p, @TPropVariant(value), ));

end;

function T7zOutArchive.SetTotal(total: Int64): HRESULT;

begin

  if Assigned(FProgressCallback) then

    Result := FProgressCallback(FProgressSender, true, total) else

    Result := S_OK;

end;

initialization

  WorkPath := '';

end.
SevenZip.pas BUG修改版 - 20160613的更多相关文章

sqm(sqlmapGUI) pcat修改版
sqlmap是一款开源的注入工具,支持几乎所有的数据库,支持get/post/cookie注入,支持错误回显注入/盲注,还有其他多种注入方法. 支持代理,指纹识别技术判断数据库 .而sqm(sqlma ...
Indy 10.5.8 for Delphi and Lazarus 修改版(2011)
Indy 10.5.8 for Delphi and Lazarus 修改版(2011) Internet Direct(Indy)是一组开放源代码的Internet组件,涵盖了几乎所有流行的I ...
Perl实用中文处理步骤（修改版）
发信人: FenRagwort (泽), 信区: Perl标题: Perl实用中文处理步骤(修改版)发信站: 水木社区 (Mon Feb 14 12:52:14 2011), 转信 (修改版感谢 ...
【LINT】cpplint修改版：自定义编码风格检查工具lint
github:https://github.com/skullboyer/code-check Code Check 本仓介绍的内容涉及代码静态检查和编码风格检查但主要放在编码风格检查,lint是基 ...
Medoo个人修改版
Medoo是一款轻量级的php数据库操作类,下面不会介绍Medoo的使用方法,想学习Medoo请前往官网自学:http://medoo.in/ 在接触Medoo之前,一直是用自己写的php数据库操作类 ...
Android 仿美团网,大众点评购买框悬浮效果之修改版
转帖请注明本文出自xiaanming的博客(http://blog.csdn.net/xiaanming/article/details/17761431),请尊重他人的辛勤劳动成果,谢谢! 我之前写 ...
黄聪：WordPress图片插件：Auto Highslide修改版（转）
一直以来很多人都很喜欢我博客使用的图片插件,因为我用的跟原版是有些不同的,效果比原版的要好,他有白色遮罩层,可以直观的知道上下翻图片和幻灯片放映模式.很多人使用原版之后发现我用的更加帅一些,于是很多人 ...
转载：Eclipse+Spket插件+ExtJs4修改版提供代码提示功能[图]
转载:Eclipse+Spket插件+ExtJs4修改版提供代码提示功能[图] ExtJs是一种主要用于创建前端用户界面,是一个基本与后台技术无关的前端ajax框架.功能丰富,无人能出其右.无论是界面 ...
若快打码平台python开发文档修改版
一.打码的作用在进行爬虫过程中,部分网站的登录验证码是比较简单的,例如四个英文数字随机组合而成的验证码,有的是全数字随机组成的验证码,有的是全中文随机组成的验证码.为了爬虫进行自动化,需要解决自动登 ...
随机推荐

HDU5772 String problem（最大权闭合子图）
题目..说了很多东西官方题解是这么说的: 首先将点分为3类第一类:Pij 表示第i个点和第j个点组合的点,那么Pij的权值等于w[i][j]+w[j][i](表示得分) 第二类:原串中的n个点每个 ...
Code Rush插件
code rush 是微软推出的一款VS2008上的插件.他有强大的文件和代码导航功能,易于访问的重构和代码创建功能.一组编辑器.选择.剪贴板工具等. 教程链接 http://www.devexpre ...
thrift 学习
入门教程: http://blog.zhengdong.me/2012/05/10/hello-world-by-thrift-using-java
python 代码片段17
#coding=utf-8 try: get_mutex() do_some_stuff() except (IndexError,KeyError,AttributeError),e: log(&q ...
挂载磁盘linux
1. 用mkfs命令在/dev/sdb上创建ext4文件系统 1.1 mkfs命令在设备上创建文件系统 mkfs [options] device 参数 device 为要在其上面创建文件系统的设备 ...
sdoi 2009 & 状态压缩
是不是平时在手机里玩吃豆豆游戏玩腻了呢?最近MOKIA手机上推出了一种新的围豆豆游戏,大家一起来试一试吧. 游戏的规则非常简单,在一个N×M的矩阵方格内分布着D颗豆子,每颗豆有不同的分值Vi.游戏者可 ...
JS正则获取参数值
var geturl = function(url){ var ret = {}; var queryStr=url.replace(/^[^\?#]*\??/g,'').replace(/#DIAL ...
ubuntu 安装 OpenCv 及其Qt的开发环境配置
ubuntu安装opencv (1)安装编译opencv的环境 sudo apt-get -y install build-essential cmake pkg-config (2)安装Image ...
ACM 疯牛
疯牛时间限制:1000 ms | 内存限制:65535 KB 难度:4 描述农夫 John 建造了一座很长的畜栏,它包括N (2 <= N <= 100,000)个隔间,这些小 ...
洛谷 P2661 信息传递 Label:并查集||强联通分量
题目描述有n个同学(编号为1到n)正在玩一个信息传递的游戏.在游戏里每人都有一个固定的信息传递对象,其中,编号为i的同学的信息传递对象是编号为Ti同学. 游戏开始时,每人都只知道自己的生日.之后每一 ...
SevenZip.pas BUG修改版 - 20160613

SevenZip.pas BUG修改版 - 20160613的更多相关文章

随机推荐

热门专题
