home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 January / Chip_1999-01_cd.bin / zkuste / delphi / D / COMPDOCS.ZIP / CompDoc.pas next >
Pascal/Delphi Source File  |  1998-01-06  |  30KB  |  974 lines
  1. (*
  2.                      Compound Documents v1.00
  3.                      ~~~~~~~~~~~~~~~~~~~~~~~~
  4.                        Robert R. Marsh, SJ
  5.                         rrm@sprynet.com
  6.                 http://home.sprynet.com/sprynet/rrm/
  7.  
  8.    Compound Documents, or OLE Structured Storage, provide an
  9.    ingenious and easy way to effectively create a full file-system
  10.    within a file. A compound document functions as a 'directory'
  11.    (or root storage in the lingo) which can contain 'sub-directories'
  12.    (aka storages) and/or 'files' (aka streams).
  13.    Compound documents also have the ability to automatically buffer
  14.    any changes until they are committed or rolled back.
  15.  
  16.    Unfortunately, the association with OLE/ActiveX keeps many Delphi
  17.    users away. But while the details can be messy there is no deep
  18.    difficulty. Some Delphi encapsulations of compound files are
  19.    already available but either cost big bucks or mirror the
  20.    underlying API too closely with all its arcane flags many of which
  21.    are mutually exclusive. The components presented here encapsulate
  22.    the OLE structured storage API in a what is, I hope, a Delphi-
  23.    friendly manner, free from all the OLE clutter. What's more they
  24.    work in all three versions of Delphi (see below for a caveat).
  25.  
  26.    A TRootStorage object corresponds to a physical file on disk.
  27.    Other TStorage objects correspond to sub-storages of a root
  28.    storage. Apart from their mode of construction both objects have
  29.    similar behavior. They have methods to manage the sub-storages
  30.    and streams they contain (CopyElement, MoveElement, RenameElement,
  31.    DeleteElement, CopyTo, ListStorages, ListStreams) and methods to
  32.    handle transaction processing (Commit, Revert).
  33.  
  34.    TStorageStream objects always belong to a parent storage object.
  35.    They are fully compatible with Delphi's other stream objects.
  36.    Despite the impression given in many descriptions transaction
  37.    processing does not work at the stream level but only for storages.
  38.  
  39.    Transaction processing operates by publishing any changes visible
  40.    at one level in the storage hierarchy to the parent level. A
  41.    storage has no knowledge of changes made at a deeper level until
  42.    they percolate upwards through a series of Commit operations.
  43.    When a root storage commits its changes they are written to the
  44.    physical file.
  45.  
  46.    Both storages and streams can be created as temporary objects by
  47.    providing no Name parameter. A unique name is generated by Windows
  48.    and is available through the Name property. Such objects are self-
  49.    deleting.
  50.  
  51.    The OLE documentation warns that compound files are optimized
  52.    for common operations (like the reading and writing of streams)
  53.    and that other operations (especially those involving the
  54.    enumeration of storage elements) can be slow. Although I have
  55.    provided some enumeration methods (ListStorages, ListStreams) you
  56.    will get better performance if you create a separate stream to
  57.    store such information for yourself. In general, I have found
  58.    read/write operations to be about 2 to 3 times slower than
  59.    equivalent operations on 'ordinary' file streams. Not bad
  60.    considering the extra functionality.
  61.  
  62.    You can find out more about Compound Documents / OLE Structured
  63.    Storage from the excellent book "Inside OLE" (2nd ed.) by Kraig
  64.    Brockschmidt (Microsoft Press) or from the Microsoft Developers
  65.    Network library (via http://microsoft.com/msdn/). Good luck!
  66.  
  67.    One of the benefits of these components is that someone has read
  68.    the small print for you and made many illegal operations
  69.    impossible. I realize, however, that I have probably misread in
  70.    some cases. So if you find problems with this code please let me
  71.    know at the address above so that I can learn from my mistakes.
  72.  
  73.    I referred above to a caveat regarding the use of these components
  74.    with Delphi 1. There are two issues. First, as I understand it, OLE2
  75.    came on the scene after Windows 3.1 so that plain vanilla
  76.    installations don't include the necessary OLE dlls. Nevertheless,
  77.    it would be rare to find a machine that hasn't had the OLE2 files
  78.    added by one application or another. The second issue has more to
  79.    do with Borland. The OLE2 DCU and PAS files they supplied with D1
  80.    seem to be contain errors (even on the D2 and D3 CDs). I have taken
  81.    the liberty of correcting the problems which pertain to Compound
  82.    Documents and also changed some of the flag declaration to bring them
  83.    more into line with D2 and D3. The result is a file called OLE2_16
  84.    which must be used with CompDoc.DCU under Delphi 1. Other versions
  85.    of Delphi can ignore this file.
  86.  
  87.    If you like these components and find yourself using them please
  88.    consider making a donation to your favorite charity. I would also
  89.    be pleased if you would make acknowledgement in any projects that
  90.    make use of them.
  91.  
  92.    These components are supplied as is. The author disclaims all
  93.    warranties, expressed or implied, including, without limitation,
  94.    the warranties of merchantability and of fitness for any purpose.
  95.    The author assumes no liability for damages, direct or
  96.    consequential, which may result from their use.
  97.  
  98.            Copyright (c) 1998 Robert R. Marsh, S.J. &
  99.           the British Province of the Society of Jesus
  100.  
  101. *)
  102.  
  103.  
  104. unit CompDoc;
  105.  
  106. interface
  107.  
  108. uses
  109.   {$IFDEF WIN32}Windows{$ELSE}WinTypes, WinProcs{$ENDIF},
  110.   {$IFDEF VER100}ActiveX{$ENDIF}
  111.   {$IFDEF VER90}OLE2{$ENDIF}
  112.   {$IFDEF VER80}OLE2_16{$ENDIF},
  113.   SysUtils, Classes;
  114.  
  115.   { These Mode flags govern the creation and opening of storages }
  116.   { and streams. Note that some constructors use only some of    }
  117.   { them.                                                        }
  118. type
  119.   { Corresponds to fmOpenRead etc. but applies to root storages, }
  120.   { storages, and streams. An inner element should not have be   }
  121.   { given a more permissive access mode than its parent storage. }
  122.   { However, in transacted mode no conflict will arise until     }
  123.   { Commit is called.                                            }
  124.   TAccessMode = (amRead, amWrite, amReadWrite);
  125.   { Corresponds to fmShareExclusive etc. Only applies to root    }
  126.   { storages. Ordinary storages have to be opened for exclusive  }
  127.   { use. (The small print!)                                      }
  128.   TShareMode = (smExclusive, smDenyWrite, smDenyRead, smDenyNone);
  129.   { Root storages and storages can be opened in transacted mode  }
  130.   { such that their changes remain temporary until Commit is     }
  131.   { called. Note that streams cannot be opened in transaction    }
  132.   { mode. Any changes to a stream are commited directly to the   }
  133.   { parent storage. This storage though can be transacted.       }
  134.   TTransactMode = (tmDirect, tmTransacted);
  135.  
  136. type
  137.   ECompDocError = class(Exception);
  138.   ECDStorageError = class(ECompDocError);
  139.   ECDStreamError = class(ECompDocError);
  140.  
  141. {$IFNDEF WIN32}
  142. type
  143.   PWideChar = pchar;
  144.   TCLSID = CLSID;
  145. {$ENDIF}
  146.  
  147. type
  148.   TStorageTimes = record
  149.     Creation : TFileTime;
  150.     LastAccess : TFileTime;
  151.     LastModify : TFileTime;
  152.   end;
  153.  
  154. type
  155. { encapsulates the compound document storage object }
  156.   TStorage = class(TObject)
  157.   private
  158.     FName : string;
  159.     FParent : TStorage;
  160.     FThis : IStorage;
  161.     hr : HResult;
  162.   protected
  163.     { checks hr and raises exception with msg (msg ignored in D1) }
  164.     procedure CheckError(msg : string);
  165.     procedure CopyMoveElement(const srcname, dstname : string; Dst : TStorage; flag : longint);
  166.     function GetCLSID : TCLSID;
  167.     function GetName : string;
  168.     function GetTimes : TStorageTimes;
  169.     procedure SetCLSID(Value : TCLSID);
  170.   public
  171.     { Creates (CreateNew = true) or opens (CreateNew = false) }
  172.     { a storage within another storage. Fails if              }
  173.     { ParentStorage is nil.                                   }
  174.     { If creating a new storage, Name is null (''), a self-   }
  175.     { deleting temporary storage is created.                  }
  176.     { If a storage is in transacted mode any methods that     }
  177.     { make changes to the storage only take effect when       }
  178.     { Commit is called.                                       }
  179.     { Note that all storages other than root storages can     }
  180.     { only be opened for exclusive access.                    }
  181.     constructor Create(Name : string; ParentStorage : TStorage; AccessMode : TAccessMode;
  182.       TransactMode : TTransactMode; CreateNew : boolean);
  183.     { Closes the storage. If the storage is temporary it is }
  184.     { also deleted. If in transacted mode any uncommitted   }
  185.     { changes are lost.                                     }                                        
  186.     destructor Destroy; override;
  187.     { If the storage was opened in transacted mode Commit  }
  188.     { publishes changes at its own level to the next       }
  189.     { higher level. If the storage is a root storage the   }
  190.     { changes are committed to the underlying file system .}
  191.     procedure Commit;
  192.     { Copies an element of the storage (i.e., a substorage }
  193.     { or stream) to another storage, optionally changing   }
  194.     { the element name.                                    }
  195.     procedure CopyElement(const srcname, dstname : string; Dst : TStorage);
  196.     { Copies all the contents of the storage to another }
  197.     { storage. If the destination storage is not empty  }
  198.     { the new elements will be added to it, possibly    }
  199.     { overwriting elements of the same name.            }
  200.     procedure CopyTo(Dst : TStorage);
  201.     { Removes a substorage or stream from the storage. }
  202.     procedure DeleteElement(const Name : string);
  203.     { Fills StreamList with the names of all the storage's ]
  204.     { streams.                                             }
  205.     procedure ListStreams(StreamList : TStrings);
  206.     { Fills StorageList with the names of all the storage's ]
  207.     { substorages.                                          }
  208.     procedure ListStorages(StorageList : TStrings);
  209.     { Like CopyElement followed by delete. }
  210.     procedure MoveElement(const srcname, dstname : string; Dst : TStorage);
  211.     { Renames one of the storage's substorages or streams. }
  212.     procedure RenameElement(const OldName, NewName : string);
  213.     { In transacted mode undoes any changes made since the }
  214.     { Commit.                                              }
  215.     procedure Revert;
  216.     { The CLSID associated with this storage. }
  217.     property ClassID : TCLSID Read GetCLSID Write SetCLSID;
  218.     { The last error code. Read-only.}
  219.     property LastError : HResult Read hr;
  220.     { The Name of the storage. If the storage was created as  }
  221.     { temporary the actual name will be retrieved. Read-only. }
  222.     property Name : string Read GetName;
  223.     { The storage whgich contains this storage. Read-only. }
  224.     property ParentStorage : TStorage Read FParent;
  225.     { The date/times of the storage's creation, last access, }
  226.     { and last modification. Read-only.                      }
  227.     property Times : TStorageTimes Read GetTimes;
  228.   end;
  229.  
  230.   { A root storage corresponds to a compound file. It has all }
  231.   { the behaviors of any other storage but can also be opened }
  232.   { in the full range of share modes.                         }
  233.   TRootStorage = class(TStorage)
  234.   public
  235.     constructor Create(Name : string; AccessMode : TAccessMode; ShareMode : TShareMode;
  236.       TransactMode : TTransactMode; CreateNew : boolean);
  237.     { Creates a new storage from ordinary file Name. The }
  238.     { file's contents are placed in a stream named       }
  239.     { 'CONTENTS'.                                        }
  240.     constructor Convert(Name : string; AccessMode : TAccessMode; ShareMode : TShareMode;
  241.       TransactMode : TTransactMode);
  242.   end;
  243.  
  244.   { A descendant of TStream with all its behaviors (CopyFrom, }
  245.   { ReadBuffer, etc.). Note that storage streams cannot be    }
  246.   { opened in transacted mode.                                }
  247.   TStorageStream = class(TStream)
  248.   private
  249.     FName : string;
  250.     FParent : TStorage;
  251.     FThis : IStream;
  252.     hr : HResult;
  253.   protected
  254.     procedure CheckError(msg : string);
  255.     function GetName : string;
  256.     {$IFDEF VER100}
  257.     procedure SetSize(NewSize : longint); override;
  258.     {$ELSE}
  259.     procedure SetSize(NewSize : longint);
  260.     {$ENDIF}
  261.   public
  262.     { Creates (CreateNew = true) or opens (CreateNew = false) }
  263.     { a stream within a storage. Fails if ParentStorage is    }
  264.     { nil. If creating a new stream, Name is null (''), a     }
  265.     { self-deleting temporary stream is created.              }
  266.     { Note that streams can only be opened for exclusivey.    }
  267.     constructor Create(Name : string; ParentStorage : TStorage; AccessMode : TAccessMode;
  268.       CreateNew : boolean); virtual;
  269.     { Constructs a stream another stream such that both have }
  270.     { live access to the same data but at different offsets. }
  271.     { The initial offset matches that of the other stream.   }
  272.     { Changes written to one stream are immediately visible  }
  273.     { to the other.                                          }
  274.     constructor CloneFrom(CDStream : TStorageStream);
  275.     { Closes the stream writing any changes to the parent }
  276.     { storage.                                            }
  277.     destructor Destroy; override;
  278.     function Read(var Buffer; Count : longint) : longint; override;
  279.     function Seek(Offset : longint; Origin : word) : longint; override;
  280.     function Write(const Buffer; Count : longint) : longint; override;
  281.     property LastError : HResult Read hr;
  282.     { The Name of the stream. If the stream was created as    }
  283.     { temporary the actual name will be retrieved. Read-only. }
  284.     property Name : string Read GetName;
  285.     { The storage whgich contains this stream. Read-only. }
  286.     property ParentStorage : TStorage Read FParent;
  287.   end;
  288.  
  289. { helper procedures }
  290.  
  291. { True if a file exists and is a compound document. }
  292. function FileIsCompoundDoc(const FileName : string) : boolean;
  293.  
  294. { Converts an existing file into a compound document with the }
  295. { file contents as a stream names 'CONTENTS'.                 }
  296. { Fails if FileName is already compound or in use.            }
  297. procedure ConvertFileToCompoundDoc(const FileName : string);
  298.  
  299. { Defragments a compound document and thus shrinks it. }
  300. { Fails if FileName is in use.                    }
  301. procedure PackCompoundDoc(const FileName : string);
  302.  
  303. { Sets the file date/times of a compound doc. If any of the }
  304. { time values are zero that filetime will not be set.       }
  305. { Fails if FileName is in use.                              }
  306. procedure SetTimesOfCompoundDoc(const FileName : string; Times : TStorageTimes);
  307.  
  308. implementation
  309.  
  310. const
  311.   S_OK = HResult(0);
  312.   E_Fail = HResult($80004005);
  313.  
  314.  
  315.   {$IFNDEF WIN32}
  316.  
  317. function Succeeded(hr : HResult) : boolean;
  318. begin
  319.   Result := SucceededHR(hr);
  320. end;
  321.  
  322. function Failed(hr : HResult) : boolean;
  323. begin
  324.   Result := FailedHR(hr);
  325. end;
  326.  
  327. function StringToPWideChar(S : string) : PWideChar;
  328. var
  329.   size : integer;
  330. begin
  331.   size := Length(S) + 1;
  332.   Result := StrAlloc(size);
  333.   Result := StrPCopy(Result, S);
  334. end;
  335.  
  336. function PWideCharToString(pw : PWideChar) : string;
  337. begin
  338.   Result := StrPas(pw);
  339. end;
  340.  
  341. procedure FreePWideChar(pw : PWideChar);
  342. begin
  343.   if Assigned(pw) then StrDispose(pw);
  344. end;
  345.  
  346. {$ELSE}
  347.  
  348. function StringToPWideChar(S : string) : PWideChar;
  349. var
  350.   OldSize : integer;
  351.   NewSize : integer;
  352. begin
  353.   OldSize := Length(S) + 1;
  354.   NewSize := OldSize * 2;
  355.   Result := AllocMem(NewSize);
  356.   MultiByteToWideChar(CP_ACP, 0, pchar(S), OldSize, Result, NewSize);
  357. end;
  358.  
  359. function PWideCharToString(pw : PWideChar) : string;
  360. var
  361.   p : pchar;
  362.   iLen : integer;
  363. begin
  364.   iLen := lstrlenw(pw) + 1;
  365.   GetMem(p, iLen);
  366.   WideCharToMultiByte(CP_ACP, 0, pw, iLen, p, iLen * 2, nil, nil);
  367.   Result := p;
  368.   FreeMem(p, iLen);
  369. end;
  370.  
  371. procedure FreePWideChar(pw : PWideChar);
  372. begin
  373.   if Assigned(pw) then FreeMem(pw);
  374. end;
  375. {$ENDIF}
  376.  
  377. var
  378.   ThisMalloc : IMalloc;
  379.  
  380. procedure CoFreeMem(p : pointer);
  381. begin
  382.   ThisMalloc.Free(p);
  383. end;
  384.  
  385. procedure GetElements(Storage : IStorage; List : TStrings; GetStorages : boolean);
  386. var
  387.   Enum : IEnumSTATSTG;
  388.   StatStg : TStatStg;
  389.   NumFetched : longint;
  390.   hr : HResult;
  391. begin
  392.   hr := Storage.EnumElements(0, nil, 0, Enum);
  393.   if hr <> S_OK then
  394.     raise ECompDocError.Create('failed enumeration');
  395.   repeat
  396.     {$IFDEF WIN32}
  397.     hr := Enum.Next(1, StatStg, @NumFetched);
  398.     {$ELSE}
  399.     hr := Enum.Next(1, StatStg, NumFetched);
  400.     {$ENDIF}
  401.     if (hr = S_OK) then
  402.     begin
  403.       if GetStorages then
  404.       begin
  405.         if StatStg.dwType = STGTY_STORAGE then
  406.           List.Add(PWideCharToString(StatStg.pwcsName));
  407.       end
  408.       else
  409.       begin
  410.         if StatStg.dwType = STGTY_STREAM then
  411.           List.Add(PWideCharToString(StatStg.pwcsName));
  412.       end;
  413.       CoFreeMem(StatStg.pwcsName);
  414.     end;
  415.   until (hr <> S_OK);
  416.   {$IFNDEF VER100}
  417.   Enum.Release;
  418.   {$ENDIF}
  419. end;
  420.  
  421. function GetMode(Accessmode : TAccessMode; ShareMode : TShareMode;
  422.   TransactMode : TTransactMode; CreateNew : boolean) : longint;
  423. begin
  424.   Result := ord(AccessMode) or (Ord(Succ(ShareMode)) shl 4) or (Ord(TransactMode) shl 16);
  425.   if CreateNew then
  426.     Result := Result or STGM_CREATE;
  427. end;
  428.  
  429. constructor TStorage.Create(Name : string; ParentStorage : TStorage; AccessMode : TAccessMode;
  430.   TransactMode : TTransactMode; CreateNew : boolean);
  431. var
  432.   Mode : longint;
  433.   PName : PWideChar;
  434. begin
  435.   Mode := GetMode(AccessMode, smExclusive, TransactMode, CreateNew);
  436.   if ParentStorage = nil then
  437.   begin
  438.     hr := E_Fail;
  439.     CheckError('no parent storage speciified');
  440.   end;
  441.   if CreateNew then
  442.   begin
  443.     if Name = '' then
  444.     begin
  445.       PName := nil;
  446.       Mode := Mode or STGM_DELETEONRELEASE;
  447.     end
  448.     else
  449.       PName := StringToPWideChar(Name);
  450.     try
  451.       hr := ParentStorage.FThis.CreateStorage(PName, Mode, 0, 0, FThis);
  452.       CheckError('storage create failed');
  453.     finally
  454.       FreePWideChar(PName);
  455.     end;
  456.     FName := Name;
  457.     FParent := ParentStorage;
  458.   end
  459.   else
  460.   begin
  461.     if Name = '' then
  462.     begin
  463.       PName := nil;
  464.       hr := E_FAIL;
  465.     end
  466.     else
  467.     begin
  468.       PName := StringToPWideChar(Name);
  469.       hr := S_OK;
  470.     end;
  471.     CheckError('no storage name given');
  472.     try
  473.       hr := ParentStorage.FThis.OpenStorage(PName, nil, Mode, nil, 0, FThis);
  474.       CheckError('storage open failed');
  475.     finally
  476.       FreePWideChar(PName);
  477.     end;
  478.     FName := Name;
  479.     FParent := ParentStorage;
  480.   end;
  481. end;
  482.  
  483. destructor TStorage.Destroy;
  484. begin
  485.   FName := '';
  486.   FParent := nil;
  487.   {$IFNDEF VER100}
  488.   if Assigned(FThis) then FThis.Release;
  489.   {$ENDIF}
  490.   FThis := nil;
  491.   inherited Destroy;
  492. end;
  493.  
  494. procedure TStorage.Commit;
  495. const
  496.   STG_E_MEDIUMFULL = HResult($80004070);
  497. begin
  498.   hr := FThis.Commit(STGC_DEFAULT);
  499.   if hr = STG_E_MEDIUMFULL then
  500.     hr := FThis.Commit(STGC_OVERWRITE);
  501.   CheckError('storage failed to commit');
  502. end;
  503.  
  504. procedure TStorage.CopyMoveElement(const srcname, dstname : string; Dst : TStorage; flag : longint);
  505. var
  506.   SrcPName : PWideChar;
  507.   DstPName : PWideChar;
  508. begin
  509.   SrcPName := StringToPWideChar(srcname);
  510.   try
  511.     DStPName := StringToPWideChar(dstname);
  512.     try
  513.       hr := FThis.MoveElementTo(SrcPName, Dst.FThis, DstPName, flag);
  514.       CheckError('storage failed to copy/move');
  515.     finally
  516.       FreePWideChar(DstPName);
  517.     end;
  518.   finally
  519.     FreePWideChar(SrcPName)
  520.   end;
  521. end;
  522.  
  523. procedure TStorage.CopyElement(const srcname, dstname : string; Dst : TStorage);
  524. begin
  525.   CopyMoveElement(srcname, dstname, Dst, STGMOVE_COPY);
  526. end;
  527.  
  528. procedure TStorage.CopyTo(Dst : TStorage);
  529. begin
  530.   {$IFDEF WIN32}
  531.   hr := FThis.CopyTo(0, nil, nil, Dst.FThis);
  532.   {$ELSE}
  533. {  hr := FThis.CopyTo(0, GUID_NULL, nil, Dst.FThis);}
  534.   {$ENDIF}
  535.   CheckError('failed copyto operation');
  536. end;
  537.  
  538. procedure TStorage.CheckError(msg : string);
  539. begin
  540.   {$IFDEF WIN32}
  541.   if (hr <> S_OK) then
  542.   begin
  543.     msg := msg + ': ' + SysErrorMessage(hr);
  544.     raise ECDStorageError.Create(msg);
  545.   end;
  546.   {$ELSE}
  547.   if (hr <> S_OK) then
  548.   begin
  549.     msg := msg + ': Error Code $' + IntToHex(GetSCode(hr) xor $80030000, 1);
  550.     raise ECDStorageError.Create(msg);
  551.   end;
  552.   {$ENDIF}
  553.  end;
  554.  
  555. function TStorage.GetCLSID : TCLSID;
  556. var
  557.   StatStg : TStatStg;
  558. begin
  559.   FThis.Stat(StatStg, STATFLAG_NONAME);
  560.   CheckError('fail to get CLSID');
  561.   Result := StatStg.CLSID;
  562. end;
  563.  
  564. function TStorage.GetName : string;
  565. var
  566.   StatStg : TStatStg;
  567. begin
  568.   if FName <> '' then
  569.     Result := FName
  570.   else
  571.     hr := FThis.Stat(StatStg, STATFLAG_DEFAULT);
  572.   CheckError('storage stat failed');
  573.   try
  574.     Result := PWideCharToString(StatStg.pwcsName);
  575.   finally
  576.     CoFreeMem(StatStg.pwcsName);
  577.   end;
  578. end;
  579.  
  580. function TStorage.GetTimes : TStorageTimes;
  581. var
  582.   StatStg : TStatStg;
  583. begin
  584.   FThis.Stat(StatStg, STATFLAG_NONAME);
  585.   CheckError('fail to get CLSID');
  586.   with Result do
  587.   begin
  588.     Creation := StatStg.ctime;
  589.     LastAccess := StatStg.atime;
  590.     LastModify := StatStg.mtime;
  591.   end;
  592. end;
  593.  
  594. procedure TStorage.DeleteElement(const Name : string);
  595. var
  596.   PName : PWideChar;
  597. begin
  598.   PName := StringToPWideChar(Name);
  599.   try
  600.     hr := FThis.DestroyElement(PName);
  601.     CheckError('failed to delete element');
  602.   finally
  603.     FreePWideChar(PName);
  604.   end;
  605. end;
  606.  
  607. procedure TStorage.ListStreams(StreamList : TStrings);
  608. begin
  609.   GetElements(FThis, StreamList, false);
  610. end;
  611.  
  612. procedure TStorage.ListStorages(StorageList : TStrings);
  613. begin
  614.   GetElements(FThis, StorageList, true);
  615. end;
  616.  
  617. procedure TStorage.MoveElement(const srcname, dstname : string; Dst : TStorage);
  618. begin
  619.   CopyMoveElement(srcname, dstname, Dst, STGMOVE_MOVE);
  620. end;
  621.  
  622. procedure TStorage.RenameElement(const OldName, NewName : string);
  623. var
  624.   OldPName : PWideChar;
  625.   NewPName : PWideChar;
  626. begin
  627.   OldPName := StringToPWideChar(OldName);
  628.   try
  629.     NewPName := StringToPWideChar(NewName);
  630.     try
  631.       hr := FThis.RenameElement(OldPName, NewPName);
  632.       CheckError('failed to rename element');
  633.     finally
  634.       FreePWideChar(NewPName);
  635.     end;
  636.   finally
  637.     FreePWideChar(OldPName);
  638.   end;
  639. end;
  640.  
  641. procedure TStorage.Revert;
  642. begin
  643.   hr := FThis.Revert;
  644.   CheckError('storage failed to revert');
  645. end;
  646.  
  647. procedure TStorage.SetCLSID(Value : TCLSID);
  648. begin
  649.   hr := FThis.SetClass(Value);
  650.   CheckError('failed to set CLSID');
  651. end;
  652.  
  653. constructor TRootStorage.Create(Name : string; AccessMode : TAccessMode; ShareMode : TShareMode;
  654.   TransactMode : TTransactMode; CreateNew : boolean);
  655. var
  656.   Mode : longint;
  657.   PName : PWideChar;
  658. begin
  659.   Mode := GetMode(AccessMode, ShareMode, TransactMode, CreateNew);
  660.   if CreateNew then
  661.   begin
  662.     if Name = '' then
  663.     begin
  664.       PName := nil;
  665.       Mode := Mode or STGM_DELETEONRELEASE;
  666.     end
  667.     else
  668.     begin
  669.       PName := StringToPWideChar(Name);
  670.     end;
  671.     try
  672.       hr := StgCreateDocFile(PName, Mode, 0, FThis);
  673.       CheckError('root storage create failed');
  674.     finally
  675.       FreePWideChar(PName);
  676.     end;
  677.     FName := Name;
  678.     FParent := nil;
  679.   end
  680.   else
  681.   begin
  682.     if Name = '' then
  683.     begin
  684.       PName := nil;
  685.       hr := E_FAIL;
  686.     end
  687.     else
  688.     begin
  689.       PName := StringToPWideChar(Name);
  690.       hr := S_OK;
  691.     end;
  692.     CheckError('no storage name given');
  693.     try
  694.       hr := StgIsStorageFile(PName);
  695.       CheckError('not a storage file');
  696.       hr := StgOpenStorage(PName, nil, Mode, nil, 0, FThis);
  697.       CheckError('root storage open failed');
  698.     finally
  699.       FreePWideChar(PName);
  700.     end;
  701.     FName := Name;
  702.     FParent := nil;
  703.   end;
  704. end;
  705.  
  706. constructor TRootStorage.Convert(Name : string; AccessMode : TAccessMode; ShareMode : TShareMode;
  707.   TransactMode : TTransactMode);
  708. var
  709.   Mode : longint;
  710.   PName : PWideChar;
  711. begin
  712.   Mode := GetMode(AccessMode, ShareMode, TransactMode, false);
  713.   if Name = '' then
  714.   begin
  715.     PName := nil;
  716.     hr := E_FAIL;
  717.   end
  718.   else
  719.   begin
  720.     PName := StringToPWideChar(Name);
  721.     hr := S_OK;
  722.   end;
  723.   CheckError('no storage name given');
  724.   try
  725.     hr := StgIsStorageFile(PName);
  726.     if hr = S_OK then CheckError('already a storage file');
  727.     hr := StgCreateDocFile(PName, (Mode or STGM_CONVERT), 0, FThis);
  728.     if Failed(hr) then CheckError('root storage convert failed');
  729.   finally
  730.     FreePWideChar(PName);
  731.   end;
  732.   FName := Name;
  733.   FParent := nil;
  734. end;
  735.  
  736. constructor TStorageStream.Create(Name : string; ParentStorage : TStorage; AccessMode : TAccessMode;
  737.   CreateNew : boolean);
  738. var
  739.   Mode : longint;
  740.   PName : PWideChar;
  741. begin
  742.   Mode := GetMode(AccessMode, smExclusive, tmDirect, CreateNew);
  743.   if CreateNew then
  744.   begin
  745.     if Name = '' then
  746.     begin
  747.       PName := nil;
  748.       Mode := Mode or STGM_DELETEONRELEASE;
  749.     end
  750.     else
  751.       PName := StringToPWideChar(Name);
  752.     try
  753.       hr := ParentStorage.FThis.CreateStream(PName, Mode, 0, 0, FThis);
  754.       CheckError('stream create failed');
  755.     finally
  756.       FreePWideChar(PName);
  757.     end;
  758.     FName := Name;
  759.     FParent := ParentStorage;
  760.   end
  761.   else
  762.   begin
  763.     if Name = '' then
  764.     begin
  765.       PName := nil;
  766.       hr := E_FAIL;
  767.     end
  768.     else
  769.     begin
  770.       PName := StringToPWideChar(Name);
  771.       hr := S_OK;
  772.     end;
  773.     CheckError('no stream name given');
  774.     try
  775.       hr := ParentStorage.FThis.OpenStream(PName, nil, Mode, 0, FThis);
  776.       CheckError('stream open failed');
  777.     finally
  778.       FreePWideChar(PName);
  779.     end;
  780.     FName := Name;
  781.     FParent := ParentStorage;
  782.   end;
  783. end;
  784.  
  785. constructor TStorageStream.CloneFrom(CDStream : TStorageStream);
  786. begin
  787.   hr := CDStream.FThis.Clone(FThis);
  788.   CheckError('stream clone failed');
  789.   FName := CDStream.FName;
  790.   FParent := CDSTream.FParent;
  791. end;
  792.  
  793. destructor TStorageStream.Destroy;
  794. begin
  795.   FName := '';
  796.   FParent := nil;
  797.   {$IFNDEF VER100}
  798.   FThis.Release;
  799.   {$ENDIF}
  800.   FThis := nil;
  801.   inherited Destroy;
  802. end;
  803.  
  804. procedure TStorageStream.CheckError(msg : string);
  805. begin
  806.   if (hr <> S_OK) then
  807.   begin
  808.     {$IFDEF WIN32}
  809.     msg := msg + ': ' + SysErrorMessage(hr);
  810.     {$ENDIF}
  811.     raise ECDStreamError.Create(msg);
  812.   end;
  813. end;
  814.  
  815. function TStorageStream.GetName : string;
  816. var
  817.   StatStg : TStatStg;
  818. begin
  819.   if FName <> '' then
  820.     Result := FName
  821.   else
  822.     hr := FThis.Stat(StatStg, STATFLAG_DEFAULT);
  823.   CheckError('stream stat failed');
  824.   try
  825.     Result := PWideCharToString(StatStg.pwcsName);
  826.   finally
  827.     CoFreeMem(StatStg.pwcsName);
  828.   end;
  829. end;
  830.  
  831. function TStorageStream.Read(var Buffer; Count : longint) : longint;
  832. var
  833.   cn : longint;
  834. begin
  835.   cn := 0;
  836.   {$IFDEF WIN32}
  837.   hr := FThis.Read(@Buffer, Count, @cn);
  838.   {$ELSE}
  839.   hr := FThis.Read(@Buffer, Count, cn);
  840.   {$ENDIF}
  841.   if not Failed(hr) then
  842.     Result := cn
  843.   else
  844.     Result := 0;
  845. end;
  846.  
  847. {$IFDEF WIN32}
  848. function TStorageStream.Seek(Offset : longint; Origin : word) : longint;
  849. var
  850.   ps : LargeInt;
  851. begin
  852.   hr := FThis.Seek(Offset, Origin, ps);
  853.   if not Failed(hr) then
  854.     Result := trunc(ps)
  855.   else
  856.     Result := -1;
  857. end;
  858. {$ELSE}
  859. function TStorageStream.Seek(Offset : longint; Origin : word) : longint;
  860. var
  861.   ps : longint;
  862.   ps2: longint;
  863. begin
  864.   hr := FThis.Seek(Offset, 0, Origin, ps, ps2);
  865.   if not Failed(hr) then
  866.     Result := ps
  867.   else
  868.     Result := -1;
  869. end;
  870. {$ENDIF}
  871. procedure TStorageStream.SetSize(NewSize : longint);
  872. begin
  873.   {$IFDEF WIN32}
  874.   hr := FThis.SetSize(NewSize);
  875.   {$ELSE}
  876.   hr := FThis.SetSize(NewSize, 0);
  877.   {$ENDIF}
  878. end;
  879.  
  880. function TStorageStream.Write(const Buffer; Count : longint) : longint;
  881. var
  882.   cn : longint;
  883. begin
  884.   cn := 0;
  885.   {$IFDEF WIN32}
  886.   hr := FThis.Write(@Buffer, Count, @cn);
  887.   {$ELSE}
  888.   hr := FThis.Write(@Buffer, Count, cn);
  889.   {$ENDIF}
  890.   if not Failed(hr) then
  891.     Result := cn
  892.   else
  893.     Result := 0;
  894. end;
  895.  
  896. function FileIsCompoundDoc(const FileName : string) : boolean;
  897. var
  898.   hr : HResult;
  899.   PName : PWideChar;
  900. begin
  901.   PName := StringToPWideChar(FileName);
  902.   try
  903.     hr := StgIsStorageFile(PName);
  904.     Result := (hr = S_OK);
  905.   finally
  906.     FreePWideChar(PName);
  907.   end;
  908. end;
  909.  
  910. procedure ConvertFileToCompoundDoc(const FileName : string);
  911. var
  912.   old : TRootStorage;
  913. begin
  914.   if FileIsCompoundDoc(FileName) then
  915.     raise ECompDocError.Create('already compound')
  916.   else
  917.   begin
  918.     old := TRootStorage.Convert(FileName, amReadWrite, smExclusive, tmDirect);
  919.     old.Free;
  920.   end;
  921. end;
  922.  
  923. procedure PackCompoundDoc(const FileName : string);
  924. var
  925.   ThisCLSID : TCLSID;
  926.   Storage, StorageTmp : TRootStorage;
  927. begin
  928.   Storage := TRootStorage.Create(FileName, amReadWrite, smExclusive, tmDirect, false);
  929.   ThisCLSID := Storage.ClassID;
  930.   StorageTmp := TRootStorage.Create('', amReadWrite, smExclusive, tmDirect, true);
  931.   Storage.CopyTo(StorageTmp);
  932.   Storage.Free;
  933.   Storage := TRootStorage.Create(FileName, amReadWrite, smExclusive, tmDirect, true);
  934.   Storage.ClassID := ThisCLSID;
  935.   StorageTmp.CopyTo(Storage);
  936.   Storage.Free;
  937.   StorageTmp.Free;
  938. end;
  939.  
  940. procedure SetTimesOfCompoundDoc(const FileName : string; Times : TStorageTimes);
  941. var
  942.   PName : PWideChar;
  943.   hr : HResult;
  944. begin
  945.   PName := StringToPWideChar(FileName);
  946.   try
  947.     hr := StgSetTimes(PName, Times.Creation, Times.LastAccess, Times.LastModify);
  948.     if hr <> S_OK then
  949.       raise ECompDocError.Create('set times failed');
  950.   finally
  951.     FreePWideChar(PName);
  952.   end;
  953. end;
  954.  
  955. var
  956.   OldExitProc : pointer;
  957.  
  958. procedure Finalize; far;
  959. begin
  960.   {$IFNDEF VER100}
  961.   if Assigned(ThisMalloc) then ThisMalloc.Release;
  962.   {$ENDIF}
  963.   ExitProc := OldExitProc;
  964. end;
  965.  
  966. initialization
  967.  
  968.   CoGetMalloc(1, ThisMalloc);
  969.   OldExitProc := ExitProc;
  970.   ExitProc := @Finalize;
  971.  
  972. end.
  973.  
  974.