olectnrs.pas

这是不可多得的源代码

{ Return the first piece of a moniker }

function OleStdGetFirstMoniker(const Moniker: IMoniker): IMoniker;
var
  Mksys: Longint;
  EnumMoniker: IEnumMoniker;
begin
  Result := nil;
  if Moniker <> nil then
  begin
    if (Moniker.IsSystemMoniker(Mksys) = 0) and
      (Mksys = MKSYS_GENERICCOMPOSITE) then
    begin
      if Moniker.Enum(True, EnumMoniker) <> 0 then Exit;
      EnumMoniker.Next(1, Result, nil);
    end
    else
      Result := Moniker;
  end;
end;

{ Return length of file moniker piece of the given moniker }

function OleStdGetLenFilePrefixOfMoniker(const Moniker: IMoniker): Integer;
var
  MkFirst: IMoniker;
  BindCtx: IBindCtx;
  Mksys: Longint;
  P: PWideChar;
begin
  Result := 0;
  if Moniker <> nil then
  begin
    MkFirst := OleStdGetFirstMoniker(Moniker);
    if (MkFirst <> nil) and
      (MkFirst.IsSystemMoniker(Mksys) = 0) and
      (Mksys = MKSYS_FILEMONIKER) and
      (CreateBindCtx(0, BindCtx) = 0) and
      (MkFirst.GetDisplayName(BindCtx, nil, P) = 0) and (P <> nil) then
    begin
      Result := WStrLen(P);
      CoTaskMemFree(P);
    end;
  end;
end;

function CoAllocCStr(const S: string): PChar;
begin
  Result := StrCopy(CoTaskMemAlloc(Length(S) + 1), PChar(S));
end;

function GetFullNameStr(const OleObject: IOleObject): string;
var
  P: PWideChar;
begin
  OleObject.GetUserType(USERCLASSTYPE_FULL, P);
  Result := P;
  CoTaskMemFree(P);
end;

function GetShortNameStr(const OleObject: IOleObject): string;
var
  P: PWideChar;
begin
  OleObject.GetUserType(USERCLASSTYPE_SHORT, P);
  Result := P;
  CoTaskMemFree(P);
end;

function GetDisplayNameStr(const OleLink: IOleLink): string;
var
  P: PWideChar;
begin
  OleLink.GetSourceDisplayName(P);
  Result := P;
  CoTaskMemFree(P);
end;

function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;
begin
  if Form.OleFormObject = nil then TOleForm.Create(Form);
  Result := Form.OleFormObject as IVCLFrameForm;
end;

function IsFormMDIChild(Form: TCustomForm): Boolean;
begin
  Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild);
end;

{ TOleUILinkInfo - helper interface for Object Properties dialog }

type
  TOleUILinkInfo = class(TInterfacedObject, IOleUILinkInfo)
  private
    FContainer: TOleContainer;
    FOleLink: IOleLink;
  public
    constructor Create(Container: TOleContainer);
    function GetNextLink(dwLink: Longint): Longint; stdcall;
    function SetLinkUpdateOptions(dwLink: Longint;
      dwUpdateOpt: Longint): HResult; stdcall;
    function GetLinkUpdateOptions(dwLink: Longint;
      var dwUpdateOpt: Longint): HResult; stdcall;
    function SetLinkSource(dwLink: Longint; pszDisplayName: PChar;
      lenFileName: Longint; var chEaten: Longint;
      fValidateSource: BOOL): HResult; stdcall;
    function GetLinkSource(dwLink: Longint; var pszDisplayName: PChar;
      var lenFileName: Longint; var pszFullLinkType: PChar;
      var pszShortLinkType: PChar; var fSourceAvailable: BOOL;
      var fIsSelected: BOOL): HResult; stdcall;
    function OpenLinkSource(dwLink: Longint): HResult; stdcall;
    function UpdateLink(dwLink: Longint; fErrorMessage: BOOL;
      fErrorAction: BOOL): HResult; stdcall;
    function CancelLink(dwLink: Longint): HResult; stdcall;
    function GetLastUpdate(dwLink: Longint;
      var LastUpdate: TFileTime): HResult; stdcall;
  end;

procedure LinkError(const Ident: string);
begin
  Application.MessageBox(PChar(Ident), PChar(SLinkProperties),
    MB_OK or MB_ICONSTOP);
end;

constructor TOleUILinkInfo.Create(Container: TOleContainer);
begin
  inherited Create;
  FContainer := Container;
  FContainer.FOleObject.QueryInterface(IOleLink, FOleLink);
end;

function TOleUILinkInfo.GetNextLink(dwLink: Longint): Longint;
begin
  if dwLink = 0 then Result := Longint(FContainer) else Result := 0;
end;

function TOleUILinkInfo.SetLinkUpdateOptions(dwLink: Longint;
  dwUpdateOpt: Longint): HResult;
begin
  Result := FOleLink.SetUpdateOptions(dwUpdateOpt);
  if Succeeded(Result) then FContainer.Changed;
end;

function TOleUILinkInfo.GetLinkUpdateOptions(dwLink: Longint;
  var dwUpdateOpt: Longint): HResult;
begin
  Result := FOleLink.GetUpdateOptions(dwUpdateOpt);
end;

function TOleUILinkInfo.SetLinkSource(dwLink: Longint; pszDisplayName: PChar;
  lenFileName: Longint; var chEaten: Longint;
  fValidateSource: BOOL): HResult;
var
  DisplayName: string;
  Buffer: array[0..255] of WideChar;
begin
  Result := E_FAIL;
  if fValidateSource then
  begin
    DisplayName := pszDisplayName;
    if Succeeded(FOleLink.SetSourceDisplayName(StringToWideChar(DisplayName,
      Buffer, SizeOf(Buffer) div 2))) then
    begin
      chEaten := Length(DisplayName);
      try
        FContainer.UpdateObject;
      except
        Application.HandleException(FContainer);
      end;
      Result := S_OK;
    end;
  end else
    LinkError(SInvalidLinkSource);
end;

function TOleUILinkInfo.GetLinkSource(dwLink: Longint; var pszDisplayName: PChar;
  var lenFileName: Longint; var pszFullLinkType: PChar;
  var pszShortLinkType: PChar; var fSourceAvailable: BOOL;
  var fIsSelected: BOOL): HResult;
var
  Moniker: IMoniker;
begin
  with FContainer do
  begin
    if @pszDisplayName <> nil then
      pszDisplayName := CoAllocCStr(GetDisplayNameStr(FOleLink));
    if @lenFileName <> nil then
    begin
      lenFileName := 0;
      FOleLink.GetSourceMoniker(Moniker);
      if Moniker <> nil then
        lenFileName := OleStdGetLenFilePrefixOfMoniker(Moniker);
    end;
    if @pszFullLinkType <> nil then
      pszFullLinkType := CoAllocCStr(GetFullNameStr(FOleObject));
    if @pszShortLinkType <> nil then
      pszShortLinkType := CoAllocCStr(GetShortNameStr(FOleObject));
  end;
  Result := S_OK;
end;

function TOleUILinkInfo.OpenLinkSource(dwLink: Longint): HResult;
begin
  try
    FContainer.DoVerb(ovShow);
  except
    Application.HandleException(FContainer);
  end;
  Result := S_OK;
end;

function TOleUILinkInfo.UpdateLink(dwLink: Longint; fErrorMessage: BOOL;
  fErrorAction: BOOL): HResult;
begin
  try
    FContainer.UpdateObject;
  except
    Application.HandleException(FContainer);
  end;
  Result := S_OK;
end;

function TOleUILinkInfo.CancelLink(dwLink: Longint): HResult;
begin
  LinkError(SCannotBreakLink);
  Result := E_NOTIMPL;
end;

function TOleUILinkInfo.GetLastUpdate(dwLink: Longint;
  var LastUpdate: TFileTime): HResult;
begin
  Result := S_OK;
end;

{ TEnumFormatEtc - format enumerator for TDataObject }

type
  PFormatList = ^TFormatList;
  TFormatList = array[0..255] of TFormatEtc;

type
  TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
  private
    FFormatList: PFormatList;
    FFormatCount: Integer;
    FIndex: Integer;
  public
    constructor Create(FormatList: PFormatList; FormatCount, Index: Integer);
    { IEnumFormatEtc }
    function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out enum: IEnumFormatEtc): HResult; stdcall;
  end;

constructor TEnumFormatEtc.Create(FormatList: PFormatList;
  FormatCount, Index: Integer);
begin
  inherited Create;
  FFormatList := FormatList;
  FFormatCount := FormatCount;
  FIndex := Index;
end;

function TEnumFormatEtc.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
var
  I: Integer;
begin
  I := 0;
  while (I < celt) and (FIndex < FFormatCount) do
  begin
    TFormatList(elt)[I] := FFormatList[FIndex];
    Inc(FIndex);
    Inc(I);
  end;
  if pceltFetched <> nil then pceltFetched^ := I;
  if I = celt then Result := S_OK else Result := S_FALSE;
end;

function TEnumFormatEtc.Skip(celt: Longint): HResult;
begin
  if celt <= FFormatCount - FIndex then
  begin
    FIndex := FIndex + celt;
    Result := S_OK;
  end else
  begin
    FIndex := FFormatCount;
    Result := S_FALSE;
  end;
end;

function TEnumFormatEtc.Reset: HResult;
begin
  FIndex := 0;
  Result := S_OK;
end;

function TEnumFormatEtc.Clone(out enum: IEnumFormatEtc): HResult;
begin
  enum := TEnumFormatEtc.Create(FFormatList, FFormatCount, FIndex);
  Result := S_OK;
end;

{ TDataObject - data object for use in clipboard transfers }

type
  TDataObject = class(TInterfacedObject, IDataObject)
  private
    FOleObject: IOleObject;
    function GetObjectDescriptor: HGlobal;
  public
    constructor Create(const OleObject: IOleObject);
    { IDataObject }
    function GetData(const formatetcIn: TFormatEtc;
      out medium: TStgMedium): HResult; stdcall;
    function GetDataHere(const formatetc: TFormatEtc;
      out medium: TStgMedium): HResult; stdcall;
    function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
    function GetCanonicalFormatEtc(const formatetc: TFormatEtc;
      out formatetcOut: TFormatEtc): HResult; stdcall;
    function SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
      fRelease: BOOL): HResult; stdcall;
    function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
      IEnumFormatEtc): HResult; stdcall;
    function DAdvise(const formatetc: TFormatEtc; advf: Longint;
      const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
    function DUnadvise(dwConnection: Longint): HResult; stdcall;
    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
  end;

constructor TDataObject.Create(const OleObject: IOleObject);
begin
  inherited Create;
  FOleObject := OleObject;
end;

function TDataObject.GetObjectDescriptor: HGlobal;
var
  DescSize, UTNCharLen, SOCCharLen: Integer;
  Descriptor: PObjectDescriptor;
  UserTypeName, SourceOfCopy: string;
  OleLink: IOleLink;
  P: PWideChar;
begin
  UserTypeName := GetFullNameStr(FOleObject);
  SourceOfCopy := UserTypeName;
  FOleObject.QueryInterface(IOleLink, OleLink);
  if OleLink <> nil then
  begin
    UserTypeName := Format(SLinkedObject, [UserTypeName]);
    SourceOfCopy := GetDisplayNameStr(OleLink);
  end;
  UTNCharLen := MultiByteToWideChar(0, 0, PChar(UserTypeName),
      Length(UserTypeName), nil, 0) + 1;
  SOCCharLen := MultiByteToWideChar(0, 0, PChar(SourceOfCopy),
      Length(SourceOfCopy), nil, 0) + 1;
  DescSize := SizeOf(TObjectDescriptor) +
    ((UTNCharLen + SOCCharLen) * Sizeof(WideChar));
  Result := GlobalAlloc(GMEM_MOVEABLE, DescSize);
  if Result <> 0 then
  begin
    Descriptor := GlobalLock(Result);
    FillChar(Descriptor^, DescSize, 0);
    with Descriptor^ do
    begin
      cbSize := DescSize;
      FOleObject.GetUserClassID(clsid);
      dwDrawAspect := DVASPECT_CONTENT;
      FOleObject.GetMiscStatus(DVASPECT_CONTENT, dwStatus);

      dwFullUserTypeName := SizeOf(TObjectDescriptor);
      P := PWideChar(Integer(Descriptor) + dwFullUserTypeName);
      MultiByteToWideChar(0, 0, PChar(UserTypeName), Length(UserTypeName),
        P, UTNCharLen);
      P[UTNCharLen-1] := #0;

      dwSrcOfCopy := dwFullUserTypeName + SOCCharLen * SizeOf(WideChar);
      P := PWideChar(Integer(Descriptor) + dwSrcOfCopy);
      MultiByteToWideChar(0, 0, PChar(SourceOfCopy), Length(SourceOfCopy),
        P, SOCCharLen);
      P[SOCCharLen-1] := #0;
    end;
    GlobalUnlock(Result);
  end;
end;

function TDataObject.GetData(const formatetcIn: TFormatEtc;
  out medium: TStgMedium): HResult;
var
  Descriptor: HGlobal;
begin
  Result := DV_E_FORMATETC;
  medium.tymed := 0;
  medium.hGlobal := 0;
  medium.unkForRelease := nil;
  with formatetcIn do
  begin
    if (cfFormat = CFObjectDescriptor) and (dwAspect = DVASPECT_CONTENT) and
      (tymed = TYMED_HGLOBAL) then
    begin
      Descriptor := GetObjectDescriptor;
      if Descriptor <> 0 then
      begin
        medium.tymed := TYMED_HGLOBAL;
        medium.hGlobal := Descriptor;
        Result := S_OK;
      end;
    end;
  end;
end;

function TDataObject.GetDataHere(const formatetc: TFormatEtc;
  out medium: TStgMedium): HResult;
var
  PersistStorage: IPersistStorage;
begin
  Result := DV_E_FORMATETC;
  with formatetc do
    if (cfFormat = CFEmbeddedObject) and (dwAspect = DVASPECT_CONTENT) and
      (tymed = TYMED_ISTORAGE) then
    begin
      medium.unkForRelease := nil;
      FOleObject.QueryInterface(IPersistStorage, PersistStorage);
      if PersistStorage <> nil then
      begin
        Result := OleSave(PersistStorage, IStorage(medium.stg), False);
        PersistStorage.SaveCompleted(nil);
      end;
    end;
end;

function TDataObject.QueryGetData(const formatetc: TFormatEtc): HResult;
begin
  Result := DV_E_FORMATETC;
  with formatetc do
    if dwAspect = DVASPECT_CONTENT then
      if (cfFormat = CFEmbeddedObject) and (tymed = TYMED_ISTORAGE) or
        (cfFormat = CFObjectDescriptor) and (tymed = TYMED_HGLOBAL) then
        Result := S_OK;
end;

function TDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc;
  out formatetcOut: TFormatEtc): HResult;
begin
  formatetcOut.ptd := nil;
  Result := E_NOTIMPL;