olere.pas

是一个delphi的流程制作软件

  LocalStorage : IStorage;
  LocalOleObject : IOleObject;
  REObject : TREObject;
  R : TRect;
  Update : boolean;
begin
  with FRichEditOle do
  begin
    SetHostNames (Application.Title, FTitle);
    LocalClientSite := GetClientSite
  end;
  FRichEditOleCallBack.GetNewStorage (LocalStorage);

  with FInsertObject do
  try
// put ole interface values into the dialog properties
// we must free these ourselves later (or else get an AV)
    ClientSite := LocalClientSite;
    Storage := LocalStorage;
    LocalOleObject := nil;
    RetObject := @LocalOleObject;
// execute the dialog
    Result := Execute;
    if Result then
    begin
// Ok pressed so recover the values, setting up a TREObject record
      ZeroMemory (@REObject, sizeof (TREObject));
      REObject.cbStruct := sizeof (TREObject);
      REObject.clsid := clsid;
      REObject.cp := integer(REO_CP_SELECTION); // FSelIndex;
      REObject.oleobj := LocalOleObject;
      REObject.stg := LocalStorage;
      REObject.olesite := ClientSite;
      REObject.dvaspect := dvaContent;
      REObject.dwFlags := REO_RESIZABLE or REO_DYNAMICSIZE;
      if SelectCreateNew then
        REObject.dwFlags := REObject.dwFlags or REO_BLANK;

// Try to get a CLSID, generates an exception on failure so swallow it.
      if IsEqualCLSID (REObject.CLSID, CLSID_NULL) then
      try
        REObject.CLSID := OleStdClassFile (Filename)
      except
      end;

// Change display aspect to icon if requested
      if CheckDisplayAsIcon and Failed (OleStdSwitchDisplayAspect (LocalOleObject,
        REObject.dvAspect, dvaIcon, 0, false, false, nil, Update)) then
          Application.MessageBox ('Object couldn''t be displayed as an icon', 'UPad (Insert Object)', mb_ok);

// now stuff it in
      Insert (REObject);

// call the show verb for new objects
      if SelectCreateNew then
      begin
        R := Rect (0, 0 , 50, 50);
        OleCheck (LocalOleObject.DoVerb (OLEIVERB_SHOW, nil, ClientSite, 0, Application.Handle, R))
      end
    end;
// need to free these interfaces explicitly
  finally
    Storage := nil;
    ClientSite := nil;
    RetObject := nil
  end
end;

procedure TOleRE.Notification (AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = FRichEdit then
    begin
//    FreeInterfaces;
      FRichEdit := nil
    end else
      if AComponent = FInsertObject then
        FInsertObject := nil
      else
        if AComponent = FObjectProps then
          FObjectProps := nil
        else
          if AComponent = FEditLinks then
            FEditLinks := nil
          else
            if AComponent = FUpdateLinks then
              FUpdateLinks := nil
            else
              if AComponent = FPromptUser then
                FPromptUser := nil
              else
                if AComponent = FPasteSpecial then
                  FPasteSpecial := nil
                else
                  if AComponent = FChangeIcon then
                    FChangeIcon := nil
                  else
                    if AComponent = FChangeSource then
                      FChangeSource := nil
                   else
                      if AComponent = FConvertDialog then
                        FChangeSource := nil
end;

function TOleRE.ObjectPropertiesDialog : boolean;
begin
  Result := false;
  if Assigned (Selected) and Assigned (FObjectProps) then
    with FObjectProps do
    begin
      ObjectInfo := TOleUIObjInfo.Create (Self);
        ObjectIsLink := Linked;
        if ObjectIsLink then
          LinkInfo := TOleUILinkInfo.Create (Self);
      FObjectProps.DisableConvert := not CanConvertOrActivateAs;
      Result := FObjectProps.Execute
    end
end;

  function MyReader (dwCookie: Longint; pbBuff: PByte; cb: Longint; var pcb: Longint): Longint; stdcall;
  begin
    pcb := FileRead (dwCookie, pbBuff^, cb);
    if pcb >= 0 then
      Result := NOERROR
    else
      Result := longint(E_FAIL)
  end;

procedure TOleRE.Open (Filename : string; Fmt : integer; Insert : boolean);
const
  RTFSig = '{\rtf';
var
  EditStream : TEditStream;
  Stream : THandle;
  Sig : array [0..5] of char;
  Ext : string;
  Cb  : integer;
begin
  Screen.Cursor := crHourglass;
  try
// Open file
    Stream := FileOpen (Filename, fmOpenRead);
    try
      if Fmt = 0 then
      begin
// try to get file type by looking at the extension
        Ext := ExtractFileExt (Filename);
        if CompareText (Ext, '.RTF') = 0 then
          Fmt := SF_RTF
        else
          if CompareText (Ext, '.TXT') = 0 then
            Fmt := SF_TEXT
          else begin
// this doesn't work so read the file and look for the rtf signature
            Cb := FileRead (Stream, Sig, length (RTFSig));
            if (Cb = length (RTFSig)) and (CompareText (Sig, RTFSig) = 0) then
              Fmt := SF_RTF
            else
              Fmt := SF_TEXT;
// back to the beginning of the file
            FileSeek (Stream, 0, 0)
          end
      end;

      with EditStream do
      begin
        dwCookie := Stream;
        dwError := 0;
        pfnCallback := MyReader
      end;
      if Insert then
        Fmt := Fmt or SFF_SELECTION;
      RichEdit.Perform (EM_STREAMIN, Fmt, integer(@EditStream))
    finally
      FileClose (Stream)
    end;

    if not Insert then
    begin
      FFilename := Filename;
      FFilterIndex := Fmt and $FF;
      FRichEdit.Modified := false
    end
  finally
    Screen.Cursor := crDefault
  end
end;

function TOleRE.PasteSpecialDialog : boolean;

  procedure FromInfo (Ct : TCreateType);
  var
    Ci : TCreateInfo;
  begin
    Ci.CreateType := Ct;
    Ci.ShowAsIcon := FPasteSpecial.CheckDisplayAsIcon;
    Ci.IconMetaPict := FPasteSpecial.Metafile.MetaPict;
    Ci.DataObject := FPasteSpecial.DataObject;
    CreateObjectFromInfo (Ci)
  end;

type
  TREPasteSpecial = record
    Aspect,
    Param : DWORD
  end;

var
  Fmt : TClipFormat;
  RePs : TREPasteSpecial;

begin
  Result := false;
  if Assigned (FPasteSpecial) then
  begin
    FPasteSpecial.DataObject := nil; // DataObject = Clipboard
    Result := FPasteSpecial.Execute;

    if Result then
    begin
      Fmt := FPasteSpecial.Selected.Format;
      if (Fmt = cfDIB) or (Fmt = cfBitmap) or (Fmt = cfText) or (Fmt = cfRTF) or
        (Fmt = cfMetafilePict) or (Fmt = cfEmbeddedObject) or (Fmt = cfLinkSource) then
      begin
// A link is to be pasted
        if FPasteSpecial.SelectPasteLink then
          FromInfo (ctLinkFromData)
        else
// An embedded object is to be pasted, this is done directly from the dataobject
          if (Fmt = cfEmbeddedObject) and (OleQueryCreateFromData (FPasteSpecial.DataObject) = ddOk) then
            FromInfo (ctFromData)
          else begin
// Otherwise use default RichEdit paste special handler, passing the format to
// paste and a pointer to a record containing the icon aspect flag and the icon
// or empty if contents aspect is to be viewed.
            ZeroMemory (@RePs, sizeof (TREPasteSpecial));
            if FPasteSpecial.CheckDisplayAsIcon then
            begin
              RePs.Aspect := dvaIcon;
              RePs.Param := FPasteSpecial.Metafile.MetaPict
            end;
            RichEdit.Perform (EM_PASTESPECIAL, Fmt, integer (@RePs))
          end
      end
    end
  end
end;

procedure TOleRE.Revert;
begin
  if CanRevert and (Application.MessageBox ('Revert to last saved changes?',
      PChar(FFilename), MB_ICONQUESTION or MB_YESNO) = ID_YES) then
    Open (FFilename, FFilterIndex, false)
end;

  function MyWriter (dwCookie: Longint; pbBuff: PByte; cb: Longint; var pcb: Longint): Longint; stdcall;
  begin
    pcb := FileWrite (dwCookie, pbBuff^, cb);
    if pcb = cb then
      Result := NOERROR
    else
      Result := longint(E_FAIL)
  end;

procedure TOleRE.Save;
var
  EditStream : TEditStream;
  Stream : THandle;
begin
  Screen.Cursor := crHourglass;
  try
    Stream := FileCreate (FFilename);
    try
      with EditStream do
      begin
        dwCookie := Stream;
        dwError := 0;
        pfnCallback := MyWriter
      end;
      RichEdit.Perform (EM_STREAMOUT, FFilterIndex, integer(@EditStream))
    finally
      FileClose (Stream)
    end;
    RichEdit.Modified := false
  finally
    Screen.Cursor := crDefault
  end
end;

procedure TOleRE.SaveAs (const Filename : string; Selection : boolean);
var
  EditStream : TEditStream;
  Stream : THandle;
  Fmt : integer;
begin
  Screen.Cursor := crHourglass;
  try
    Stream := FileCreate (Filename);
    try
      with EditStream do
      begin
        dwCookie := Stream;
        dwError := 0;
        pfnCallback := MyWriter
      end;
      Fmt := FFilterIndex;
      if Selection then
        Fmt := Fmt or SFF_SELECTION;
      RichEdit.Perform (EM_STREAMOUT, Fmt, integer(@EditStream))
    finally
      FileClose (Stream)
    end;

    FRichEdit.Modified := false;
    FFilename := Filename
  finally
    Screen.Cursor := crDefault
  end
end;

procedure TOleRE.SaveCompleted (Storage : IStorage = nil);
begin
  FRichEditOle.SaveCompleted (FSelIndex, Storage)
end;

procedure TOleRE.SetDrawAspect (Aspect : integer);
begin
  FRichEditOle.SetdvAspect (FSelIndex, Aspect)
end;

procedure TOleRE.SetDrawAspect (Iconic, Force: boolean; IconMetaPict: HGlobal);
var
  OldAspect,
  NewAspect : DWORD;
  MustUpdate : boolean;
begin
  if Force then
    OldAspect := $FFFF
  else
    OldAspect := GetAspect;
  if Iconic then
    NewAspect := dvaIcon
  else
    NewAspect := dvaContent;
  OleCheck (OleStdSwitchDisplayAspect (Selected, OldAspect, NewAspect, IconMetaPict, false, false, nil, MustUpdate));
  SetDrawAspect (NewAspect)
end;

procedure TOleRE.SetLinkAvailable (Available : boolean);
begin
  FRichEditOle.SetLinkAvailable (FSelIndex, Available)
end;

procedure TOleRE.UpdateAllLinks;
var
  UpdateOpt,
  Count,
  Loop : integer;
  REObject : TREObject;
  OleLink : IOleLink;
begin
  if (Links > 0) and Assigned (FUpdateLinks) then
  begin
    Count := 0;
    for Loop := 0 to GetObjectCount - 1 do
    begin
      REObject := GetObject (Loop, [reIndex, reOleObject]);
      OleCheck (REObject.OleObj.QueryInterface (IOleLink, OleLink));
      if Assigned (OleLink) then
      begin
        OleLink.GetUpdateOptions (UpdateOpt);
        if UpdateOpt = OLEUPDATE_ALWAYS then
          inc (Count)
      end
    end;

    if Count > 0 then
    begin
      FUpdateLinks.Count := Count;
      FUpdateLinks.Links := TOleUILinkContainer.Create (Self);
      if (not FUpdateLinks.Execute) and Assigned (FPromptUser) then
      begin
        FPromptUser.UserStyle := usCannotUpdateLink;
        if FPromptUser.Execute = urLinks then
          EditLinksDialog
      end
    end
  end
end;

procedure TOleRE.UpdateLink;
var
  OleObject : IOleObject;
  OleLink : IOleLink;
  UpdateOpt : integer;
begin
  OleObject := Selected;
  if Assigned (FUpdateLinks) and Assigned (OleObject) then
  begin
    OleCheck (OleObject.QueryInterface (IOleLink, OleLink));
    if Assigned (OleLink) then
    begin
      OleLink.GetUpdateOptions (UpdateOpt);
      if UpdateOpt = OLEUPDATE_ALWAYS then
      begin
        FUpdateLinks.Count := 1;
        FUpdateLinks.Links := TOleUILinkContainer1.Create (OleLink);
        if (not FUpdateLinks.Execute) and Assigned (FPromptUser) and
          Assigned (FEditLinks) then
        begin
          FPromptUser.UserStyle := usCannotUpdateLink;
          if FPromptUser.Execute = urLinks then
            EditLinkDialog
        end
      end
    end
  end
end;

end.