olecontainer.pas

是一个delphi的流程制作软件

    UpdateView
  except
    if DataHandle <> 0 then
      GlobalFree(DataHandle);
    DestroyObject;
    raise
  end
end;

procedure TOle2Container.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
    SetFocus;
  inherited MouseDown (Button, Shift, X, Y)
end;

procedure TOle2Container.Changed;
begin
  if not (csReading in ComponentState) then
  begin
    FModified := true;
    FModSinceSave := true;
    DesignModified
  end
end;

procedure TOle2Container.ObjectMoved(const ObjectRect: TRect);
var
  R: TRect;
  I: Integer;
begin
  if Assigned(FOnObjectMove) then
  begin
    R := ObjectRect;
    I := GetBorderWidth;
    InflateRect (R, I, I);
    FOnObjectMove (Self, R)
  end
end;

function TOle2Container.ObjectPropertiesDialog: Boolean;
begin
  CheckObject;
  Result := false;
  if Assigned (FOleObjectPropsDialog) then
    with FOleObjectPropsDialog do
    begin
      ObjectInfo := TOleUIObjInfo.Create (Self);
      ObjectIsLink := Linked;
      ViewProps.SelectRelative := FScaleRelative;
      if ObjectIsLink then
        LinkInfo := TOleUILinkInfo.Create (Self);
      Result := Execute
    end
end;

procedure TOle2Container.Notification (AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = FOleInsertObjectDialog then
      FOleInsertObjectDialog := nil
    else
      if AComponent = FOleObjectPropsDialog then
        FOleObjectPropsDialog := nil
      else
        if AComponent = FOleEditLinksDialog then
          FOleEditLinksDialog := nil
        else
          if AComponent = FOlePromptUserDialog then
            FOlePromptUserDialog := nil
          else
            if AComponent = FOleChangeSourceDialog then
              FOleChangeSourceDialog := nil
            else
              if AComponent = FOleUpdateLinksDialog then
                FOleUpdateLinksDialog := nil
              else
                if AComponent = FOleChangeIconDialog then
                  FOleChangeIconDialog := nil
                else
                  if AComponent = FOleConvertDialog then
                    FOleConvertDialog := nil
                  else
                    if AComponent = FOlePasteSpecialDialog then
                      FOlePasteSpecialDialog := nil
end;

procedure TOle2Container.Paint;
var
  W, H: Integer;
  S: TPoint;
  R, CR: TRect;
  Flags: Integer;
begin
  if FDocObj and FUIActive then Exit;
  CR := Rect(0,0,Width,Height);
  if FBorderStyle = bsSingle then
  begin
    if NewStyleControls and Ctl3D then
      Flags := BF_ADJUST or BF_RECT
    else
      Flags := BF_ADJUST or BF_RECT or BF_MONO;
  end else
    Flags := BF_FLAT;

  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := Color;
  DrawEdge(Canvas.Handle, CR, EDGE_SUNKEN, Flags or BF_MIDDLE);
  if FOleObject <> nil then
  begin
    W := CR.Right - CR.Left;
    H := CR.Bottom - CR.Top;
    XFormSizeInHimetricToPixels(0, FViewSize, S);

    if (FDrawAspect = DVASPECT_CONTENT) and (FSizeMode = smScale) then
      if W * S.Y > H * S.X then
      begin
        S.X := S.X * H div S.Y;
        S.Y := H
      end else begin
        S.Y := S.Y * W div S.X;
        S.X := W
      end;

    if (FDrawAspect = DVASPECT_ICON) or (FSizeMode = smCenter) or (FSizeMode = smScale) then
    begin
      R.Left := (W - S.X) div 2;
      R.Top := (H - S.Y) div 2;
      R.Right := R.Left + S.X;
      R.Bottom := R.Top + S.Y;
    end
    else if FSizeMode = smClip then
    begin
      SetRect(R, CR.Left, CR.Top, S.X, S.Y);
      IntersectClipRect(Canvas.Handle, CR.Left, CR.Top, CR.Right, CR.Bottom);
    end
    else
      SetRect(R, CR.Left, CR.Top, W, H);
    OleDraw(FOleObject, FDrawAspect, Canvas.Handle, R);
    if FObjectOpen then OleStdShadeRect(Canvas.Handle, CR);
  end;
  if FFocused then Canvas.DrawFocusRect(CR);
end;

procedure TOle2Container.Paste;
var
  DataObject : IDataObject;
begin
  OleCheck (OleGetClipboard (DataObject));
  PasteThis (DataObject)
end;

procedure TOle2Container.PasteThis (DataObject : IDataObject; Link : boolean = false);
var
  Descriptor: ActiveX.PObjectDescriptor;
  FormatEtc: TFormatEtc;
  Medium: TStgMedium;
  CreateInfo: TCreateInfo;
  Z : TEnumFormats;
begin
  if CanPasteThis (DataObject) then
  begin
    Z := TEnumFormats.Create (DataObject);
    Z.HasBitmap;

    ZeroMemory (@CreateInfo, sizeof (TCreateInfo));
    try
      CreateInfo.DataObject := DataObject;
      if Link then
        CreateInfo.CreateType := ctLinkFromData
      else
        CreateInfo.CreateType := ctFromData;
      FormatEtc := SetFormatEtc (cfObjectDescriptor, tsGlobal);
      if Succeeded (CreateInfo.DataObject.GetData (FormatEtc, Medium)) then
      begin
        Descriptor := GlobalLock (Medium.hGlobal);
        try
          CreateInfo.ShowAsIcon := Descriptor^.dwDrawAspect = dvaIcon
        finally
          GlobalUnlock (Medium.hGlobal);
          ReleaseStgMedium (Medium)
        end
      end;
      if CreateInfo.ShowAsIcon then
      begin
        FormatEtc := SetFormatEtc (cfMetafilePict, tsMetafilePict, nil, dvaIcon);
        if Succeeded (CreateInfo.DataObject.GetData (FormatEtc, Medium)) then
          CreateInfo.IconMetaPict := Medium.hMetaFilePict
      end;
      CreateObjectFromInfo(CreateInfo)
    finally
      FreeMetafilePict (CreateInfo.IconMetaPict)
    end
  end
end;

function TOle2Container.PasteSpecialDialog: boolean;
var
  CreateInfo: TCreateInfo;
begin
  Result := false;
  if Assigned (FOlePasteSpecialDialog) then
    with FOlePasteSpecialDialog do
      if CanPaste and Execute then
      begin
        if Link then
          CreateInfo.CreateType := ctLinkFromData
        else
          CreateInfo.CreateType := ctFromData;
        CreateInfo.ShowAsIcon := CheckDisplayAsIcon;
        CreateInfo.IconMetaPict := Metafile.MetaPict;
        CreateInfo.DataObject := DataObject;
        CreateObjectFromInfo (CreateInfo);
        Result := true
      end
end;

procedure TOle2Container.PopupVerbMenuClick(Sender: TObject);
begin
  DoVerb((Sender as TMenuItem).Tag);
end;

function TOle2Container.QueryInterface(const iid: TIID; out obj): HResult;
begin
  Pointer(obj) := nil;
  Result := E_NOINTERFACE;
  if IsEqualIID(iid, IOleDocumentSite) and
    (not FAllowActiveDoc or (csDesigning in ComponentState)) then Exit;
  if GetInterface(iid, obj) then Result := S_OK;
end;

function TOle2Container._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;

procedure TOle2Container.Run;
begin
  CheckObject;
  OleCheck(OleRun(FOleObject));
end;

function TOle2Container.SaveObject: HResult;
var
  PersistStorage: IPersistStorage;
begin
  Result := S_OK;
  if FOleObject = nil then Exit;
  PersistStorage := FOleObject as IPersistStorage;
  OleCheck(OleSave(PersistStorage, FStorage, True));
  PersistStorage.SaveCompleted(nil);
  PersistStorage := nil;
  OleCheck(FStorage.Commit(STGC_DEFAULT));
  FModSinceSave := False;
end;

procedure TOle2Container.SaveAsDocument(const FileName: string);
var
  TempStorage: IStorage;
  PersistStorage: IPersistStorage;
begin
  CheckObject;
  if FModSinceSave then SaveObject;
  FOleObject.QueryInterface(IPersistStorage, PersistStorage);
  if PersistStorage <> nil then
  begin
    TempStorage := OleStdCreateRootStorage (Filename, fmOpenReadWrite or fmShareExclusive or fmCreate);
    OleCheck(OleSave(PersistStorage, TempStorage, False));
    PersistStorage.SaveCompleted (nil)
  end
end;

procedure TOle2Container.SaveToFile(const FileName: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create (FileName, Classes.fmCreate);
  try
    SaveToStream (Stream)
  finally
    Stream.Free
  end
end;

procedure TOle2Container.SaveToStream(Stream: TStream);
var
  TempLockBytes: ILockBytes;
  TempStorage: IStorage;
  DataHandle: HGlobal;
  Buffer: Pointer;
  Header: TStreamHeader;
begin
  CheckObject;
  if FModSinceSave then SaveObject;
  if FCopyOnSave then
  begin
    OleCheck (CreateILockBytesOnHGlobal(0, True, TempLockBytes));
    OleCheck (StgCreateDocfileOnILockBytes (TempLockBytes, fmOpenReadWrite or fmShareExclusive or fmCreate, 0, TempStorage));
    OleCheck (FStorage.CopyTo(0, nil, nil, TempStorage));
    OleCheck (TempStorage.Commit (STGC_DEFAULT));
    OleCheck (GetHGlobalFromILockBytes(TempLockBytes, DataHandle))
  end else
    OleCheck(GetHGlobalFromILockBytes(FLockBytes, DataHandle));

  Header.Signature := StreamSignature;
  Header.DrawAspect := FDrawAspect;
  Header.OrgSize := FOrgSize;
  Header.DataSize := GlobalSize(DataHandle);
  Stream.WriteBuffer(Header, SizeOf(Header));
  Buffer := GlobalLock(DataHandle);
  try
    Stream.WriteBuffer (Buffer^, Header.DataSize)
  finally
    GlobalUnlock(DataHandle)
  end
end;

procedure TOle2Container.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    AdjustBounds;
    Invalidate
  end
end;

procedure TOle2Container.SetDrawAspect(Iconic: Boolean; IconMetaPict: HGlobal);
var
  OleCache: IOleCache;
  EnumStatData: IEnumStatData;
  OldAspect,
  AdviseFlags, Connection: Longint;
  TempMetaPict: HGlobal;
  FormatEtc: TFormatEtc;
  Medium: TStgMedium;
  ClassID: TCLSID;
  StatData: TStatData;
begin
  OldAspect := FDrawAspect;
  if Iconic then
  begin
    FDrawAspect := DVASPECT_ICON;
    AdviseFlags := ADVF_NODATA;
  end else
  begin
    FDrawAspect := DVASPECT_CONTENT;
    AdviseFlags := ADVF_PRIMEFIRST;
  end;
  if (FDrawAspect <> OldAspect) or (FDrawAspect = DVASPECT_ICON) then
  begin
    OleCache := FOleObject as IOleCache;
    if FDrawAspect <> OldAspect then
    begin
      OleCheck(OleCache.EnumCache(EnumStatData));
      if EnumStatData <> nil then
        while EnumStatData.Next(1, StatData, nil) = 0 do
          if StatData.formatetc.dwAspect = OldAspect then
            OleCache.Uncache(StatData.dwConnection);
      FillChar(FormatEtc, SizeOf(FormatEtc), 0);
      FormatEtc.dwAspect := FDrawAspect;
      FormatEtc.lIndex := -1;
      OleCheck(OleCache.Cache(FormatEtc, AdviseFlags, Connection));
      SetViewAdviseSink(True);
    end;
    if FDrawAspect = DVASPECT_ICON then
    begin
      TempMetaPict := 0;
      if IconMetaPict = 0 then
      begin
        OleCheck(FOleObject.GetUserClassID(ClassID));
        TempMetaPict := OleGetIconOfClass(ClassID, nil, True);
        IconMetaPict := TempMetaPict;
      end;
      try
        FormatEtc := SetFormatEtc (cfMetafilePict, tsMetafilePict, nil, dvaIcon);
      //  Medium := SetMedium (tsMetafilePict);
        Medium.tymed := TYMED_MFPICT;
        Medium.hMetaFilePict := IconMetaPict;
        Medium.unkForRelease := nil;
        OleCheck(OleCache.SetData(FormatEtc, Medium, False));
      finally
        FreeMetafilePict (TempMetaPict)
      end;
    end;
    if FDrawAspect = dvaContent then
    try
      UpdateObject;
    except
      Application.HandleException (Self)
    end;
    UpdateView
  end
end;

procedure TOle2Container.SetFocused(Value: Boolean);
var
  R: TRect;
begin
  if FFocused <> Value then
  begin
    FFocused := Value;
    if GetUpdateRect(Handle, PRect(nil)^, False) then
      Invalidate
    else begin
      R := ClientRect;
      InflateRect(R, -GetBorderWidth, -GetBorderWidth);
      Canvas.DrawFocusRect (R)
    end
  end
end;

procedure TOle2Container.SetIconic(Value: Boolean);
begin
  if GetIconic <> Value then
  begin
    CheckObject;
    SetDrawAspect (Value, 0)
  end
end;

procedure TOle2Container.SetScale (Value : integer);
var