structuredstorage.pas

Structured Storage Library in Delphi With source

procedure TStructuredStorage.RenameElement(OldElementName, NewElementName: String);
var
  OldWideName, NewWideName:   Array[0..MAX_PATH] of WideChar;
  pOldWideName, pNewWideName: PWideChar;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Destroy the Element
  pOldWideName := StringToWideChar(OldElementName, @OldWideName[0], Sizeof(OldWideName) div Sizeof(WideChar));
  pNewWideName := StringToWideChar(NewElementName, @NewWideName[0], Sizeof(NewWideName) div Sizeof(WideChar));
  CheckHRESULT(FStorage.RenameElement(pOldWideName, pNewWideName), OldElementName);
end;

procedure TStructuredStorage.SetElementTimes(ElementName: String; CreateTime, AccessTime, ModTime: TDateTime);
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  cTime, aTime, mTime: TFileTime;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Translate the File Times to UTC Time Code
  cTime := DateTimeToUTCFileTime(CreateTime);
  aTime := DateTimeToUTCFileTime(AccessTime);
  mTime := DateTimeToUTCFileTime(ModTime);

  //** Set the Element Times
  pWideName := StringToWideChar(ElementName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  CheckHRESULT(FStorage.SetElementTimes(pWideName, cTime, aTime, mTime), ElementName);
end;

procedure TStructuredStorage.CommitIfCurrent;
begin
  Self.CommitEx(STGC_DEFAULT or STGC_ONLYIFCURRENT);
end;

procedure TStructuredStorage.CommitByForce;
begin
  Self.CommitEx(STGC_DEFAULT);
end;

procedure TStructuredStorage.CommitEx(Mode: Integer);
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Instruct the Storage to Commit data
  CheckHRESULT(FStorage.Commit(Mode), 'CommitEx');
end;

procedure TStructuredStorage.Revert;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Instruct the Storage to Revert data
  CheckHRESULT(FStorage.Revert, 'Revert');
end;

function TStructuredStorage.FindFirst(FindType: TStorageFindSet; var Search: TStorageFind): Boolean;
var
  Enum:  IEnumSTATSTG;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Retrieve an Enumerator Object
  CheckHRESULT(FStorage.EnumElements(0, nil, 0, Enum), 'FindFirst');

  //** Construct the TStorageFind Controller Class
  Search := TStorageFind.Create(FindType, Enum);
  Result := Self.FindNext(Search);
end;

function TStructuredStorage.FindNext(Search: TStorageFind): Boolean;
begin
  Result := FALSE;
  if (Search <> nil) then begin
    //** Iterate the IEnumSTATSTG Interface to Locate the Next Entry
    While (TRUE) do begin
      //** Retrieve the Next Enumeration from IEnumSTATSTG
      if (Search.NextFromInterface) then begin
        if (Search.StorageType in Search.FFindSet) then begin
          Result := TRUE;
          Break;
        end;
      end else begin
        Break;
      end;
    end;
  end;
end;

procedure TStructuredStorage.FindClose(Search: TStorageFind);
begin
  //** Destroy the TStorageFind Controller Object
  if (Search <> nil) then begin
    Search.Free;
  end;
end;

procedure TStructuredStorage.FindAllByType(FindType: TStorageFindSet; List: TStrings);
var
  Search:  TStorageFind;
begin
  if (List <> nil) then begin
    List.Clear;
    if (Self.FindFirst(FindType, Search)) then begin
      List.Add(Search.Name);
      While (Self.FindNext(Search)) do begin
        List.Add(Search.Name);
      end;
      Self.FindClose(Search);
    end;
  end;
end;

function TStructuredStorage.IsStreamPresent(StreamName: String): Boolean;
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  nResult:   HRESULT;
  Stream:    IStream;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Attempt to open the Stream Object
  pWideName := StringToWideChar(StreamName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  nResult := FStorage.OpenStream(pWideName, nil, ssSTRM_DIRECT, 0, Stream);
  if ( nResult = S_OK ) then begin
    //** If successfull, then release the stream and return TRUE
    Stream := nil;
    Result := TRUE;
  end else begin
    Result := FALSE;
  end;
end;

function TStructuredStorage.IsStoragePresent(StorageName: String): Boolean;
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  nResult:   HRESULT;
  Storage:   IStorage;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Create the Sub-Storage Object
  pWideName := StringToWideChar(StorageName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  nResult := FStorage.OpenStorage(pWideName, nil, ssSTOR_DIRECT, nil, 0, Storage);
  if ( nResult = S_OK ) then begin
    //** If successfull, then release the storage and return TRUE
    Storage := nil;
    Result := TRUE;
  end else begin
    Result := FALSE;
  end;
end;


//****************************************************
//****************************************************
//** TStorageStream Constructor & Destructors
//****************************************************
//****************************************************
constructor TStorageStream.CreateFromInterface(Stream: IStream);
begin
  inherited Create;

  //** Assign Stream Object
  FStream := Stream;
end;

destructor TStorageStream.Destroy;
begin
  //** Release the Storage Object if it is Assigned
  if (FStream <> nil) then begin
    FStream := nil;
  end;

  inherited Destroy;
end;

procedure TStorageStream.WriteString(const Value: String);
var
  Size:  Integer;
begin
  Size := Length(Value);
  Self.Write(Size, SizeOf(Size));
  if (Size > 0) then begin
    Self.Write(PCHAR(Value)[0], Size);
  end;
end;

procedure TStorageStream.WriteInteger(const Value: Integer);
begin
  Self.Write(Value, SizeOf(Value));
end;

procedure TStorageStream.WriteBoolean(const Value: Boolean);
begin
  Self.Write(Value, SizeOf(Value));
end;

procedure TStorageStream.WriteStringList(Value: TStrings);
var
  Idx:  Integer;
begin
  //** Write the Total List Count
  Self.WriteInteger(Value.Count);

  //** Write each String in the List
  For Idx := 1 to Value.Count do begin
    Self.WriteString(Value[Idx - 1]);
  end;
end;

function  TStorageStream.ReadString: String;
var
  Size:   Integer;
  Buffer: PCHAR;
begin
  Result := EmptyStr;
  Self.Read(Size, SizeOf(Size));
  if (Size > 0) then begin
    GetMem(Buffer, Size + 1);
    Try
      FillChar(Buffer^, Size + 1, #0);
      Self.Read(Buffer^, Size);
      Result := StrPas(Buffer);
    Finally
      FreeMem(Buffer, Size);
    End;
  end;
end;

function  TStorageStream.ReadInteger: Integer;
begin
  Self.Read(Result, SizeOf(Result));
end;

function  TStorageStream.ReadBoolean: Boolean;
begin
  Self.Read(Result, SizeOf(Result));
end;

procedure TStorageStream.ReadStringList(Value: TStrings);
var
  Count:  Integer;
  Idx:    Integer;
begin
  if (Value <> nil) then begin
    //** Clear the Input List
    Value.Clear;

    //** Read the Total List Count
    Count := Self.ReadInteger;
    For Idx := 1 to Count do begin
      Value.Add(Self.ReadString);
    end;
  end;
end;

procedure TStorageStream.LoadFromFile(const FileName: String);
var
  fHandle:  TFileStream;
begin
  fHandle := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  Try
    Self.CopyFrom(fHandle, fHandle.Size);
  Finally
    fHandle.Free;
  End;
end;

procedure TStorageStream.SaveToFile(const FileName: String);
var
  fHandle:  TFileStream;
begin
  fHandle := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
  Try
    fHandle.CopyFrom(Self, fHandle.Size);
  Finally
    fHandle.Free;
  End;
end;


procedure TStorageStream.SetSize(NewSize: Longint);
begin
  CheckHRESULT(FStream.SetSize(NewSize), 'SetSize');
end;

function TStorageStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result := 0;
  if (@Buffer <> nil) then begin
    CheckHRESULT(FStream.Read(@Buffer, Count, @Result), 'Read');
  end;
end;

function TStorageStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := 0;
  if (@Buffer <> nil) then begin
    CheckHRESULT(FStream.Write(@Buffer, Count, @Result), 'Write');
  end;
end;

function TStorageStream.Seek(Offset: Longint; Origin: Word): Longint;
var
  nPos64: Int64;
begin
  case origin of
    soFromBeginning:  CheckHRESULT(FStream.Seek(Offset, STREAM_SEEK_SET, nPos64), 'Seek');
    soFromCurrent:    CheckHRESULT(FStream.Seek(Offset, STREAM_SEEK_CUR, nPos64), 'Seek');
    soFromEnd:        CheckHRESULT(FStream.Seek(Offset, STREAM_SEEK_END, nPos64), 'Seek');
  end;
  Result := nPos64;
end;





//****************************************************
//****************************************************
//** TStorageFind Constructor & Destructors
//****************************************************
//****************************************************
constructor TStorageFind.Create(FindSet: TStorageFindSet; Enum: IEnumSTATSTG);
begin
  inherited Create;

  //** Setup the Defaults
  FFindSet := FindSet;
  FEnumerator := Enum;
end;

destructor TStorageFind.Destroy;
begin
  //** Release the IEnumSTATSTG Object Interface
  FFindSet := [];
  FEnumerator := nil;

  inherited Destroy;
end;

function TStorageFind.NextFromInterface: Boolean;
var
  Data:  TStatStg;
begin
  FillChar(Data, SizeOf(Data), #0);
  Result := (FEnumerator.Next(1, Data, nil) = S_OK);

  //** Auto-Populate the Data Elements (IEnumSTATSTG)
  if (Result) then begin
    FName := WideCharToString(Data.pwcsName);
    FSize := Data.cbSize;
    FStorageType := GetStorageType(Data.dwType);
    FCreated := UTCFileTimeToDateTime(Data.ctime);
    FLastModified := UTCFileTimeToDateTime(Data.mtime);
    FLastAccessed := UTCFileTimeToDateTime(Data.atime);
  end;

  //** Release IAlloc Memory for Data.pwcsName allocation
  if (Data.pwcsName <> nil) then begin
    CoTaskMemFree(Data.pwcsName);
    Data.pwcsName := nil;
  end;
end;



//****************************************************
//** Utility Functions & Procedures
//****************************************************
function IsFileStorage(const FileName: String): Boolean;
var
 WideName: Array[0..MAX_PATH] of WideChar;
begin
  Result := FileExists(FileName);
  if (Result) then begin
    Result := (StgIsStorageFile(StringToWideChar(FileName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar))) = S_OK);
  end;
end;

procedure CheckHRESULT(Code: HRESULT; Subst: String);
var
  Params:  Array[0..5] of PChar;
  szFmt:   String;
  Buffer:  Array[0..256] of Char;
begin
  if (Code <> S_OK) then begin
    szFmt := SysErrorMessage(Code);
    if (Length(Subst) < 1) then begin
      Subst := '<empty>';
    end;
    FillChar(Params, SizeOf(Params), #0);
    FillChar(Buffer, SizeOf(Buffer), #0);
    Params[0] := PCHAR(Subst);
    FormatMessage(FORMAT_MESSAGE_FROM_STRING or
                  FORMAT_MESSAGE_ARGUMENT_ARRAY,
                  PChar(szFmt), 0, 0,
                  @Buffer[0], SizeOf(Buffer),
                  @Params[0]);

    Raise EStructuredStorage.Create(StrPas(Buffer));
  end;
end;

function GetStorageType(dwType: DWORD): TStorageType;
begin
  case dwType of
    STGTY_STORAGE:    Result := stStorage;
    STGTY_STREAM:     Result := stStream;
    STGTY_LOCKBYTES:  Result := stLockBytes;
    STGTY_PROPERTY:   Result := stProperty;
  else
    result := stUnknown;
  end;
end;

function UTCFileTimeToDateTime(const ft: TFileTime): TDateTime;
var
  tmpft: TFileTime;
  st:    TSystemTime;
begin
  //** Setup the Default
  Result := 0;

  //** Translaste the (UTC) Universal Time Coordinate to the TDateTime.
  if (ft.dwLowDateTime > 0) OR (ft.dwHighDateTime > 0) then begin
    if (FileTimeToLocalFileTime(ft, tmpft)) then begin
      if (FileTimeToSystemTime(tmpft, st)) then begin
        Result := SystemTimeToDateTime(st);
      end;
    end;
  end;
end;

function DateTimeToUTCFileTime(const dt: TDateTime): TFileTime;
var
  tmpft:  TFileTime;
  tmpft2: TFileTime;
  st:     TSystemTime;
begin
  //** Default Return Value
  Result.dwLowDateTime := 0;
  Result.dwHighDateTime := 0;

  //** Translaste the TDateTime to (UTC) Universal Time Coordinate.
  DateTimeToSystemTime(dt, st);
  if (SystemTimeToFileTime(st, tmpft)) then begin
    if (LocalFileTimeToFileTime(tmpft, tmpft2)) then begin
      Result := tmpft2;
    end;
  end;
end;


end.