tdocfile_u1.pas

是一个delphi的流程制作软件

unit TDocFile_U1;

//////////////////////////////////////////
// TDocFile_U1   1.0
//
// Andre v.d. Merwe <[e-mail]>
//
//////////////////////////////////////////


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls,  ActiveX,  ComObj;


const
   MY_STGM_OPEN = STGM_DIRECT or STGM_SHARE_EXCLUSIVE or STGM_READWRITE;
   MY_STGM_CREATE = STGM_DIRECT or STGM_SHARE_EXCLUSIVE or STGM_READWRITE or STGM_CREATE;
   CLSID_NULL : TGUID = '{00000000-0000-0000-0000-000000000000}';


type
   //--------------TDocFileStream------------------------------------------------

   TDocFileStream = class(  TStream  )
     public
      constructor Create(  const Stream : IStream  );
      destructor Destroy; override;

     private
      FStream: IStream;
      FsLastError : string;

      function MyOleCheck(  Hr : HResult  ) : boolean;

     public
         {Seek}
      function Seek(  Offset : Longint;  Origin : Word) : Longint; override;

         {Read data}
      function Read(  var Buffer;  Count : Longint  ) : Longint; override;
      function ReadString : string;

         {Write data}
      function Write(  const Buffer;  Count: Longint) : Longint; override;
      function WriteString(  sStr : string  ) : Longint;

         {Return the name of this stream}
      function GetStreamName : string;

         {Access to the IStream}
      property OleStream : IStream read FStream;
         {Last error}
      property sLastError : string read FsLastError;

     protected
      procedure SetSize(  NewSize : Longint  ); override;
   end;



   //--------------TDocFileStorage-----------------------------------------------

      {Callback for TDocFileStorage.EnumElements}
   EnumElementsCallBack_Func = function(  sElementName : WideString;
                                          dwType : DWORD;
                                          pData : pointer
                                        ) : boolean of object;

   TDocFileStorage = class
     public
      constructor Create(  Storage : IStorage  );
      destructor Destroy; override;

     private
      FStorage : IStorage;
      FsLastError : string;

      function MyOleCheck(  Hr : HResult  ) : boolean;

     public
      property Storage : IStorage read FStorage;
      property sLastError : string read FsLastError;

      function GetStorageName : string;
      function GetStorageCLSID : TCLSID;
      function GetStorageCLSID_string : string;

      function DeleteElement(  sElementName : WideString  ) : boolean;
      function RenameElement(  sOldName,  sNewName : WideString  ) : boolean;
      function CopyTo(  DestStorage : IStorage  ) : boolean;

      function MoveElementTo(  sName : WideString;
                               DestStorage : IStorage;
                               sNewName : WideString;
                               dwFlags : DWORD
                             ) : boolean;

      function OpenStream(  sStreamName : WideString;  dwFlags : DWORD  ) : TDocFileStream;
      function CreateStream(  sStreamName : WideString;  dwFlags : DWORD  ) : TDocFileStream;
      function OpenCreateStream(  sStreamName : WideString;
                                  dwOpenFlags,  dwCreateFlags : DWORD
                                ) : TDocFileStream;

      function OpenStorage(  sStorageName : WideString;  dwFlags : DWORD  ) : TDocFileStorage;
      function CreateStorage(  sStorageName : WideString;  dwFlags : DWORD  ) : TDocFileStorage;
      function OpenCreateStorage(  sStorage : WideString;
                                   dwOpenFlags,  dwCreateFlags : DWORD
                                 ) : TDocFileStorage;

      function EnumElements(  EnumFunc : EnumElementsCallBack_Func;
                              pData : pointer
                            ) : boolean;

      function SetCLSID(  CLSID : TCLSID  ) : boolean;
      function Commit(  dwFlag : DWORD  ) : boolean;
   end;


//--------------Helper Functions--------------------------------------------


function IsADocFile(  sFileName : WideString  ) : boolean;
function OpenDocFile(  sDocFileName : WideString;  dwFlags : DWORD  ) : TDocFileStorage;
function CreateDocFile(  sDocFileName : WideString;  dwFlags : DWORD  ) : TDocFileStorage;
function OpenCreateDocFile(  sDocFileName : WideString;  dwOpenFlags,  dwCreateFlags : DWORD  ) : TDocFileStorage;
function CompressDocFile(  sStorageFileName : WideString  ) : boolean;



implementation

//--------------------------------------------------------------------
//
/////////////////////////Helper Functions////////////////////////////
//
//--------------------------------------------------------------------

function IsADocFile(  sFileName : WideString  ) : boolean;
begin
      {Is this a valid storage file?}
   Result := (StgIsStorageFile(  PWideChar(sFileName)  ) = S_OK);
end;



function OpenDocFile(  sDocFileName : WideString;  dwFlags : DWORD  ) : TDocFileStorage;
var
   Hr : HResult;
   Root : IStorage;
begin
      {Open doc file}
   Hr := StgOpenStorage(  PWideChar(sDocFileName),
                          nil,
                          dwFlags,
                          nil,
                          0,
                          Root
                        );

   if(  not SUCCEEDED(  Hr  )  ) then
   begin
      Result := nil;
      Exit;
   end;

  Result := TDocFileStorage.Create(  Root  );
end;



function CreateDocFile(  sDocFileName : WideString;  dwFlags : DWORD  ) : TDocFileStorage;
var
   Hr : HResult;
   Root : IStorage;
begin
      {Create doc file}
   Hr := StgCreateDocFile(  PWideChar(sDocFileName),
                           dwFlags,
                           0,
                           Root
                         );


      {Created?}
   if(  not SUCCEEDED(  Hr  )  ) then
   begin
      Result := nil;
      Exit;
   end;

   Result := TDocFileStorage.Create(  Root  );
end;



function OpenCreateDocFile(  sDocFileName : WideString;  dwOpenFlags,  dwCreateFlags : DWORD  ) : TDocFileStorage;
var
   MyOleStorage : TDocFileStorage;
begin
      {Try to open}
   MyOleStorage := OpenDocFile(  sDocFileName,  dwOpenFlags  );

      {Was the file opened?}
   if(  MyOleStorage <> nil  ) then
   begin
      Result := MyOleStorage;
      Exit;
   end;

      {File was not opened, so try to create}
   MyOleStorage := CreateDocFile(  sDocFileName,  dwCreateFlags  );


      {Was the stream created?}
   if(  MyOleStorage <> nil  ) then
   begin
      Result := MyOleStorage;
      Exit;
   end;

   Result := nil;
end;



{ Reduces a doc files size.
   NB the file MUST be closed for this to work}
function CompressDocFile(  sStorageFileName : WideString  ) : boolean;

   function GetTempDirFile(   sPre : string  ) : string;
   var
      szFileName,  szPath : array[ 0 .. 500 ] of char;
   begin
         {Get temp path}
      GetTempPath(  499,  szPath  );
         {Get a tempory file name}

      GetTempFileName(   szPath,  PChar(sPre),  0,  szFileName  );
      GetTempDirFile := string(szFileName);
   end;

var
   Hr : HResult;
   CLSID : TCLSID;
   StatStg : TStatStg;
   sTmpFileName : WideString;
   Storage,  StorageTmp : IStorage;
begin
      {Try to open the file}
   Hr := StgOpenStorage(  PWideChar(sStorageFileName),
                          nil,
                          STGM_READWRITE or STGM_SHARE_EXCLUSIVE or
                          STGM_DIRECT,
                          nil,
                          0,
                          Storage
                        );

   if(   not SUCCEEDED(  Hr  )   ) then
   begin
      Result := false;
      Exit;
   end;

      {Get the CLSID}
   Storage.Stat(  StatStg,  0  );
   CLSID := StatStg.clsid;

      {Get a tmp file name in the tempory directory}
   sTmpFileName := GetTempDirFile(  'ole_'  );

      {Create the tempory file}
   Hr := StgCreateDocFile(  PWideChar(sTmpFileName),
                            STGM_CREATE or STGM_SHARE_EXCLUSIVE or
                            STGM_DIRECT or STGM_READWRITE,
                            0,
                            StorageTmp
                          );

   if(   not SUCCEEDED(  Hr  )   ) then
   begin
      Result := false;
      Exit;
   end;

      {Copy everything to tmp file}
   Storage.CopyTo(  0,  nil,  nil,  StorageTmp  );

      {Close old file}
   Storage := nil;

      {Create file, del old one in the process}
   Hr := StgCreateDocFile(  PWideChar(sStorageFileName),
                            STGM_CREATE or STGM_SHARE_EXCLUSIVE or
                            STGM_DIRECT or STGM_READWRITE,
                            0,
                            Storage
                          );

   if(   not SUCCEEDED(  Hr  )   ) then
   begin
      DeleteFile(  sTmpFileName  );
      Result := false;
      Exit;
   end;

     {Set the CLSID}
   Storage.SetClass(  CLSID  );

     {Copy everything back from tmp file}
   StorageTmp.CopyTo(  0,  nil,  nil,  Storage  );

   Storage := nil;
   StorageTmp := nil;

      {Delete tmp file}
   DeleteFile(  sTmpFileName  );

   Result := true;
end;




//--------------------------------------------------------------------
//
///////////////////////////TDocFileStream//////////////////////////////
//
//--------------------------------------------------------------------


constructor TDocFileStream.Create(  const Stream : IStream  );
begin
   inherited Create;

   FStream := Stream;

   if(  FStream = nil  ) then
      FsLastError := 'Stream is nil!'
   else
      FsLastError := '';
end;



destructor TDocFileStream.Destroy;
begin
   FStream := nil;

   inherited Destroy;
end;



function TDocFileStream.MyOleCheck(  Hr : HResult  ) : boolean;
var
   bOk : boolean;
   sErrorMsg : string;
begin
   bOk := SUCCEEDED(  Hr  );

   if(  not bOk  ) then
   begin
         {Get the error string}
      sErrorMsg := SysErrorMessage(  Hr  );

         {Save the error message}
      FsLastError := sErrorMsg;
      bOk := false;
   end;

   Result := bOk;
end;




function TDocFileStream.Seek(  Offset : Longint;  Origin : Word  ) : Longint;
var
   Pos : Largeint;
begin
   if(  FStream = nil  ) then
   begin
      FsLastError := 'Stream is nil';
      Result := -1;
      Exit;
   end;

   FsLastError := '';

      {Seek to given pos}
   if(   not MyOleCheck(   FStream.Seek(  Offset,  Origin,  Pos  )   )   ) then
   begin
         {Seek failed}
      Result := -1;
      Exit;
   end;

   Result :=  Pos ;
end;



function TDocFileStream.Read(  var Buffer;  Count : Longint) : Longint;
begin
   if(  FStream = nil  ) then
   begin
      FsLastError := 'Stream is nil';
      Exit;
   end;

   FsLastError := '';

      {Read the data}
   if(   not MyOleCheck(   FStream.Read(  @Buffer,  Count,  @Result  )   )   ) then
   begin
         {Read failed}
      Result := -1;
   end;
end;



function TDocFileStream.ReadString : string;
var
   sz : PChar;
   Count : integer;
begin
   if(  FStream = nil  ) then
   begin
      FsLastError := 'Stream is nil';
      Exit;
   end;

   FsLastError := '';

      {Size of data to retrieve}
   Count := Size - Position;

      {If there is any data to read}
   if(  Count > 0  ) then
   begin
         {Allocate memory for the string and a NULL char}
      sz := StrAlloc(  Count + 1  );

         {Attemt to read the data,  if failed (-1)}
      if(   Read(  sz[ 0 ],  Count  ) = -1   ) then
      begin
            {Read failed}
         StrDispose(  sz  );
         Result := '';
         Exit;
      end;

         {Null terminate}
      sz[ Count ] := #0;

      Result := sz;

         {Done with the mem}
      StrDispose(  sz  );
   end
   else
      Result := '';
end;



function TDocFileStream.Write(  const Buffer;  Count : Longint  ) : Longint;
begin
   if(  FStream = nil  ) then
   begin
      FsLastError := 'Stream is nil';
      Exit;
   end;

   FsLastError := '';

   if(   not MyOleCheck(   FStream.Write(  @Buffer,  Count,  @Result  )   )   ) then
      Result := -1;
end;



function TDocFileStream.WriteString(  sStr : string  ) : Longint;
begin
   if(  FStream = nil  ) then
   begin
      FsLastError := 'Stream is nil';
      Result := -1;
      Exit;
   end;

   FsLastError := '';

      {Write a string}
   Result := Write(   PChar(sStr)[ 0 ],  Length(  sStr  )   );
end;



procedure TDocFileStream.SetSize(  NewSize : Longint  );
begin
   if(  FStream = nil  ) then
   begin
      FsLastError := 'Stream is nil';
      Exit;
   end;

   FsLastError := '';

      {Set the size}
   if(   not MyOleCheck(   FStream.SetSize(  NewSize  )   )   ) then
      Exit;

      {Position cant be greater than the size}
   if(  Position > Size  ) then
      Position := Size;
end;



function TDocFileStream.GetStreamName : string;
var
   StatStg : TSTATSTG;
begin
   if(  FStream = nil  ) then
   begin
      FsLastError := 'Stream is nil';
      Exit;
   end;

   FsLastError := '';

      {Return the name of this stream}
   FStream.Stat(  StatStg,  0  );
   Result := StatStg.pwcsName;
end;





//--------------------------------------------------------------------
//