olere.pas

是一个delphi的流程制作软件

  OleObject : IOleObject;
begin
  OleObject := FOleRE.Selected;
// Wanting to change the display aspect, so put new aspect
// into the cache and then tell the richedit to change
  if Aspect > 0 then
  begin
    if MetaPict = 0 then
      MetaPict := FOleRe.GetIconMetaPict;
    FOleRE.SetDrawAspect (Aspect=dvaIcon, false, MetaPict);
    Result := ddOk;
    exit
  end;
// Wanting to change the icon but not the aspect
  if MetaPict > 0 then
  begin
    FOleRE.SetDrawAspect (FOleRE.Iconic, false, MetaPict);
    Result := ddOk;
    exit
  end;

  Result := integer(E_FAIL)
end;

//=== Ole UI Link Information ==================================================

type
  TOleUILinkInfo = class (TStdOleLinkInfo)
    procedure GetNextLink (LinkId: integer; var Result : integer); override;
    procedure OpenLinkSource (LinkId: integer; var Result : integer); override;
    procedure CancelLink (LinkId: integer; var Result : integer); override;
    procedure UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer); override;
    procedure GetLastUpdate (LinkId : integer; var LastUpdate: TFileTime; var Result : integer); override;
  private
    FOleRE : TOleRE;
    FLink : integer;
  public
    constructor Create(OleRE : TOleRE);
  end;

constructor TOleUILinkInfo.Create(OleRE : TOleRE);
var
  OleObject : IOleObject;
  OleLink : IOleLink;
begin
  inherited Create;
  FOleRE := OleRE;
  OleObject := FOleRE.Selected;
  OleObject.QueryInterface(IOleLink, OleLink);
  FLink := integer (OleLink)
end;

procedure TOleUILinkInfo.GetNextLink (LinkId: integer; var Result : integer);
begin
  if LinkId = 0 then
    Result := FLink
  else
    Result := 0
end;

procedure TOleUILinkInfo.OpenLinkSource (LinkId: integer; var Result : integer);
begin
  try
    FOleRE.DoVerb(ovShow)
  except
    Application.HandleException(FOleRE)
  end;
  Result := S_OK
end;

procedure TOleUILinkInfo.UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer);
begin
  inherited UpdateLink (0, ErrorMessage, ErrorAction, Result);
  with FOleRE do
  if (Result = integer(MK_E_UNAVAILABLE)) and Assigned (FPromptUser) then
  begin
    FPromptUser.UserStyle := usCannotUpdateLink;
    if FPromptUser.Execute = urLinks then
      EditLinksDialog
  end
end;

procedure TOleUILinkInfo.CancelLink (LinkId: integer; var Result : integer);
begin
  LinkError('Cannot break link');
  Result := integer (E_NOTIMPL)
end;

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

//=== Rich Edit Callback =======================================================

type
  TRichEditOleCallback = class (TBaseREOleCallback)
  private
    FOleRE : TOleRE;
  protected
    procedure GetNewStorage (var Stg: IStorage; var Result : integer); override;
    procedure GetInPlaceContext (var Frame: IOleInPlaceFrame; var Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo; var Result : integer); override;
    procedure ShowContainerUI (Show : boolean; var Result : integer); override;
    procedure QueryInsertObject (const clsid: TCLSID; Stg: IStorage; Cp: integer; var Result : integer); override;
    procedure DeleteObject (OleObject: IOLEObject; var Result : integer); override;
    procedure QueryAcceptData (DataObject: IDataObject; var Format: TClipFormat; Reco: TREFlag; Really: boolean; MetaPict: hGlobal; var Result : integer); override;
    procedure ContextSensitiveHelp (EnterMode: boolean; var Result : integer); override;
    procedure GetClipboardData (const CharRange : TCharRange; Reco: TREFlag; var DataObject: IDataObject; var Result : integer); override;
    procedure GetDragDropEffect (Drag: boolean; ShiftState : TShiftState; var Effect: integer; var Result : integer); override;
    procedure GetContextMenu (SelType : word; OleObject : IOleObject; const CharRange: TCharRange; var Menu: hMenu; var Result : integer); override;
  public
    constructor Create (OleRE : TOleRE);
  end;

constructor TRichEditOleCallback.Create (OleRE : TOleRE);
begin
  inherited Create;
  FOleRE := OleRE
end;

procedure TRichEditOleCallback.GetNewStorage (var Stg: IStorage; var Result : integer);
begin
  Result:= ddOk;
  inc (FOleRE.FItemCount);
  if Assigned (FOleRE.FNewStorage) then
    FOleRE.FNewStorage (FOleRE, Stg, Result);
  if (not Assigned (Stg)) and (Result = ddOk) then
    Stg := OleStdCreateChildStorage (FOleRE.FStorage, Format ('REOBJ%d', [FOleRE.FItemCount]), SubStorageMode)
end;

procedure TRichEditOleCallback.GetInPlaceContext (var Frame: IOleInPlaceFrame; var Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo; var Result : integer);
begin
  Result:= ddOk;
  Frame := FOleRE.FFrame;
  if Assigned (Frame) then
    Frame.QueryInterface (IOleInPlaceUIWindow, Doc);
  with FrameInfo do
  begin
    cb := sizeof (TOleInPlaceFrameInfo);
    fMDIApp := false;
    Frame.GetWindow (hWndFrame);
    hAccel := 0;
    cAccelEntries := 0
  end
end;

procedure TRichEditOleCallback.ShowContainerUI (Show : boolean; var Result : integer);
begin
  if Show then
  begin
    FOleRE.FFrame.SetMenu (0, 0, 0);
    FOleRE.FFrame.ClearBorderSpace
  end;

  Result := ddOk;
  if Assigned (FOleRE.FShowContainer) then
    FOleRE.FShowContainer (FOleRE, Show, Result)
end;

procedure TRichEditOleCallback.QueryInsertObject (const clsid: TCLSID; Stg: IStorage; Cp: integer; var Result : integer);
begin
  Result := ddOk;
  if Assigned (FOleRE.FQueryInsertObject) then
    FOleRE.FQueryInsertObject (FOleRE, CLSID, Stg, Cp, Result)
end;

procedure TRichEditOleCallback.DeleteObject (OleObject: IOLEObject; var Result : integer);
begin
  Result := ddOk;
  if Assigned (FOleRE.FDeleteObject) then
    FOleRE.FDeleteObject (FOleRE, OleObject)
end;

procedure TRichEditOleCallback.QueryAcceptData (DataObject: IDataObject; var Format: TClipFormat; Reco: TREFlag; Really: boolean; MetaPict: hGlobal; var Result : integer);
begin
  Result:= ddOk;
  if Assigned (FOleRE.FQueryAcceptData) then
    FOleRE.FQueryAcceptData (FOleRE, DataObject, Format, Reco, Really, MetaPict, Result)
end;

procedure TRichEditOleCallback.ContextSensitiveHelp (EnterMode: boolean; var Result : integer);
begin
  Result:= ddOk;
  if Assigned (FOleRE.FContextHelp) then
    FOleRE.FContextHelp (FOleRE, EnterMode, Result)
end;

procedure TRichEditOleCallback.GetClipboardData (const CharRange : TCharRange; Reco: TREFlag; var DataObject: IDataObject; var Result : integer);
begin
  Result:= ddNotImplemented;
  if Assigned (FOleRE.FClipboard) then
    FOleRE.FClipboard (FOleRE, CharRange, Reco, DataObject, Result)
end;

procedure TRichEditOleCallback.GetDragDropEffect (Drag: boolean; ShiftState : TShiftState; var Effect: integer; var Result : integer);
begin
  Result:= ddNotImplemented;
  if Assigned (FOleRE.FDragDropEffect) then
    FOleRE.FDragDropEffect (FOleRE, Drag, ShiftState, Effect)
end;

procedure TRichEditOleCallback.GetContextMenu (SelType : word; OleObject : IOleObject; const CharRange: TCharRange; var Menu: hMenu; var Result : integer);
begin
  Result := ddOk;
  if Assigned (FOleRE.FContextMenu) then
    FOleRE.FContextMenu (FOleRE, SelType, OleObject, CharRange, Menu, Result)
end;

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

constructor TOleRE.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FSelFlags := [reSelection];
  FSelIndex := -1;
  FFilterIndex := SF_RTF
end;

procedure TOleRE.SetRichEdit (RichEdit : TCustomRichEdit);
begin
  FRichEdit := RichEdit;
  if Assigned (RichEdit) and not (csDesigning in ComponentState) then
  begin
    FDoc := GetVCLFrameForm (ValidParentForm(FRichEdit));
    if IsFormMDIChild (FDoc.Form) then
      FFrame := GetVCLFrameForm (Application.MainForm)
    else
      FFrame := FDoc;
    FStorage := OleStdCreateTempRootStorage (StorageMode);
    FRichEditOle := TRichEditOle.Create (FRichEdit);
    FRichEditOleCallback := TRichEditOleCallback.Create (Self);
    REOleSetCallback (FRichEdit, FRichEditOleCallback)
  end
end;

destructor TOleRE.Destroy;
begin
//  Close;
  inherited Destroy
end;

function TOleRE.ChangeIconDialog : boolean;
var
  OleObject : IOleObject;
  C : TCLSID;
begin
  Result := false;
  OleObject := Selected;
  if Assigned (OleObject) and Assigned (FChangeIcon) then
  with FChangeIcon do
  begin
    OleCheck (OleObject.GetUserClassID(C));
    AsCLSID := C;
    Metafile.Metapict := GetIconMetaPict;
    Result := Execute;
    if Result then
      SetDrawAspect (true, false, Metafile.MetaPict)
  end
end;

function TOleRE.ChangeSourceDialog : boolean;
var
  OleObject : IOleObject;
  OleLink : IOleLink;
begin
  OleObject := Selected;
  if Assigned (OleObject) and Assigned (FChangeSource) then
  begin
    OleObject.QueryInterface (IOleLink, OleLink);
    FChangeSource.Link := integer (pointer(OleLink));
    FChangeSource.LinkContainer := TOleUILinkContainer.Create (Self);
    Result := FChangeSource.Execute;
    if Result then
    begin
      SetDrawAspect (Iconic, true, GetIconMetaPict);
      Selected.Update
    end
  end else
    Result := false
end;

procedure TOleRE.CheckObject;
begin
  if not Assigned (Selected) then
    raise Exception.Create('Nothing selected');
end;

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

function TOleRE.ConvertDialog : boolean;
var
  CLSID : TCLSID;
  TypeStr,
  LabelStr : string;
  MetaPict : hGlobal;
  Format : TClipFormat;
  IconWanted : boolean;
  LocalObject : IOleObject;
begin
  Result := false;
  LocalObject := Selected;
  if Assigned (LocalObject) and Assigned (FConvertDialog) and CanConvertOrActivateAs then
  begin
// need to test if static already?
    ConvertInfo ([ciFormat, ciType, ciLabel, ciMetafile], CLSID, Format, TypeStr, LabelStr, MetaPict);
    FConvertDialog.IsLinked := Linked;
    FConvertDialog.Format.Aspect := XlatAspect (Aspect);
    FConvertDialog.AsCLSID := CLSID;
    FConvertDialog.Format.Format := Format;
    FConvertDialog.UserType := TypeStr;
    FConvertDialog.IconLabel := LabelStr;
    FConvertDialog.Metafile.MetaPict := MetaPict;
    if FConvertDialog.Execute then
    begin
//Potentially a long operation...
      Screen.Cursor := crHourglass;
      try
// First, let's bother with the iconic aspect switch.
        MetaPict := 0;
        IconWanted := FConvertDialog.Format.Aspect = caIcon;
        if IconWanted then
          MetaPict := FConvertDialog.Metafile.MetaPict;
        SetDrawAspect (IconWanted, true, MetaPict);
// Now change types around, don't bother if CLSID the same
        if (FConvertDialog.Select = csConvertTo) and
          not IsEqualCLSID (FConvertDialog.AsCLSID, FConvertDialog.NewCLSID) then
        begin
// Convert object
          FRichEditOle.ConvertObject (reoSelection, FConvertDialog.NewCLSID, '');
          LocalObject.Update
        end;

        if (FConvertDialog.Select = csActivateAs) then
// Activate As...
          FRichEditOle.ActivateAs (FConvertDialog.AsCLSID, FConvertDialog.NewCLSID)

      finally
        Screen.Cursor := crDefault
      end
    end
  end
end;

// Helper function for ConvertObjectDialog to retrieve necessary information about the object.
// The Wanted parameter varies the data fetched.
procedure TOleRE.ConvertInfo (Wanted : TConvertInfos; var CLSID : TCLSID; var Format : TClipFormat; var TypeStr, LabelStr : string; var Metafile : hGlobal);
var
  Buffer : POleStr;
  OleObject : IOleObject;
  Storage : IStorage;
begin
  CLSID := CLSID_NULL;
  Format := cfNull;
  TypeStr := '';
  LabelStr := '';
  Metafile := 0;
  OleObject := Selected;
  if Assigned (OleObject) then
  begin
    Storage := GetObjectStorage;
// For embedded objects get the real CLSID of the object and
// its format string.  If this fails then we can try to ask
// the object, or we can look in the registry.
    if Failed (ReadClassStg (Storage, CLSID)) then
      if Failed (OleObject.GetUserClassID (CLSID)) then
        CLSID := CLSID_NULL;
    if ((ciFormat in Wanted) or (ciType in Wanted)) and
      Succeeded (ReadFmtUserTypeStg (Storage, Format, Buffer)) then
    begin
      TypeStr := Buffer;
      if Assigned (Buffer) then
        OleStdFreeString (Buffer)
    end else begin
      Format := cfNull;
      TypeStr := OleStdUserTypeOfClass (CLSID, 0)
    end;
    if not (ciFormat in Wanted) then
      Format := cfNull;
    if not (ciType in Wanted) then
      TypeStr := '';
// Try to get the AuxUserType from the registry, using
// the short version (registered under AuxUserType\2).
// If that fails, just copy TypeStr.
    if ciLabel in Wanted then
    begin
      LabelStr := OleStdUserTypeOfClass (CLSID, 2);
      if LabelStr = '' then
        LabelStr := TypeStr
    end;

    if ciMetafile in Wanted then
      Metafile := GetIconMetaPict
  end;
end;

procedure TOleRE.CreateObjectFromInfo (const CreateInfo: TCreateInfo);
var
  LocalClientSite : IOleClientSite;
  LocalStorage : IStorage;
  LocalOleObject : IOleObject;
  REObject : TREObject;
  Update : boolean;
  R :TRect;
begin
  with FRichEditOle do
  begin
    SetHostNames (Application.Title, FTitle);
    LocalClientSite := GetClientSite
  end;
  FRichEditOleCallBack.GetNewStorage (LocalStorage);

  with CreateInfo do
  begin
    case CreateType of
      ctNewObject    : OleCheck(OleCreate(ClassID, IOleObject, OLERENDER_DRAW, nil, LocalClientSite, LocalStorage, LocalOleObject));
      ctFromFile     : OleCheck(OleCreateFromFile(GUID_NULL, PWideChar(FileName), IOleObject, OLERENDER_DRAW, nil, LocalClientSite, LocalStorage, LocalOleObject));
      ctLinkToFile   : OleCheck(OleCreateLinkToFile(PWideChar(FileName), IOleObject, OLERENDER_DRAW, nil, LocalClientSite, LocalStorage, LocalOleObject));
      ctFromData     : OleCheck(OleCreateFromData(DataObject, IOleObject, OLERENDER_DRAW, nil, LocalClientSite, LocalStorage, LocalOleObject));
      ctLinkFromData : OleCheck(OleCreateLinkFromData(DataObject, IOleObject, OLERENDER_DRAW, nil, LocalClientSite, LocalStorage, LocalOleObject))
    end;
    ZeroMemory (@REObject, sizeof (TREObject));
    REObject.cbStruct := sizeof (TREObject);
    LocalOleObject.GetUserClassId (REObject.CLSID);
    REObject.cp := integer(REO_CP_SELECTION);