olestd.pas

是一个delphi的流程制作软件

// (OleStdFree can be used to free the copy).
function OleStdCopyTargetDevice (Source : PDVTargetDevice) : PDVTargetDevice;
begin
  if not Assigned (Source) then
    Result := nil
  else begin
    Result := OleStdMalloc (Source.tdSize);
    if Assigned (Result) then
      Move (Source, Result, Source.tdSize)
  end
end;

//--- OleStdCopyFormatEtc
// Copies the contents of a FORMATETC structure. this function takes
// special care to copy correctly copying the pointer to the TARGETDEVICE
// contained within the source FORMATETC structure.
// if the source FORMATETC has a non-Nil TARGETDEVICE, then a copy
// of the TARGETDEVICE will be allocated for the destination of the
// FORMATETC (Result).
//
// NOTE: the caller MUST free the allocated copy of the TARGETDEVICE
// within the destination FORMATETC when done with it
// using the standard allocator returned from CoGetMalloc.
// (OleStdFree can be used to free the copy).
function OleStdCopyFormatEtc (const Source : TFormatEtc) : TFormatEtc;
begin
  Result := Source;
  Result.ptd := OleStdCopyTargetDevice (Source.ptd)
end;

//--- OleStdCompareTargetDevice
// Compares two target device records
function OleStdCompareTargetDevice (ptd1, ptd2 : PDVTargetDevice) : boolean;
begin
// same address; must be same (handles nil, nil case)
// one nil only, different sizes, bytes not equal
  Result := (ptd1 = ptd2) or
    (Assigned (ptd1) and Assigned (ptd2) and
    (ptd1.tdSize = ptd2.tdSize) and
    CompareMem (ptd1, ptd2, ptd1.tdSize))
end;

//--- OleStdCompareFormatEtc
// Compares two TFormatEtc records 
function OleStdCompareFormatEtc (const FormatEtc1, FormatEtc2 : TFormatEtc) : TCompareFormatEtc;
begin
// are Format the the same
  if (FormatEtc1.cfFormat <> FormatEtc2.cfFormat) or
     (FormatEtc1.lindex <> FormatEtc2.lIndex) or
// are Target Device same
     (not OleStdCompareTargetDevice (FormatEtc1.ptd, FormatEtc2.ptd)) or
// is Aspect1 a subset or equal to Aspect2
     (integer(FormatEtc2.dwAspect) and not integer(FormatEtc1.dwAspect) <> 0) or
// is tymed1 a subset or equal to tymed2
     (integer(FormatEtc2.tymed) and not integer(FormatEtc1.tymed) <> 0) then
        Result := cfeNone
  else
// is the match exact
    if (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and
       (FormatEtc1.tymed = FormatEtc2.tymed) then
      Result := cfeExact
    else
      Result := cfePartial
end;

//--- SetStgMedium
// Fill in a StgMedium record using one line of code
function SetStgMedium (Stg, Handle : longint; Release : pointer = nil) : TStgMedium;
begin
  Result.tymed := Stg;
  Result.hGlobal := Handle;
  Result.unkForRelease := Release
end;

//-- OleStdSwitchDisplayAspect
// Switch the currently cached display aspect between DVASPECT_ICON
// and DVASPECT_CONTENT.
// NOTE: when setting up icon aspect, any currently cached content
// cache is discarded and any advise connections for content aspect
// are broken.
//
// RETURNS:
//   S_OK -- new display aspect setup successfully
//   E_INVALIDARG -- IOleCache interface is NOT supported (this is required).
//   <other SCODE> -- any SCODE that can be returned by IOleCache::Cache method.
//   NOTE: if an error occurs then the current display aspect and cache contents unchanged.
function OleStdSwitchDisplayAspect (OleObject : IOleObject; var CurrentAspect : DWORD;
  NewAspect : DWORD; MetafilePict : THandle; DeleteOldAspect, SetUpViewAdvise : boolean;
  AdviseSink: IAdviseSink; var MustUpdate : boolean) : HRESULT;
var
  OleCache : IOleCache;
  ViewObject : IViewObject;
  EnumStatData : IEnumStatData;
  StatData : TStatData;
  FormatEtc : TFormatEtc;
  Medium : TStgMedium;
  Advf,
  NewConnection,
  OldAspect : longint;
  Error : HRESULT;
begin
  OleCache := nil;
  ViewObject := nil;
  EnumStatData := nil;
  OldAspect := CurrentAspect;
  MustUpdate := false;

  if Failed (OleObject.QueryInterface (IOleCache, OleCache)) then
  begin
// if IOleCache is NOT available, do nothing
    Result := E_INVALIDARG;
    exit
  end;

// Setup new cache with the new aspect
   FormatEtc := SetFormatEtc (cfNull, tsNull, nil, NewAspect);

// NOTE: if we are setting up Icon aspect with a custom icon then we do not want
// DataAdvise notifications to ever change the contents of the data cache. thus
// we set up a NODATA advise connection. otherwise we set up a standard DataAdvise
// connection.
  if (NewAspect = dvaIcon) and (MetafilePict <> 0) then
    Advf := advf_nodata
  else
    Advf := ADVF_PRIMEFIRST;
  Result := OleCache.Cache (FormatEtc, Advf, NewConnection);
  if Failed (Result) then
    exit;
  CurrentAspect := NewAspect;

// NOTE: if we are setting up Icon aspect with a custom icon, then stuff the icon
// into the cache. otherwise the cache must be forced to be updated. set the
// MustUpdate flag to tell caller to force the object to Run so that the cache
// will be updated.
  if (NewAspect = dvaIcon) and (MetafilePict <> 0) then
  begin
    FormatEtc := SetFormatEtc (cfMetafilePict, tsMetafilePict, nil, dvaIcon);
    Medium := SetStgMedium (tsMetafilePict, MetafilePict);
    OleCache.SetData (FormatEtc, Medium, false)
  end else
    MustUpdate := true;

// re-establish the ViewAdvise connection
   if SetUpViewAdvise and Assigned (AdviseSink) then
     if Succeeded (OleObject.QueryInterface (IViewObject, ViewObject)) then
     begin
       ViewObject.SetAdvise (NewAspect, 0, AdviseSink);
       ViewObject := nil
     end;

// Remove any existing caches that are set up for the old display aspect. It WOULD
// be possible to retain the caches set up for the old aspect, but this would
// increase the storage space required for the object and possibly require additional
// overhead to maintain the unused caches. For these reasons the strategy to
// delete the previous caches is prefered. If it is a requirement to quickly
// switch between Icon and Content display, then it would be better to keep both
// aspect caches.
  if DeleteOldAspect then
  begin
    Error := OleCache.EnumCache (EnumStatData);
    while Error = ddOk do
    begin
      Error := EnumStatData.Next (1, StatData, nil);
      if Error = ddOk then
// Remove previous cache with old aspect
        if StatData.FormatEtc.dwAspect = OldAspect then
          OleCache.Uncache (StatData.dwConnection)
    end
  end;
  Result := ddOk
end;

//--- OleStdShadeRect
// Shade a rectangle
procedure OleStdShadeRect (DC: HDC; const Rect: TRect);
const
  HatchBits: array[0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);
var
  Bitmap: HBitmap;
  SaveBrush: HBrush;
  SaveTextColor, SaveBkColor: TColorRef;
begin
  Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);
  SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));
  SaveTextColor := SetTextColor(DC, clWhite);
  SaveBkColor := SetBkColor(DC, clBlack);
  with Rect do PatBlt(DC, Left, Top, Right - Left, Bottom - Top, $00A000C9);
  SetBkColor(DC, SaveBkColor);
  SetTextColor(DC, SaveTextColor);
  DeleteObject(SelectObject(DC, SaveBrush));
  DeleteObject(Bitmap);
end;

//--- OleStdGetObjectDescriptor
// Fill in a Object Descriptor record, place it in gloabl
// memory and return a handle to it
function OleStdGetObjectDescriptor (OleObject : IOleObject) : hGlobal;
var
  Descriptor: TObjectDescriptor;
  OleLink: IOleLink;
begin
  ZeroMemory (@Descriptor, SizeOf (Descriptor));
  with Descriptor do
  begin
    FullUserTypeName := OleStdFullNameStr (OleObject);
    OleObject.QueryInterface(IOleLink, OleLink);
    if Assigned (OleLink) then
    begin
      FullUserTypeName := 'Linked ' + FullUserTypeName;
      SrcOfCopy := OleStdDisplayNameStr (OleLink)
    end else
      SrcOfCopy := FullUserTypeName;
    OleObject.GetUserClassID (CLSID);
    DrawAspect := dvaContent;
    OleObject.GetMiscStatus (dvaContent, Status);

    Result := XlatObjectDescriptor (Descriptor)
  end
end;

//--- OleStdUserTypeOfClass
// Returns the user type (human readable class name) of the
// specified class as stored in the registry.
function OleStdUserTypeOfClass (CLSID : TCLSID; Index : integer) : string;
var
  Key,
  CLSIDStr : string;
  Size : integer;
begin
  Result := '';
  CLSIDStr := OleStdCLSIDToString (CLSID);
  if Index = 0 then
    Key := Format ('CLSID\%s', [CLSIDStr])
  else
    Key := Format ('CLSID\%s\AuxUserType\%d', [CLSIDStr, Index]);
  Size := 256;
  SetLength (Result, Size);
  if RegQueryValue (HKEY_CLASSES_ROOT, PChar(Key), PChar (Result), Size) <> ERROR_SUCCESS then
  begin
    Result := 'Unknown';
    if CoIsOle1Class (CLSID) then
    begin
//Try to get ProgID value for an OLE 1 class
      Key := OleStdCLSIDToProgID (CLSID);
      RegQueryValue (HKEY_CLASSES_ROOT, PChar(Key), PChar(Result), Size)
    end
  end;

  SetLength(Result, StrLen (PChar(Result)))
end;

//--- OleStdDoConvert
// Convert an embedded or linked object to another type, working in conjunection
// with OleUIConvert dialog.
function OleStdDoConvert (Storage : IStorage; NewCLSID : TCLSID) : HRESULT;
var
  Original : TCLSID;
  Format : TClipFormat;
  NewType,
  UserType : string;
begin
  Result := E_FAIL;
  if Succeeded (ReadClassStg (Storage, Original)) then
  begin
    OleStdReadFmt (Storage, Format, UserType);
    NewType := OleStdUserTypeOfClass (NewCLSID, 0);
    if Succeeded (WriteClassStg (Storage, NewCLSID)) then
    begin
      OleStdWriteFmt (Storage, Format, NewType);
      SetConvertStg (Storage, true);
      Result := NOERROR;
      exit
    end;
// Failed to write new type, restore the old class
    WriteClassStg (Storage, Original)
  end
end;

//--- OleStdHostNames
/// Stuff two host names into an OleObject
procedure OleStdHostNames (OleObject : IOleObject; Name1, Name2 : string);
var
  Buffer1,
  Buffer2 : POleStr;
begin
  if Assigned (OleObject) then
  begin
    Buffer1 := OleStdCopyPasString (Name1);
    Buffer2 := OleStdCopyPasString (Name2);
    try
      OleCheck (OleObject.SetHostNames (Buffer1, Buffer2))
    finally
      OleStdFreeString (Buffer1);
      OleStdFreeString (Buffer2)
    end
  end
end;

//--- OleStdShortName
// Obtain a short name from an object
function OleStdShortNameStr (const OleObject: IOleObject): string;
var
  P: PWideChar;
begin
  if Assigned (OleObject) then
  begin
    OleObject.GetUserType(USERCLASSTYPE_SHORT, P);
    Result := P;
    CoTaskMemFree(P)
  end else
    Result := ''
end;

//--- OleStdDisplayNameStr
// Obtain a display name from a link
function OleStdDisplayNameStr(const OleLink: IOleLink): string;
var
  P: PWideChar;
begin
  if Assigned (OleLink) then
  begin
    OleLink.GetSourceDisplayName(P);
    Result := P;
    CoTaskMemFree(P)
  end else
    Result := ''
end;

//--- OleStdFullNameStr
// Obtain the full name from an Object
function OleStdFullNameStr(const OleObject: IOleObject): string;
var
  P: PWideChar;
begin
  if Assigned (OleObject) then
  begin
    OleObject.GetUserType(USERCLASSTYPE_FULL, P);
    Result := P;
    CoTaskMemFree(P)
  end else
    Result := ''
end;

//--- OleStdClassFile
// Obtain the clsid for a file
function OleStdClassFile (const Name : string) : TCLSID;
var
  Buffer : POleStr;
begin
  Result := CLSID_NULL;
  Buffer := OleStdCopyPasString (Name);
  try
    OleCheck (GetClassFile (Buffer, Result), Name)
  finally
    if Assigned (Buffer) then
      OleStdFreeString (Buffer)
  end
end;

//--- OleStdMonikerDisplayName
// Obtain a display name from a moniker
function OleStdMonikerDisplayName (Moniker : IMoniker) : string;
var
  BindCtx : IBindCtx;
  P : PWideChar;
begin
  if Assigned (Moniker) then
  begin
    OleCheck (CreateBindCtx (0, BindCtx));
    OleCheck (Moniker.GetDisplayName (BindCtx, nil, P));
    Result := P;
    CoTaskMemFree (P)
  end else
    Result := ''
end;

end.