按如下方式使用：
var
stgFile:TStgFile;
stream:TStgStream;
storage:TStorage;
begin
try
stgFile := TStgFile.CreateFile( ... );
storage := stgFile.CreateStorage( ... );
...
stream := storage.CreateStream( ... );
...
except
...
end;
end;
************************************************************
STG File存取
// (c) Alex Konshin mailto:alexk@msmt.spb.su 02.12.97
{ HISTROY:
2002-1-8 down from www.torry.net
2002-1-9 Fix some error;
Add commit function to TStorage.
}
{
$Date: 2002/01/10 00:53:37 $
$Author: zhangjun $
$Revision: 1.1 $
}
unit Storages;
interface
uses
SysUtils, Windows, Classes, Forms, ActiveX;
const
stgmOpenReadWrite = {STGM_TRANSACTED or} STGM_READWRITE or STGM_SHARE_DENY_WRITE;
stgmOpenRead = {STGM_TRANSACTED or} STGM_READ or STGM_SHARE_EXCLUSIVE;
stgmCreate = { STGM_TRANSACTED or} STGM_CREATE or STGM_READWRITE or STGM_SHARE_EXCLUSIVE;
stgmConvert = {STGM_TRANSACTED or} STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CONVERT;
type
TStorage = class;
TStgStream = class(TStream)
protected
FStream : IStream;
FStorage : TStorage;
FName, FPath : String;
procedure SetSize( NewSize : Longint ); override;
procedure SetName( Value : String); virtual;
constructor Create( const AName : String; AStorage : TStorage; AStream : IStream );
public
function Read( var Buffer; Count : Longint ) : Longint; override;
function Write( const Buffer; Count : Longint ) : Longint; override;
function Seek( Offset : Longint; Origin : Word ) : Longint; override;
destructor Destroy; override;
published
property Name : String read FName write SetName;
end; { TStgStream }
TStorage = class
protected
FStorage : IStorage;
FName, FPath : String;
FParent : TStorage;
FLockCount : LongInt;
procedure SetName( Value : String); virtual;
constructor Create( const AName : String; AParent : TStorage; AStorage : IStorage );
public
destructor Destroy; override; // 眢骓?桉镱朦珙忄螯 Close !
procedure Close;
function CreateStream( const AName : String; const Mode : DWord ) : TStgStream;
function OpenStream( const AName : String; const Mode : DWord ) : TStgStream;
function OpenCreateStream( const AName : String; const Mode : DWord ) : TStgStream;
function CreateStorage( const AName : String; const Mode : DWord ) : TStorage;
function OpenStorage( const AName : String; const Mode : DWord ) : TStorage;
function OpenCreateStorage( const AName : String; const Mode : DWord; var bCreate : Boolean ) : TStorage;
procedure RenameElement( const AOldName, ANewName : String );
// STGTY_STORAGE = 1,
// STGTY_STREAM = 2,
// STGTY_LOCKBYTES = 3,
// STGTY_PROPERTY = 4
procedure EnumElements( AStrings : TStringList ; dwTypeNeed:DWORD);
procedure Commit(cFlag:DWORD);
published
property Storage : IStorage read FStorage;
property Name : String read FName write SetName;
property Path : String read FPath;
end; { TStorage }
TStgFile = class(TStorage)
protected
FFileName : String;
constructor Create( const AFileName : String; AStorage : IStorage );
public
class function CreateFile( const AFileName : String; const Mode : DWord ) : TStgFile;
class function OpenFile( const AFileName : String; const Mode : DWord ) : TStgFile;
// function Clone( const Mode : DWord ) : TStgFile;
end; { TStgFile }
{function ModeToStgMode( const Mode : Word ) : DWORD;
// fmCreate Create a file with the given name. If a file with the given name exists, open the file in write mode.
// fmOpenRead Open the file for reading only.
// fmOpenWrite Open the file for writing only. Writing to the file completely replaces the current contents.
// fmOpenReadWrite Open the file to modify the current contents rather than replace them.
//
// fmShareCompat Sharing is compatible with the way FCBs are opened.
// fmShareExclusive Other applications can not open the file for any reason.
// fmShareDenyWrite Other applications can open the file for reading but not for writing.
// fmShareDenyRead Other applications can open the file for writing but not for reading.
// fmShareDenyNone No attempt is made to prevent other applications from reading from or writing to the file.
function OpenStream( const APath : String; const Mode : Word ) : TStream; // Open plain file or IStream as TStream
function OpenStorage( const APath : String; const Mode : Word ) : TStorage;
}
//=============================================================
implementation
uses ComObj;
//=============================================================
// fmCreate = $ffff;
// fmOpenRead = $0000;
// fmOpenWrite = $0001;
// fmOpenReadWrite = $0002;
// fmShareCompat = $0000;
// fmShareExclusive = $0010;
// fmShareDenyWrite = $0020;
// fmShareDenyRead = $0030;
// fmShareDenyNone = $0040;
function ModeToStgMode( const Mode : Word ) : DWORD;
const
RWModes : Array [0..3] of DWord = (STGM_READ,STGM_WRITE,STGM_READWRITE,0);
ShareModes : Array [0..7] of DWord =
( STGM_SHARE_EXCLUSIVE,STGM_SHARE_EXCLUSIVE,STGM_SHARE_DENY_WRITE,STGM_SHARE_DENY_READ,
STGM_SHARE_DENY_NONE,STGM_SHARE_EXCLUSIVE,STGM_SHARE_EXCLUSIVE,STGM_SHARE_EXCLUSIVE);
begin
if Mode=fmCreate then Result := stgmCreate
else Result := RWModes[Mode and 3] or ShareModes[Mode shr 4];
end;
//-------------------------------------------------------------
{function GetName( var ptr : PChar; var len : Integer ) : String;
const Delimitors : String = '/\'#0;
var i : Integer;
begin
Result := '';
i := QScanChars( ptr, len, Delimitors );
if i>0 then
begin
Dec(i);
if i=0 then Exit;
Result := Copy(ptr,1,i);
Inc(ptr,i);
Dec(len,i)
end
else
begin
Result := Copy(ptr,1,len);
ptr := nil;
len := 0;
end;
end;}
//==TStgStream===========================================================
constructor TStgStream.Create( const AName : String; AStorage : TStorage; AStream : IStream );
begin
inherited Create;
FStream := AStream;
FStorage := AStorage;
if AStorage<>nil then
begin
FPath := AStorage.FPath+AStorage.FName+'\';
Inc(AStorage.FLockCount);
end;
FName := AName;
end; {TStgStream.Create}
//-------------------------------------------------------------
destructor TStgStream.Destroy;
begin
{ if FStream<>nil then
begin
FStream._Release;
FStream := nil;
end;}
if FStorage<>nil then FStorage.Close;
inherited Destroy;
end; {TStgStream.Destroy}
//-------------------------------------------------------------
function TStgStream.Read( var Buffer; Count : Longint ) : Longint;
begin
Result := 0;
if FStream<>nil then OleCheck( FStream.Read( @Buffer, Count, @Result ) );
end; {TStgStream.Read}
//-------------------------------------------------------------
function TStgStream.Write( const Buffer; Count : Longint ) : Longint;
begin
Result := 0;
if FStream<>nil then OleCheck( FStream.Write( @Buffer, Count, @Result ) );
end; {TStgStream.Write}
//-------------------------------------------------------------
function TStgStream.Seek( Offset : Longint; Origin : Word ) : Longint;
var NewPos : LargeInt;
begin
Result := 0;
if FStream=nil then Exit;
OleCheck( FStream.Seek( Offset, Origin, NewPos ) );
Result := LongInt(NewPos);
end; {TStgStream.Seek}
//-------------------------------------------------------------
procedure TStgStream.SetSize( NewSize : Longint );
begin
if FStream=nil then Exit;
OleCheck( FStream.SetSize(NewSize) );
end; {TStgStream.SetSize}
//-------------------------------------------------------------
procedure TStgStream.SetName( Value : String );
begin
if FName=Value then Exit;
if FStorage<>nil then FStorage.RenameElement(FName,Value);
FName := Value;
end; {TStgStream.SetName}
//==TStorage===========================================================
constructor TStorage.Create( const AName : String; AParent : TStorage; AStorage : IStorage );
begin
inherited Create;
FStorage := AStorage;
FName := AName;
FParent := AParent;
if AParent<>nil then
begin
FPath := AParent.FPath+AParent.FName+'\';
Inc(AParent.FLockCount);
end;
end; {TStorage.Create}
//-------------------------------------------------------------
destructor TStorage.Destroy;
begin
{ if FStorage<>nil then
begin
FStorage._Release;
FStorage := nil;
end;}
if FParent<>nil then FParent.Close;
inherited Destroy;
end; {TStorage.Destroy}
//-------------------------------------------------------------
procedure TStorage.Close;
begin
if FLockCount>0 then Dec(FLockCount) else Destroy;
end; {TStorage.Destroy}
//-------------------------------------------------------------
function TStorage.CreateStream( const AName : String; const Mode : DWord ) : TStgStream;
var pw : PWideChar;
rc : HResult;
newStream : IStream;
begin
Result := nil;
if (FStorage=nil)or(AName='') then Exit;
pw := StringToOleStr(AName);
try
rc := FStorage.CreateStream( pw, Mode, 0, 0, newStream );
if rc<>S_OK then OleError(rc);
finally
SysFreeString(pw);
end;
if newStream=nil then Exit;
Result := TStgStream.Create( AName, Self, newStream );
end; {TStorage.CreateStream}
//-------------------------------------------------------------
function TStorage.OpenStream( const AName : String; const Mode : DWord ) : TStgStream;
var pw : PWideChar;
rc : HResult;
newStream : IStream;
begin
Result := nil;
if (FStorage=nil)or(AName='') then Exit;
pw := StringToOleStr(AName);
try
rc := FStorage.OpenStream( pw, nil, Mode, 0, newStream );
if rc<>S_OK then OleError(rc);
finally
SysFreeString(pw);
end;
if newStream=nil then Exit;
Result := TStgStream.Create( AName, Self, newStream );
end; {TStorage.CreateStream}
//-------------------------------------------------------------
function TStorage.OpenCreateStream( const AName : String; const Mode : DWord ) : TStgStream;
var pw : PWideChar;
rc : HResult;
newStream : IStream;
begin
Result := nil;
if (FStorage=nil)or(AName='') then Exit;
pw := StringToOleStr(AName);
try
rc := FStorage.OpenStream( pw, nil, Mode and ($ffffffff xor STGM_CREATE xor STGM_CONVERT), 0, newStream );
if rc=STG_E_FILENOTFOUND then rc := FStorage.CreateStream( pw, Mode, 0, 0, newStream );
if rc<>S_OK then OleError(rc);
finally
SysFreeString(pw);
end;
if newStream=nil then Exit;
Result := TStgStream.Create( AName, Self, newStream );
end; {TStorage.CreateStream}
//-------------------------------------------------------------
function TStorage.CreateStorage( const AName : String; const Mode : DWord ) : TStorage;
var pw : PWideChar;
rc : HResult;
newStg : IStorage;
begin
Result := nil;
if AName='' then Exit;
pw := StringToOleStr(AName);
try
rc := FStorage.CreateStorage( pw, Mode, 0, 0, newStg );
if rc<>S_OK then OleError(rc);
finally
SysFreeString(pw);
end;
if newStg=nil then Exit;
Result := TStorage.Create( AName, Self, newStg );
end; {TStorage.CreateStorage}
//-------------------------------------------------------------
function TStorage.OpenStorage( const AName : String; const Mode : DWord ) : TStorage;
var pw : PWideChar;
rc : HResult;
newStg : IStorage;
begin
Result := nil;
if AName='' then Exit;
pw := StringToOleStr(AName);
// newStg := nil;
rc := FStorage.OpenStorage( pw, nil, Mode, nil, 0, newStg );
SysFreeString(pw);
if rc<>S_OK then OleError(rc);
if newStg=nil then Exit;
Result := TStorage.Create( AName, Self, newStg );
end; {TStorage.OpenStorage}
//-------------------------------------------------------------
function TStorage.OpenCreateStorage( const AName : String; const Mode : DWord; var bCreate : Boolean ) : TStorage;
var pw : PWideChar;
rc : HResult;
newStg : IStorage;
begin
Result := nil;
if AName='' then Exit;
pw := StringToOleStr(AName);
if bCreate then rc := FStorage.CreateStorage( pw, Mode, 0, 0, newStg )
else
begin
rc := FStorage.OpenStorage( pw, nil, Mode and ($ffffffff xor STGM_CREATE xor STGM_CONVERT), nil, 0, newStg );
if rc=STG_E_FILENOTFOUND then
begin
rc := FStorage.CreateStorage( pw, Mode, 0, 0, newStg );
bCreate := True;
end;
end;
SysFreeString(pw);
if rc<>S_OK then OleError(rc);
if newStg=nil then Exit;
Result := TStorage.Create( AName, Self, newStg );
end; {TStorage.CreateStorage}
//-------------------------------------------------------------
procedure TStorage.EnumElements( AStrings : TStringList ; dwTypeNeed:DWORD);
const MaxElem = 100;
var rc : HResult;
n,i : LongInt;
oEnum : IEnumSTATSTG;
aElem : Array [0..MaxElem-1] of TSTATSTG;
sName : String;
begin
if AStrings=nil then Exit;
rc := FStorage.EnumElements(0,nil,0,oEnum);
if rc<>S_OK then OleCheck(rc);
n := MaxElem;
// try
repeat
oEnum.Next(MaxElem,aElem,@n);
if n>0 then
for i := 0 to n-1 do with aElem[i] do
begin
if ( dwType and dwTypeNeed ) <> 0 then
begin
WideCharToStrVar(pwcsName,sName);
AStrings.AddObject(sName,Pointer(dwType));
CoTaskMemFree(pwcsName);
end;
end;
until n<>MaxElem;
// finally
// oEnum._Release;
// oEnum := nil;
// end;
end; {TStorage.EnumElements}
//-------------------------------------------------------------
procedure TStorage.RenameElement( const AOldName, ANewName : String );
var wcOld,wcNew : PWideChar;
rc : HResult;
begin
if (AOldName='')or(ANewName='')or(AOldName=ANewName) then Exit;
wcOld := StringToOleStr(AOldName);
wcNew := StringToOleStr(ANewName);
try
rc := FStorage.RenameElement(wcOld,wcNew);
finally
SysFreeString(wcOld);
SysFreeString(wcNew);
end;
OleCheck(rc);
end; {TStorage.RenameElement}
//-------------------------------------------------------------
procedure TStorage.SetName( Value : String );
begin
if FName=Value then Exit;
if (FStorage<>nil)and(FParent<>nil) then FParent.RenameElement(FName,Value);
FName := Value;
end; {TStorage.SetName}
//==TStgFile===========================================================
constructor TStgFile.Create( const AFileName : String; AStorage : IStorage );
begin
inherited Create('',nil,AStorage);
if AFileName='' then Exit;
FFileName := ExpandFileName(AFileName);
FPath := FFileName+':';
end; {TStgFile.Create}
//-------------------------------------------------------------
class function TStgFile.CreateFile( const AFileName : String; const Mode : DWord ) : TStgFile;
var pw : PWideChar;
newStg : IStorage;
begin
Result := nil;
if AFileName='' then Exit;
pw := StringToOleStr(AFileName);
try
newStg := nil;
OleCheck( StgCreateDocFile(pw,Mode,0,newStg) );
finally
SysFreeString(pw);
end;
if newStg<>nil then Result := TStgFile.Create(AFileName,newStg);
end; {TStgFile.CreateFile}
//-------------------------------------------------------------
class function TStgFile.OpenFile( const AFileName : String; const Mode : DWord ) : TStgFile;
var pw : PWideChar;
newStg : IStorage;
begin
Result := nil;
if AFileName='' then Exit;
pw := StringToOleStr(AFileName);
newStg := nil;
try
OleCheck( StgOpenStorage(pw,nil,Mode,nil,0,newStg) );
finally
SysFreeString(pw);
end;
if newStg<>nil then Result := TStgFile.Create(AFileName,newStg);
end; {TStgFile.OpenFile}
//-------------------------------------------------------------
{function TStgFile.Clone( const Mode : DWord ) : TStgFile;
var newStg : IStorage;
begin
Result := nil;
newStg := nil;
if FStorage=nil then Exit;
StgOpenStorage(nil,FStorage,Mode,nil,0,newStg);
if newStg<>nil then Result := TStgFile.Create(Self.FFileName,newStg);
end; {TStgFile.Clone}
procedure TStorage.Commit( cflag:DWORD );
var
rc:HRESULT;
begin
if FStorage <> nil then
rc := FStorage.Commit( cFlag );
if rc <> S_OK then OleError( rc );
end;
end.