oleinterface.pas

是一个delphi的流程制作软件

  except
    Result := ddUnexpected;
    raise
  end
end;

function TBaseREOleCallback.QueryInsertObject (const clsid: TCLSID; stg: IStorage; cp: longint): HRESULT;
begin
  Result:=  ddNotImplemented;
  try
    QueryInsertObject (clsid, stg, cp, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

function TBaseREOleCallback.DeleteObject (oleobj: IOLEObject): HRESULT;
begin
  Result:=  ddNotImplemented;
  try
    DeleteObject (oleobj, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

function TBaseREOleCallback.QueryAcceptData (dataobj: IDataObject; var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HRESULT;
begin
  Result:= ddNotImplemented;
  try
    QueryAcceptData (DataObj, cfFormat, TREFlag(reco), fReally, hMetaPict, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

function TBaseREOleCallback.ContextSensitiveHelp (fEnterMode: BOOL): HRESULT;
begin
  Result:=  ddNotImplemented;
  try
    ContextSensitiveHelp (fEnterMode, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

function TBaseREOleCallback.GetClipboardData (const chrg: TCharRange; reco: DWORD; out dataobj: IDataObject): HRESULT;
begin
  Result:= ddNotImplemented;
  try
    GetClipboardData (chrg, TREFlag(reco), dataobj, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

function TBaseREOleCallback.GetDragDropEffect (fDrag: BOOL; grfKeyState: DWORD; var dwEffect: DWORD): HRESULT;
begin
  Result:= ddNotImplemented;
  try
    GetDragDropEffect (fDrag, KeysToShiftState (grfKeyState), integer (dwEffect), integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

function TBaseREOleCallback.GetContextMenu (seltype: Word; oleobj: IOleObject; const chrg: TCharRange; var menu: HMENU): HRESULT;
begin
  Result:= ddNotImplemented;
  try
    GetContextMenu (seltype, oleobj, chrg, menu, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

procedure REOleSetCallback (RichEdit : TCustomRichEdit; OleInterface: IRichEditOleCallback);
begin
  if (not Assigned (RichEdit)) or (SendMessage (RichEdit.Handle, EM_SETOLECALLBACK, 0, longint (OleInterface)) = 0) then
    raise Exception.Create('Unable to set RichEditOleCallback')
end;

//=== IRichEditOle type conversion class =======================================

function REOleGetInterface(ARichEdit: TCustomRichEdit; out OleInterface: IRichEditOle): boolean;
begin
  Result:= boolean (SendMessage(ARichEdit.Handle, EM_GETOLEINTERFACE, 0, longint(@OleInterface)))
end;

constructor TRichEditOle.Create (ARichEdit : TCustomRichEdit);
begin
  inherited Create;
  if not REOleGetInterface (ARichEdit, FRichEditOle) then
    Fail
end;

function TRichEditOle.GetClientSite : IOleClientSite;
begin
  OleCheck (FRichEditOle.GetClientSite (Result))
end;

function TRichEditOle.GetObjectCount : integer;
begin
  Result := FRichEditOle.GetObjectCount
end;

function TRichEditOle.GetLinkCount : integer;
begin
  Result := FRichEditOle.GetLinkCount
end;

function TRichEditOle.GetObject (Index : integer; Flags : TREObjectFlags) : TREObject;
var
  IOB :  integer;
  IntFlags : integer;
begin
// prepare TREObject
  ZeroMemory (@Result, SizeOf (TREObject));
  Result.cbStruct := sizeof (TREObject);
// assemble dwFlags
  IntFlags := REO_GETOBJ_NO_INTERFACES;
  if reStorage in Flags then
    IntFlags := IntFlags or REO_GETOBJ_PSTG;
  if reOleObject in Flags then
    IntFlags := IntFlags or REO_GETOBJ_POLEOBJ;
  if reSite in Flags then
    IntFlags := IntFlags or REO_GETOBJ_POLESITE;
// get IOB
// select iob in preference order, index, selected, cp thus if the user
// specifies multiple flags the lower priority ones are discarded (alternative
// would be to raise an exception if multiple flags set).
  IOB := Index;
  if not (reIndex in Flags) then
    if reSelection in Flags then
      IOB := integer(REO_IOB_SELECTION)
    else
      if reByPosition in Flags then
      begin
        IOB := integer(REO_IOB_USE_CP);
        Result.cp := Index
      end;

  FRichEditOle.GetObject (IOB, Result, IntFlags)
end;

procedure TRichEditOle.InsertObject (REObject : TREObject);
begin
  OleCheck (FRichEditOle.InsertObject (REObject))
end;

procedure TRichEditOle.ConvertObject (Obj : integer; NewCLSID : TCLSID; UserTypeNew : string);
begin
  if UserTypeNew = '' then
    UserTypeNew := OleStdUserTypeOfClass (NewCLSID, 0);
  OleCheck (FRichEditOle.ConvertObject (Obj, NewCLSID, PChar(UserTypeNew)))
end;

procedure TRichEditOle.ActivateAs (clsid, clsidAs : TCLSID);
begin
  OleCheck (FRichEditOle.ActivateAs (CLSID, CLSIDAs))
end;

procedure TRichEditOle.SetHostNames (ContainerApp, ContainerObj : string);
begin
  OleCheck (FRichEditOle.SetHostNames (PChar(ContainerApp), PChar(ContainerObj)))
end;

procedure TRichEditOle.SetLinkAvailable (Obj : integer; Available : boolean);
begin
  OleCheck (FRichEditOle.SetLinkAvailable (Obj, Available))
end;

procedure TRichEditOle.SetdvAspect (Obj : integer; dvAspect : DWORD);
begin
  OleCheck (FRichEditOle.SetdvAspect (Obj, dvAspect))
end;

procedure TRichEditOle.HandsOffStorage (Obj : integer);
begin
  OleCheck (FRichEditOle.HandsOffStorage (Obj))
end;

procedure TRichEditOle.SaveCompleted (Obj : integer; Stg : IStorage);
begin
  OleCheck (FRichEditOle.SaveCompleted (Obj, Stg))
end;

procedure TRichEditOle.InPlaceDeactivate;
begin
  OleCheck (FRichEditOle.InPlaceDeactivate)
end;

procedure TRichEditOle.ContextSensitiveHelp (EnterMode : boolean);
begin
  OleCheck (FRichEditOle.ContextSensitiveHelp (EnterMode))
end;

function TRichEditOle.GetClipboardData (Chrg : TCharRange; reco : TREFlag) : IDataObject;
begin
  OleCheck (FRichEditOle.GetClipboardData (Chrg, ord(Reco), Result))
end;

procedure TRichEditOle.ImportDataObject (DataObj : IDataObject; Format : TClipFormat; MetaPict : HGLOBAL);
begin
  OleCheck (FRichEditOle.ImportDataObject (DataObj, Format, MetaPict))
end;

//==============================================================================

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

function TBaseOleObjInfo.GetObjectInfo (dwObject: Longint; var dwObjSize: Longint; var lpszLabel: PChar; var lpszType: PChar; var lpszShortType: PChar; var lpszLocation: PChar): HResult;
var
  ObjectSize : integer;
  ObjectLabel,
  ObjectLongType,
  ObjectShortType,
  ObjectLocation : string;
begin
  Result := E_NOTIMPL;
  GetObjectInfo (dwObject, ObjectSize, ObjectLabel, ObjectLongType, ObjectShortType, ObjectLocation, integer(Result));
  if Result = S_OK then
  begin
    if @dwObjSize <> nil then
      if ObjectSize = 0 then
        dwObjSize := -1
      else
        dwObjSize := ObjectSize;
    if @lpszLabel <> nil then
      lpszLabel := CoAllocCStr (ObjectLabel);
    if @lpszType <> nil then
      lpszType := CoAllocCStr (ObjectLongType);
    if @lpszShortType <> nil then
      lpszShortType := CoAllocCStr (ObjectShortType);
    if @lpszLocation <> nil then
      lpszLocation := CoAllocCStr (ObjectLocation)
  end
end;

function TBaseOleObjInfo.GetConvertInfo (dwObject: Longint; var ClassID: TCLSID; var wFormat: Word; var ConvertDefaultClassID: TCLSID; var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult;
var
  ClsidExclude : PCLSID;
  ClsidExcludeCount : integer;
  Format : TClipFormat;
begin
  Result := E_NOTIMPL;
  Format := 0;
  ClsidExclude := nil;
  ClsidExcludeCount := 0;
  GetConvertInfo (dwObject, ClassID, Format, ConvertDefaultClassID, ClsidExclude, ClsidExcludeCount, integer(Result));
  if Result = S_OK then
  begin
    if @wFormat <> nil then
      wFormat := Format;
    if @lpClsidExclude <> nil then
      lpClsidExclude := ClsidExclude;
    if @cClsidExclude <> nil then
      cClsidExclude := ClsidExcludeCount
  end
end;

function TBaseOleObjInfo.ConvertObject (dwObject: Longint; const clsidNew: TCLSID): HResult;
begin
  Result := E_NOTIMPL;
  ConvertObject (dwObject, clsidNew, integer(Result))
end;

function TBaseOleObjInfo.GetViewInfo (dwObject: Longint; var hMetaPict: HGlobal;  var dvAspect: Longint; var nCurrentScale: Integer): HResult;
var
  MetaPict : hGlobal;
  Aspect,
  Scale : integer;
begin
  Result := E_NOTIMPL;
  GetViewInfo (dwObject, MetaPict, Aspect, Scale, integer (Result));
  if @hMetaPict <> nil then
    hMetaPict := MetaPict;
  if @dvAspect <> nil then
    dvAspect := Aspect;
  if @nCurrentScale <> nil then
    nCurrentScale := Scale
end;

function TBaseOleObjInfo.SetViewInfo (dwObject: Longint; hMetaPict: HGlobal; dvAspect: Longint; nCurrentScale: Integer; bRelativeToOrig: BOOL): HResult;
begin
  Result := E_NOTIMPL;
  SetViewInfo (dwObject, hMetaPict, dvAspect, nCurrentScale, bRelativeToOrig, integer (Result))
end;

//--- Base OLE Link Container --------------------------------------------------

function TBaseOleLinkContainer.GetNextLink(dwLink: Longint): Longint;
begin
  Result := 0;
  GetNextLink (dwLink, Result)
end;

function TBaseOleLinkContainer.SetLinkUpdateOptions(dwLink: Longint; dwUpdateOpt: Longint): HResult;
begin
  Result := E_NOTIMPL;
  SetLinkUpdateOptions (dwLink, dwUpdateOpt, integer (Result))
end;

function TBaseOleLinkContainer.GetLinkUpdateOptions(dwLink: Longint; var dwUpdateOpt: Longint): HResult;
begin
  Result := E_NOTIMPL;
  GetLinkUpdateOptions (dwLink, dwUpdateOpt, integer (Result))
end;

function TBaseOleLinkContainer.SetLinkSource(dwLink: Longint; pszDisplayName: PChar; lenFileName: Longint; var chEaten: Longint; fValidateSource: BOOL): HResult;
begin
  Result := E_NOTIMPL;
  SetLinkSource (dwLink, pszDisplayName, lenFilename, chEaten, fValidateSource, integer (Result))
end;

function TBaseOleLinkContainer.GetLinkSource(dwLink: Longint; var pszDisplayName: PChar; var lenFileName: Longint; var pszFullLinkType: PChar; var pszShortLinkType: PChar; var fSourceAvailable: BOOL; var fIsSelected: BOOL): HResult;
var
  DisplayName,
  FullLinkType,
  ShortLinkType : string;
  IsSelected,
  SourceAvailable : boolean;
  Filename : integer;
begin
  Result := E_NOTIMPL;
  DisplayName := '';
  FullLinkType := '';
  ShortLinkType := '';
  if @fIsSelected <> nil then
    IsSelected := fIsSelected
  else
    IsSelected :=false;
  if @fSourceAvailable <> nil then
    SourceAvailable := fSourceAvailable
  else
    SourceAvailable := false;
  Filename := 0;
  GetLinkSource (dwLink, DisplayName, FullLinkType, ShortLinkType, Filename, SourceAvailable, IsSelected, integer (Result));
  if @pszDisplayName <> nil then
    pszDisplayName := CoAllocCStr(DisplayName);
  if @lenFileName <> nil then
    lenFileName := Filename;
  if @pszFullLinkType <> nil then
    pszFullLinkType := CoAllocCStr(FullLinkType);
  if @pszShortLinkType <> nil then
    pszShortLinkType := CoAllocCStr(ShortLinkType);
  if @fSourceAvailable <> nil then
    fSourceAvailable := SourceAvailable;
  if @fIsSelected <> nil then
    fIsSelected:= IsSelected
end;

function TBaseOleLinkContainer.OpenLinkSource(dwLink: Longint): HResult;
begin
  Result := E_NOTIMPL;
  OpenLinkSource (dwLink, integer (Result))
end;

function TBaseOleLinkContainer.UpdateLink(dwLink: Longint; fErrorMessage: BOOL; fErrorAction: BOOL): HResult;
begin
  Result := E_NOTIMPL;
  UpdateLink (dwLink, fErrorMessage, fErrorAction, integer (Result))
end;

function TBaseOleLinkContainer.CancelLink(dwLink: Longint): HResult;
begin
  Result := E_NOTIMPL;
  CancelLink (dwLink, integer(Result))
end;

//--- Base OLE Link Info -------------------------------------------------------

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


end.