olestd.pas

是一个delphi的流程制作软件

//--- OleStd Utilities ----------------------------------------------
//
// A set of standard utilites for use with COM, especially OLE.
// Loosely based on the contents of OleStd.h and OleStd.C but
// now containing many other utilities.  In general, these
// utility functions carry out specific jobs for particular
// interfaces (like IStorage).  They also contain the majority
// of functions and procedures that take POleStr strings as
// parameters, these utilities take normal Delphi strings and
// do the necessary translation.
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//------------------------------------------------------------------------------


{$INCLUDE OLE.INC}

unit 
  OleStd;

interface

uses
  Windows, SysUtils, Classes, Graphics, ActiveX, OleConsts;

//--- Standard Ole Function Wrappers -------------------------------------------

//--- Memory functions
// Use Malloc interface to obtain global memory, resize, free, and get size;
// in each case you can use the system memory allocator or substitute
// an IMalloc interface of your own.
function  OleStdMalloc (Size : longword; Malloc : IMalloc = nil) : pointer;
function  OleStdRealloc (Mem : pointer; Size : longword; Malloc : IMalloc = nil) : pointer;
procedure OleStdFree (Mem : pointer; Malloc : IMalloc = nil);
function  OleStdGetSize (Mem : pointer; Malloc : IMalloc = nil) : longword;

//--- Wide string functions
// Get the length of a POleStr
function OleStdWideStrLen (Str: POleStr): integer;
// Copy a POleStr ino another created POleStr
function OleStdCopyString (Source : POleStr; Malloc : IMalloc = nil) : POleStr;
// Copy a pascal string into a a created POleStr
function OleStdCopyPasString (const Source : string;  Malloc : IMalloc = nil) : POleStr;
// Free a POleStr created here
procedure OleStdFreeString (Str : POleStr; Malloc : IMalloc = nil);

// Storage Utilities
// Create and open an IStorage given a filename and flags
function OleStdCreateRootStorage (const Name : string; Mode : integer) : IStorage;
// Create and open a temorary IStorage (system provides filename etc)
function OleStdCreateTempRootStorage (Mode : integer) : IStorage;
// Open an existing storage file
function OleStdOpenRootStorage (const Name : string; Mode : integer) : IStorage;
// Create and open a child storage within an existing IStorage
function OleStdCreateChildStorage (Storage : IStorage; const Name : string; Mode : integer) : IStorage;
// Open an existing child storage within an IStorage
function OleStdOpenChildStorage (Storage : IStorage; const Name : string; Mode : integer) : IStorage;
// Rename an element (Storage or stream) within an IStorage
procedure OleStdRenameElement (Storage : IStorage; const Oldname, Newname : string);
// Obtain a storage enumerator interface
function OleStdGetEnumerator (Storage : IStorage) : IEnumStatStg;
// Delete an element (storage or stream) from an IStorage
procedure OleStdDeleteElement (Storage : IStorage; const Name : string);
// Create and open an IStream within a IStorage
function OleStdCreateStream (Storage : IStorage; const Name : string; Mode : integer) : IStream;
// Open an IStream within a IStorage
function OleStdOpenStream (Storage : IStorage; const Name : string; Mode : integer) : IStream;
// Returns true if the given file or memory interface is an IStorage
function OleStdIsStorage (const Name : string) : boolean; overload;
function OleStdIsStorage (LockBytes : ILockBytes) : boolean; overload;
// Save the root storage from the IRootStorage into the new filename
procedure OleStdSaveRootStorage (RootStorage : IRootStorage; const Name : string);
// Touch time information for a Istorage or filename
procedure OleStdSetTimes (Storage : IStorage; const Name : string; Created, Accessed, Modified : TFileTime); overload;
procedure OleStdSetTimes (const Name : string; Created, Accessed, Modified : TFileTime); overload;
// Read and write Class ID information to a storage
procedure OleStdWriteClass (Storage : IStorage; CLSID : TCLSID);
function OleStdReadClass (Storage : IStorage) : TCLSID;
// Read and write clipboard format information to an IStorage
procedure OleStdWriteFmt (Storage : IStorage; Format : TClipFormat; const UserType : string);
procedure OleStdReadFmt (Storage : IStorage; var Format : TClipFormat; var UserType : string);

//--- CLSID conversions
// convert a CLSID to string
function OleStdCLSIDToString (const CLSID : TCLSID) : string;
// convert a string to a CLSID
function OleStdStringToCLSID (const Str : string) : TCLSID;
// convert a CLSID to a program id
function OleStdCLSIDToProgId (const CLSID : TCLSID) : string;

//--- OleObject and OleLink "Name" Utilities
// Get the full name from an OleObject
function OleStdFullNameStr(const OleObject: IOleObject): string;
// Get the short name from an OleObject
function OleStdShortNameStr(const OleObject: IOleObject): string;
// Get the display name from an OleLink
function OleStdDisplayNameStr (const OleLink: IOleLink): string;
// Create an Object Descriptor structure in global memory and
// return a handle 
function OleStdGetObjectDescriptor (OleObject : IOleObject) : hGlobal;

// Maximum length of an ole storage or stream name
const
  OLE_MAX_NAME = 31;

//--- Stuff to help with TFormatEtc records
// Used by ...Compare... to return result which can be
// an exact match, a partial (and may be useable) match
// and a match not good enough/no match at all.
type
  TCompareFormatEtc = (cfeNone, cfePartial, cfeExact);

// Helper function to fill out a TFormatEtc using one line of code
function SetFormatEtc (Cf : TClipFormat; med: Longint; td: PDVTargetDevice = nil; Asp: Longint = DVASPECT_CONTENT; li: Longint = -1) : TFormatEtc;
// Helper function to copy contents of a TFormatEtc
// NB  FormatEtc2 := FormatEtc1;  does not work - see code to see why this
// function is needed
function OleStdCopyFormatEtc (const Source : TFormatEtc) : TFormatEtc;
// Compare two TFormatEtc records, see above comments for return value
function OleStdCompareFormatEtc (const FormatEtc1, FormatEtc2 : TFormatEtc) : TCompareFormatEtc;

//--- Utilities for target device parameter manipulation
// Create a DC for a given target device
function OleStdCreateDC (ptd : PDVTargetDevice) : hDC;
// Create an IC for a given target device
function OleStdCreateIC (ptd : PDVTargetDevice) : hDC;

// Create a target device
// @@ needed: procedure OleStdCreateTargetDevice();
// Delete the given target device
procedure OleStdDeleteTargetDevice (ptd : PDVTargetDevice);
// Replicate the given target device
function OleStdCopyTargetDevice (Source : PDVTargetDevice) : PDVTargetDevice;
// Compare to see if two target devices are identical
function OleStdCompareTargetDevice (ptd1, ptd2 : PDVTargetDevice) : boolean;

//--- Miscellaneous utilities
// Fill in a TStgMedium record using one line
function SetStgMedium (Stg, Handle : longint; Release : pointer = nil) : TStgMedium;
// Complex but useful!  Change the display aspect (content, icon etc) of the given
// OleObject from on aspect to another; providing a metafile for Icons and proving
// other interfaces as well.  
function OleStdSwitchDisplayAspect (OleObject : IOleObject; var CurrentAspect : DWORD;
  NewAspect : DWORD; MetafilePict : THandle; DeleteOldAspect, SetUpViewAdvise : boolean;
  AdviseSink: IAdviseSink; var MustUpdate : boolean) : HRESULT;
// Shade a given rectangle (used to show an object is open)
procedure OleStdShadeRect (DC: HDC; const Rect: TRect);
// Helper function for Convert process.  Used to convert an object
// held in storage to a new type of object
function OleStdDoConvert (Storage : IStorage; NewCLSID : TCLSID) : HRESULT;
// Obtain from the registry the UserType given a CLSID and registry offset
function OleStdUserTypeOfClass (CLSID : TCLSID; Index : integer) : string;
// Set the host names of the given OleObject
procedure OleStdHostNames (OleObject : IOleObject; Name1, Name2 : string);
// Find the Class that represent the filename
function OleStdClassFile (const Name : string) : TCLSID;
// Convert a Moniker into a string
function OleStdMonikerDisplayName (Moniker : IMoniker) : string;

//======================================================================
implementation

uses
  OleDnD, OleErrors;

//---OleStdMalloc
// Allocate memory using the currently active IMalloc* allocator

const
  AssertMemAllocFailed = 'CoGetMalloc failed';
  AssertSuspectPointer = 'Cannot Free a suspicious pointer';

function OleStdMalloc (Size : longword; Malloc : IMalloc = nil) : pointer;
begin
  if not Assigned (Malloc) then
    Result := CoTaskMemAlloc (Size)
  else
    Result := Malloc.Alloc (Size)
end;

//---OleStdRealloc
// Re-allocate memory using the currently active IMalloc* allocator
function OleStdRealloc (Mem : pointer; Size : longword; Malloc : IMalloc = nil) : pointer;
begin
  if not Assigned (Malloc) then
    Result := CoTaskMemRealloc (Mem, Size)
  else
    Result := Malloc.Realloc (Mem, Size)
end;

//---OleStdFree
// Free memory using the currently active IMalloc* allocator
procedure OleStdFree (Mem : pointer; Malloc : IMalloc = nil);
var
  Ok : integer;
begin
  if not Assigned (Malloc) then
  begin
    Ok := CoGetMalloc (MEMCTX_TASK, Malloc);
    Assert (Ok = NOERROR, AssertMemAllocFailed)
  end;
  Ok := Malloc.DidAlloc (Mem);
  Assert (Ok = S_FALSE, AssertSuspectPointer);
  Malloc.Free (Mem)
end;

//--- OleStdGetSize
// Get the size of a memory block that was allocated using the
// currently active IMalloc* allocator.
function OleStdGetSize (Mem : pointer; Malloc : IMalloc = nil) : longword;
var
  Ok : integer;
begin
  if not Assigned (Malloc) then
  begin
    Ok := CoGetMalloc (MEMCTX_TASK, Malloc);
    Assert (Ok = NOERROR, AssertMemAllocFailed)
  end;
  Result := Malloc.GetSize (Mem)
end;

//--- OleStdFreeString
// Free a string that was allocated with the currently active
// IMalloc* allocator.
procedure OleStdFreeString (Str : POleStr; Malloc : IMalloc = nil);
begin
  OleStdFree (Str, Malloc)
end;

//--- OleStdWideStrLen
// Returns length (in characters) of the given POleStr
function OleStdWideStrLen (Str: POleStr): Integer;
begin
  Result := 0;
  while Str [Result] <> #0 do
    inc (Result)
end;

//--- OleStdCopyString
// Copy a string into memory allocated with the currently active
// IMalloc* allocator.
function OleStdCopyString (Source : POleStr; Malloc : IMalloc = nil) : POleStr;
var
  Size : longword;
begin
  Size := (OleStdWideStrLen (Source)+1) * sizeof (WideChar);
  Result := OleStdMalloc (Size, Malloc);
  if not Assigned (Result) then
    OutOfMemoryError;
  Move (Source, Result, Size)
end;

//--- OleStdCopyString
// Copy a delphi string into memory allocated with the currently active
// IMalloc* allocator.
function OleStdCopyPasString (const Source : string;  Malloc : IMalloc = nil) : POleStr;
var
  Size : integer;
begin
  Size := length (Source);
  if Size = 0 then
    Result := nil
  else begin
    inc (Size);
    Result := OleStdMalloc (Size * SizeOf(WideChar), Malloc);
    if not Assigned (Result) then
      OutOfMemoryError;
    StringToWideChar (Source, Result, Size)
  end
end;

//=== Storage Wrapper Funtions -------------------------------------------------
// These wrapper functions achieve two things:
//  - translation of strings and zero terminated widechars
//  - error checking and raise exception

// Generates an exception if the given name is zero length or greater than
// that recognised by IStorage and IStream
procedure CheckName (const Name : string);
begin
  if not length (Name) in [1..OLE_MAX_NAME] then
    OleError (STG_E_INVALIDNAME, Name)
end;

// filename used for temp files
const
  TempName = 'Temporary file';

//--- OleStdCreateRootStorage
// Creates a new storage object using the OLE-provided compound file
// implementation for the IStorage interface.
function OleStdCreateRootStorage (const Name : string; Mode : integer) : IStorage;
var
  Buffer : POleStr;
begin
  Buffer := OleStdCopyPasString (Name);
  try
    OleCheck (StgCreateDocFile (Buffer, Mode, 0, Result), Name)
  finally
    if Assigned (Buffer) then
      OleStdFreeString (Buffer)
  end
end;

//--- OleStdCreateTempRootStorage
// Creates a tempory file
function OleStdCreateTempRootStorage (Mode : integer) : IStorage;
begin
  OleCheck (StgCreateDocFile (nil, Mode, 0, Result), TempName)
end;

//--- OleStdOpenRootStorage
// Opens an existing root storage object in the file system. You can use this
// function to open directories, files, compound files, and summary catalogs.
function OleStdOpenRootStorage (const Name : string; Mode : integer) : IStorage;
var
  Buffer : POleStr;
begin
  Buffer := OleStdCopyPasString (Name);
  try
    if OleStdIsStorage (Name) or (Mode and STGM_CONVERT <> 0) then
      OleCheck (StgOpenStorage (Buffer, nil, Mode, nil, 0, Result), Name)
    else
      OleError (STG_E_NOTSTORAGEFILE, Name)
  finally
    OleStdFreeString (Buffer)
  end
end;

//--- OleStdCreateChildStorage
// Creates and opens a new storage object nested within this storage object.
function OleStdCreateChildStorage (Storage : IStorage; const Name : string; Mode : integer) : IStorage;
var
  Buffer : POleStr;
begin
  CheckName (Name);
  Buffer := OleStdCopyPasString (Name);
  try
    if Assigned (Storage) then
      OleCheck (Storage.CreateStorage (Buffer, Mode, 0, 0, Result), Name)
    else
     OleError (STG_E_STORAGECANTBENIL)
  finally
    OleStdFreeString (Buffer)
  end
end;

//--- OleStdOpenChildStorage
// Opens an existing storage object with the specified name according to the
// specified access mode.
function OleStdOpenChildStorage (Storage : IStorage; const Name : string; Mode : integer) : IStorage;
var
  Buffer : POleStr;
begin
  CheckName (Name);
  Buffer := OleStdCopyPasString (Name);
  try
    if Assigned (Storage) then
      OleCheck (Storage.OpenStorage (Buffer, nil, Mode, nil, 0, Result), Name)
    else
      OleError (STG_E_STORAGECANTBENIL)
  finally
    OleStdFreeString (Buffer)
  end
end;

//--- OleStdRenameElement
// Change the name of a given named element to another name
procedure OleStdRenameElement (Storage : IStorage; const Oldname, Newname : string);
var
  WOldName,
  WNewName : POleStr;
begin
  CheckName (OldName);
  CheckName (NewName);
  WOldName := OleStdCopyPasString (OldName);
  WNewName := OleStdCopyPasString (NewName);