olelinks.pas

是一个delphi的流程制作软件

//--- Ole Interface Conversions ------------------------------------------------
//
// Standard fucntionality for a IOleUILinkContainer interface
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//------------------------------------------------------------------------------

{$INCLUDE OLE.INC}

unit OleLinks;

interface

uses
  Windows, SysUtils, ActiveX, OleDlg,
  OleStd, OleConsts, OleInterface;

// This provides standard functionality for an IOleUILinkContainer interface. It
// is descended from a TBaseOleLinkContainer (in OleInterface.pas) which
// translates the C styled names in Delphi styles.  It does not provide
// functionality for the GetNextLink procedure and OpenLinkSource procedure
// because only the user of this helper class knows how to do this. They are both
// provided with overrides which do nothing. The LinkId parameter must be a
// IOleLink interface.

type
  TStdOleLinkContainer = class (TBaseOleLinkContainer)
  private
    function ValidateLinkSource (DisplayName : string; var Eaten : integer; var Moniker : IMoniker; var CLSID : TCLSID) : boolean;
    function CreateNewSourceMoniker (DisplayName : string; NameLen : integer; Moniker : IMoniker) : boolean;
    function FilePrefixLen (Moniker : IMoniker) : integer;
  protected
    procedure GetNextLink (LinkId: integer; var Result : integer); override;
    procedure SetLinkUpdateOptions (LinkId, UpdateOpt : integer; var Result : integer); override;
    procedure GetLinkUpdateOptions (LinkId: integer; var UpdateOpt, Result : integer); override;
    procedure SetLinkSource (LinkId: integer; DisplayName: string; var NameLen : integer; var Eaten: integer; ValidateSource: boolean; var Result : integer); override;
    procedure GetLinkSource (LinkId: integer; var DisplayName, FullLinkType, ShortLinkType : string; var Filename : integer; var SourceAvailable, IsSelected : boolean; var Result : integer); override;
    procedure OpenLinkSource (LinkId: integer; var Result : integer); override;
    procedure UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer); override;
    procedure CancelLink (LinkId: integer; var Result : integer); override;
  end;

  TStdOleLinkInfo = class (TStdOleLinkContainer, IOleUILinkInfo)
    function GetLastUpdate(dwLink: Longint; var LastUpdate: TFileTime): HResult; overload; stdcall;
  protected
//    procedure GetNextLink (LinkId: integer; var Result : integer); override;
    procedure SetLinkUpdateOptions (LinkId, UpdateOpt : integer; var Result : integer); override;
    procedure GetLinkUpdateOptions (LinkId: integer; var UpdateOpt, Result : integer); override;
    procedure SetLinkSource (LinkId: integer; DisplayName: string; var NameLen : integer; var Eaten: integer; ValidateSource: boolean; var Result : integer); override;
    procedure GetLinkSource (LinkId: integer; var DisplayName, FullLinkType, ShortLinkType : string; var Filename : integer; var SourceAvailable, IsSelected : boolean; var Result : integer); override;
//    procedure OpenLinkSource (LinkId: integer; var Result : integer); override;
    procedure UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer); override;
    procedure CancelLink (LinkId: integer; var Result : integer); override;
    procedure GetLastUpdate (LinkId : integer; var LastUpdate: TFileTime; var Result : integer); overload; virtual;
  end;

implementation

const
  MaxNameLen =260;

procedure TStdOleLinkContainer.GetNextLink (LinkId: integer; var Result : integer);
begin
  Result := 0
end;

function TStdOleLinkContainer.ValidateLinkSource (DisplayName : string; var Eaten : integer; var Moniker : IMoniker; var CLSID : TCLSID) : boolean;
var
  BindCtx : IBindCtx;
  Name : POleStr;
  OleObject : IOleObject;
begin
  Result := false;
  Moniker := nil;
  CLSID := CLSID_NULL;
  if Succeeded (CreateBindCtx (0, BindCtx)) then
  begin
    Name := OleStdCopyPasString (DisplayName);
    try
// obtain a moniker for this source, bind to that source an get its clsid
      Result := Succeeded (MkParseDisplayName (BindCtx, Name, Eaten, Moniker)) and
        Succeeded (Moniker.BindToObject (BindCtx, nil, IOleObject, OleObject)) and
        Succeeded (OleObject.GetUserClassId (CLSID))
    finally
      OleStdFreeString (Name)
    end
  end
end;

function TStdOleLinkContainer.CreateNewSourceMoniker (DisplayName : string; NameLen : integer; Moniker : IMoniker) : boolean;
var
  Name : POleStr;
  ItemMoniker,
  FileMoniker : IMoniker;
begin
  Result := false;
  Moniker := nil;
  Name := OleStdCopyPasString (copy (DisplayName, 1, NameLen));
  try
    CreateFileMoniker (Name, FileMoniker);
  finally
    OleStdFreeString(Name)
  end;
  if not Assigned (FileMoniker) then
    exit;
  if length (DisplayName) > NameLen then
  begin
    Name := OleStdCopyPasString (copy (DisplayName, NameLen+1, MaxNameLen));
    try
      CreateItemMoniker ('!', Name, ItemMoniker)
    finally
      OleStdFreeString(Name)
    end;
    if Assigned (ItemMoniker) then
      CreateGenericComposite (FileMoniker, ItemMoniker, Moniker);
    if not Assigned (Moniker) then
      exit
  end else
    Moniker := FileMoniker;

  Result := true
end;

// Returns the length of a file moniker given that Moniker is either a file
// moniker or a composite moniker containing a file moniker as the first item.
function TStdOleLinkContainer.FilePrefixLen (Moniker : IMoniker) : integer;
var
  MkSys : integer;
  First : IMoniker;
  Enum : IEnumMoniker;
  BindCtx : IBindCtx;
  OleStr : POleStr;
begin
  Result := 0;
  if Assigned (Moniker) then
  begin
    if Failed (Moniker.IsSystemMoniker (MkSys)) or
      (MkSys <> MKSYS_GENERICCOMPOSITE) then
      First := Moniker
    else
      if Succeeded (Moniker.Enum (true, Enum)) then
        Enum.Next (1, First, nil)
      else
        exit;

    if Assigned (First) and
      Succeeded (First.IsSystemMoniker (MkSys)) and
      (MkSys = MKSYS_FILEMONIKER) and
      Succeeded (CreateBindCtx (0, BindCtx)) and
      Succeeded (First.GetDisplayName (BindCtx, nil, OleStr)) then
    begin
      Result := OleStdWideStrLen (OleStr);
      CoTaskMemFree (OleStr)
    end
  end
end;

procedure TStdOleLinkContainer.SetLinkUpdateOptions (LinkId, UpdateOpt: integer; var Result : integer);
var
  OleLink : IOleLink;
begin
  OleLink := IOleLink (LinkId);
  if Assigned (OleLink) then
    Result := OleLink.SetUpdateOptions (UpdateOpt)
  else
    Result := integer (E_FAIL)
end;

procedure TStdOleLinkContainer.GetLinkUpdateOptions (LinkId: integer; var UpdateOpt, Result : integer);
var
  OleLink : IOleLink;
begin
  OleLink := IOleLink (LinkId);
  if Assigned (OleLink) then
    Result := OleLink.GetUpdateOptions (UpdateOpt)
  else
    Result := integer (E_FAIL)
end;

procedure TStdOleLinkContainer.SetLinkSource (LinkId: integer; DisplayName: string; var NameLen : integer; var Eaten: integer; ValidateSource: boolean; var Result : integer);
var
  Moniker : IMoniker;
  Available : boolean;
  CLSID : TCLSID;
  Name : POleStr;
  OleLink : IOleLink;
begin
  Result := integer (E_FAIL);
  OleLink := IOleLink (LinkId);

  Available := false;
  if ValidateSource then
  begin
    if not ValidateLinkSource (DisplayName, Eaten, Moniker, CLSID) then
      exit;
    Available := not IsEqualCLSID (CLSID, CLSID_NULL)
  end else
    if not CreateNewSourceMoniker (DisplayName, NameLen, Moniker) then
      exit;

  if not Assigned (OleLink) then
    exit;

  if Assigned (Moniker) then
    Result := OleLink.SetSourceMoniker (Moniker, CLSID)
  else begin
    Name := OleStdCopyPasString (DisplayName);
    try
      Result := OleLink.SetSourceDisplayName(Name)
    finally
      OleStdFreeString (Name)
    end
  end;

  if Succeeded (Result) then
    if Available then
      Result := S_OK
    else
      Result := S_FALSE
end;

procedure TStdOleLinkContainer.GetLinkSource (LinkId: integer; var DisplayName, FullLinkType, ShortLinkType : string; var Filename : integer; var SourceAvailable, IsSelected : boolean; var Result : integer);
var
  OleLink : IOleLink;
  Moniker: IMoniker;
  OleObject : IOleObject;
  OleStr : POleStr;
begin
  Result := integer (E_FAIL);
  OleLink := IOleLink (LinkId);
  if not Assigned (OleLink) then
    exit;

  if Succeeded (OleLink.GetSourceMoniker (Moniker)) then
  begin
    if Succeeded (OleLink.QueryInterface (IOleObject, OleObject)) then
    begin
      OleObject.GetUserType (USERCLASSTYPE_FULL, OleStr);
      FullLinkType := OleStr;
      CoTaskMemFree (OleStr);
      OleObject.GetUserType (USERCLASSTYPE_SHORT, OleStr);
      ShortLinkType := OleStr;
      CoTaskMemFree (OleStr)
    end;
    Filename := FilePrefixLen (Moniker)
  end;
  Result := OleLink.GetSourceDisplayName (OleStr);
  DisplayName := OleStr;
  CoTaskMemFree (OleStr)
end;

procedure TStdOleLinkContainer.OpenLinkSource (LinkId: integer; var Result : integer);
begin
  Result := S_OK
end;

procedure TStdOleLinkContainer.UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer);
var
  OleLink : IOleLink;
  OleObject : IOleObject;
begin
  Result := integer (E_FAIL);
  OleLink := IOleLink (LinkId);
  if not Assigned (OleLink) then
    exit;

  Result := OleLink.QueryInterface (IOleObject, OleObject);
  if Succeeded (Result) then
  begin
    try
      Result := OleObject.IsUpToDate;
      if Result <> S_OK then
        Result := OleObject.Update
    except
      Result := integer (MK_E_UNAVAILABLE)
    end
  end
end;

procedure TStdOleLinkContainer.CancelLink (LinkId: integer; var Result : integer);
var
  OleLink : IOleLink;
begin
  OleLink := IOleLink (LinkId);
  if Assigned (OleLink) then
    OleLink.SetSourceMoniker (nil, CLSID_NULL);

  Result := S_OK
end;

procedure TStdOleLinkInfo.SetLinkUpdateOptions (LinkId, UpdateOpt : integer; var Result : integer);
var
  Link : integer;
begin
  GetNextLink (0, Link);
  inherited SetLinkUpdateOptions (Link, UpdateOpt, Result)
end;

procedure TStdOleLinkInfo.GetLinkUpdateOptions (LinkId: integer; var UpdateOpt, Result : integer);
var
  Link : integer;
begin
  GetNextLink (0, Link);
  inherited GetLinkUpdateOptions (Link, UpdateOpt, Result)
end;

procedure TStdOleLinkInfo.SetLinkSource (LinkId: integer; DisplayName: string; var NameLen : integer; var Eaten: integer; ValidateSource: boolean; var Result : integer);
var
  Link : integer;
begin
  GetNextLink (0, Link);
  inherited SetLinkSource (Link, DisplayName, NameLen, Eaten, ValidateSource, Result)
end;

procedure TStdOleLinkInfo.GetLinkSource (LinkId: integer; var DisplayName, FullLinkType, ShortLinkType : string; var Filename : integer; var SourceAvailable, IsSelected : boolean; var Result : integer);
var
  Link : integer;
begin
  GetNextLink (0, Link);
  inherited GetLinkSource (Link, DisplayName, FullLinkType, ShortLinkType, Filename, SourceAvailable, IsSelected, Result)
end;

procedure TStdOleLinkInfo.UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer);
var
  Link : integer;
begin
  GetNextLink (0, Link);
  inherited UpdateLink (Link, ErrorMessage, ErrorAction, Result);
end;

procedure TStdOleLinkInfo.CancelLink (LinkId: integer; var Result : integer);
var
  Link : integer;
begin
  GetNextLink (0, Link);
  inherited CancelLink (Link, Result)
end;

function TStdOleLinkInfo.GetLastUpdate (dwLink: Longint; var LastUpdate: TFileTime): HResult;
begin
  Result := E_NOTIMPL;
  GetLastUpdate (dwLink, LastUpdate, integer (Result))
end;

procedure TStdOleLinkInfo.GetLastUpdate (LinkId : integer; var LastUpdate: TFileTime; var Result : integer);
begin
  Result := S_OK
end;

end.