jclstructstorage.pas

East make Tray Icon in delphi

  begin
    AName := StrToWChar(FFileName);
    try
      if FConvertedMode and STGM_CREATE = STGM_CREATE then
        HR := StgCreateDocfile(AName, FConvertedMode, 0, FStorage)
      else
        HR := StgOpenStorage(AName, nil, FConvertedMode, nil, 0, FStorage);
    finally
      FreeWChar(AName);
    end;
    if not Succeeded(HR) then
      raise EJclStructStorageError.Create(SysErrorMessage(HR));
  end;
end;

function TJclStructStorageFolder.CheckResult(HR: HRESULT): Boolean;
begin
  Result := Succeeded(HR);
  FLastError := HR;
end;

function TJclStructStorageFolder.GetFileStream(const Name: string; out Stream: TStream): Boolean;
var
  AName: PWideChar;
  Stm: IStream;
begin
  Check;
  AName := StrToWChar(Name);
  try
    // Streams don't support transactions, so always create in direct mode
    // Streams only support STGM_SHARE_EXCLUSIVE so add this explicitly
    if Succeeded(FStorage.OpenStream(AName, nil,
      AccessToMode(FAccessMode - [smCreate] + [smShareDenyRead, smShareDenyWrite]), 0, Stm)) then
    begin
      Stream := TJclStructStorageStream.Create;
      TJclStructStorageStream(Stream).FStream := Stm;
      TJclStructStorageStream(Stream).FName := Name;
      Result := True;
    end
    else
    begin
      Result := False;
      Stream := nil;
    end;
  finally
    FreeWChar(AName);
  end;
end;

function TJclStructStorageFolder.GetFolder(const Name: string; out Storage: TJclStructStorageFolder): Boolean;
var
  AName: PWideChar;
  AMode: UINT;
  Strg: IStorage;
begin
  Check;
  AName := StrToWChar(Name);
  try
    // Sub storages only supports STGM_SHARE_EXCLUSIVE, so add explicitly
    AMode := AccessToMode(FAccessMode - [smCreate] + [smShareDenyRead, smShareDenyWrite]);
    if Succeeded(FStorage.OpenStorage(AName, nil,
      AMode, nil, 0, Strg)) then
    begin
      // The parameters here has no real meaning since we set up the private fields directly
      Storage := TJclStructStorageFolder.Create(Name, FAccessMode);
      TJclStructStorageFolder(Storage).FConvertedMode := AMode;
      TJclStructStorageFolder(Storage).FStorage := Strg;
      TJclStructStorageFolder(Storage).FFileName := Name;
      Result := True;
    end
    else
    begin
      Storage := nil;
      Result := False;
    end;
  finally
    FreeWChar(AName);
  end;
end;

function TJclStructStorageFolder.GetSubItems(Strings: TStrings;
  Folders: Boolean): Boolean;
var
  Enum: IEnumSTATSTG;
  Stat: TStatStg;
  NumFetch: Longint;
begin
  Check;
  Strings.BeginUpdate;
  try
    Strings.Clear;
    Result := CheckResult(FStorage.EnumElements(0, nil, 0, Enum));
    if not Result then
      Exit;
    while Succeeded(Enum.Next(1, Stat, @NumFetch)) and (NumFetch = 1) do
    try
      if Folders and (Stat.dwType = STGTY_STORAGE) then
        Strings.Add(WideCharToString(Stat.pwcsName))
      else
      if not Folders and (Stat.dwType = STGTY_STREAM) then
        Strings.Add(WideCharToString(Stat.pwcsName));
    finally
      CoMallocFree(Stat.pwcsName);
    end;
  finally
    Strings.EndUpdate;
  end;
end;

function TJclStructStorageFolder.Rename(const OldName, NewName: string): Boolean;
var
  PWO, PWN: PWideChar;
begin
  Check;
  PWO := StrToWChar(OldName);
  PWN := StrToWChar(NewName);
  try
    // this will fail if the subelement is open
    Result := CheckResult(FStorage.RenameElement(PWO, PWN));
  finally
    FreeWChar(PWO);
    FreeWChar(PWN);
  end;
end;

class function TJclStructStorageFolder.IsStructured(const FileName: string): HRESULT;
var
  AName: PWideChar;
begin
  AName := StrToWChar(FileName);
  try
    Result := StgIsStorageFile(AName);
  finally
    FreeWChar(AName);
  end;
end;

class function TJclStructStorageFolder.Convert(const FileName: string): HRESULT;
var
  Strg: IStorage;
  AName: PWideChar;
begin
  Result := IsStructured(FileName);
  if Succeeded(Result) then
  begin
    AName := StrToWChar(FileName);
    try
      Result := StgCreateDocFile(AName, STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CONVERT, 0, Strg);
//      Result := (HR = S_OK) or (HR = STG_S_CONVERTED);
    finally
      FreeWChar(AName);
    end;
  end;
end;

function TJclStructStorageFolder.GetStats(out Stat: TStatStg; IncludeName: Boolean): Boolean;
const
  Flags: array [Boolean] of Longint =
    (STATFLAG_NONAME, STATFLAG_DEFAULT);
begin
  Check;
  Result := CheckResult(FStorage.Stat(Stat, Flags[IncludeName]));
end;

function TJclStructStorageFolder.SetElementTimes(const Name: string; Stat: TStatStg): Boolean;
var
  AName: PWideChar;
begin
  Check;
  AName := StrToWChar(Name);
  try
    with Stat do
      Result := CheckResult(FStorage.SetElementTimes(AName, ctime, atime, mtime));
  finally
    FreeWChar(AName);
  end;
end;

function TJclStructStorageFolder.Commit: Boolean;
begin
  Check;
  Result := CheckResult(FStorage.Commit(STGC_DEFAULT)) or
    CheckResult(FStorage.Commit(STGC_OVERWRITE));
end;

function TJclStructStorageFolder.Revert: Boolean;
begin
  Check;
  Result := CheckResult(FStorage.Revert);
end;

function TJclStructStorageFolder.CopyTo(const OldName, NewName: string; Dest: TJclStructStorageFolder): Boolean;
var
  PWO, PWN: PWideChar;
begin
  Result := False;
  if Dest = nil then
    Exit;
  Check;
  Dest.Check;
  PWO := StrToWChar(OldName);
  PWN := StrToWChar(NewName);
  try
    Result := CheckResult(FStorage.MoveElementTo(PWO, Dest.FStorage, PWN, STGMOVE_COPY));
  finally
    FreeWChar(PWO);
    FreeWChar(PWN);
  end;
end;

procedure TJclStructStorageFolder.AssignTo(Dest: TPersistent);
begin
  if Dest is TJclStructStorageFolder then
  begin
    Check;
    TJclStructStorageFolder(Dest).Check;
    CheckResult(FStorage.CopyTo(0, nil, nil, TJclStructStorageFolder(Dest).FStorage));
  end
  else
    inherited AssignTo(Dest);
end;

function TJclStructStorageFolder.MoveTo(const OldName, NewName: string;
  Dest: TJclStructStorageFolder): Boolean;
var
  PWO, PWN: PWideChar;
begin
  Result := False;
  if Dest = nil then
    Exit;
  Check;
  Dest.Check;
  PWO := StrToWChar(OldName);
  PWN := StrToWChar(NewName);
  try
    Result := CheckResult(FStorage.MoveElementTo(PWO, Dest.FStorage, PWN, STGMOVE_MOVE));
  finally
    FreeWChar(PWO);
    FreeWChar(PWN);
  end;
end;

function TJclStructStorageFolder.GetName: string;
var
  Stat: StatStg;
begin
  if (FStorage <> nil) and CheckResult(FStorage.Stat(Stat, STATFLAG_DEFAULT)) then
  begin
    Result := WideCharToString(Stat.pwcsName);
    CoMallocFree(Stat.pwcsName);
  end
  else
    Result := FFileName;
end;

procedure TJclStructStorageFolder.FreeStats(var Stat: TStatStg);
begin
  if Stat.pwcsName <> nil then
    CoMallocFree(Stat.pwcsName);
end;

//=== { TJclStructStorageStream } ============================================

destructor TJclStructStorageStream.Destroy;
begin
  FStream := nil;
  inherited Destroy;
end;

procedure TJclStructStorageStream.Check;
begin
  if FStream = nil then
    raise EJclStructStorageError.CreateRes(@RsIStreamNil);
end;

function TJclStructStorageStream.CheckResult(HR: HRESULT): Boolean;
begin
  Result := Succeeded(HR);
  FlastError := HR;
end;

function TJclStructStorageStream.Clone: TJclStructStorageStream;
var
  Stm: IStream;
begin
  if Succeeded(FStream.Clone(Stm)) then
  begin
    Result := TJclStructStorageStream.Create;
    Result.FStream := Stm;
  end
  else
    Result := nil;
end;

function TJclStructStorageStream.CopyTo(Stream: TJclStructStorageStream;
  Size: Int64): Boolean;
var
  DidRead, DidWrite: Int64;
begin
  DidRead := 0;
  DidWrite := 0;
  Result := Succeeded(FStream.CopyTo(Stream.FStream, Size, DidRead, DidWrite));
end;

procedure TJclStructStorageStream.FreeStats(var Stat: TStatStg);
begin
  if Stat.pwcsName <> nil then
    CoMallocFree(Stat.pwcsName);
end;

function TJclStructStorageStream.GetName: string;
var
  Stat: StatStg;
begin
  if (FStream <> nil) and CheckResult(FStream.Stat(Stat, STATFLAG_DEFAULT)) then
  begin
    Result := WideCharToString(Stat.pwcsName);
    CoMallocFree(Stat.pwcsName);
  end
  else
    Result := Fname;
end;

function TJclStructStorageStream.GetStats(out Stat: TStatStg; IncludeName: Boolean): Boolean;
const
  Flags: array [Boolean] of Longint =
    (STATFLAG_NONAME, STATFLAG_DEFAULT);
begin
  Check;
  Result := CheckResult(FStream.Stat(Stat, Flags[IncludeName]));
end;

function TJclStructStorageStream.Read(var Buffer; Count: Longint): Longint;
begin
  Check;
  if not Succeeded(FStream.Read(@Buffer, Count, @Result)) then
    Result := 0;
end;

function TJclStructStorageStream.Seek(Offset: Integer; Origin: Word): Longint;
var
  N: Int64;
begin
  Check;
  if not Succeeded(FStream.Seek(Offset, Ord(Origin), N)) then
    Result := -1
  else
    Result := N;
end;

procedure TJclStructStorageStream.SetSize(NewSize: Longint);
begin
  Check;
  FStream.SetSize(NewSize);
end;

function TJclStructStorageStream.Write(const Buffer; Count: Longint): Longint;
begin
  Check;
  if not Succeeded(FStream.Write(@Buffer, Count, @Result)) then
    Result := 0;
end;

// History:

// $Log: JclStructStorage.pas,v $
// Revision 1.8  2005/03/08 08:33:23  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.7  2005/02/24 16:34:52  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.6  2004/10/02 05:47:29  marquardt
// added check for incompatible jedi.inc
// replaced jedi.inc with jvcl.inc
//
// Revision 1.5  2004/08/02 15:30:17  marquardt
// hunting down (rom) comments
//
// Revision 1.4  2004/08/01 11:40:23  marquardt
// move constructors/destructors
//
// Revision 1.3  2004/07/28 18:00:54  marquardt
// various style cleanings, some minor fixes
//
// Revision 1.2  2004/06/16 07:30:31  marquardt
// added tilde to all IFNDEF ENDIFs, inherited qualified
//
// Revision 1.1  2004/06/12 02:50:33  rrossmair
// initial check-in
//
//
// donated 2004/04/30 20:54:36

end.