oledataobject.pas

是一个delphi的流程制作软件

constructor TCloneDataObject.Create (Formats : TFormatEtcList; Handles : THandles);
begin
  inherited Create;
  FFormats := Formats;
  FHandles := Handles;
// Check number of formats = number of data handles
  Assert (FFormats.Count = High (FHandles) + 1, 'DataObject .create mismatch')
end;

// Destroy data held by the dataobject
destructor TCloneDataObject.Destroy;
var
  loop : integer;
  Medium : TStgMedium;
begin
// release copies of the data
  Medium.unkForRelease := nil;
  for loop := 0 to FFormats.Count - 1 do
  begin
    Medium.Tymed := XlatMediums(FFormats.Items[loop].Medium);
    Medium.hGlobal := FHandles [Loop];
    ReleaseStgMedium (Medium)
  end;
// release array
  FHandles := nil;
// release FormateEtc list
  FFormats.Free;
  inherited Destroy
end;

procedure TCloneDataObject.GetData (const FormatEtc : TFormatEtc; var Medium : TStgMedium; var Result : integer);
var
  Loop : integer;
begin
  ZeroMemory (@Medium, sizeof (TStgMedium));
// look through all formats, in priority order, for a match or at least a close
// fit.  Ask for a global handle to the data from handles array and duplicate it
// for the actual transfer.
  for Loop := 0 to FFormats.Count - 1 do
    if OleStdCompareFormatEtc (FormatEtc, FFormats[Loop].FormatEtc) > cfeNone then
    begin
      Medium.tymed := FFormats[Loop].FormatEtc.tymed;  // use the media we have
      if FormatEtc.tymed in [tsGlobal, tsGDI, tsMetafilePict, tsEnhMetafile] then
      begin
        Medium.hGlobal := OleDuplicateData (FHandles [Loop], FormatEtc.cfFormat, 0);
        Assert (Medium.hGlobal <> 0,'OleDuplicateData Failed');
      end else
        Medium.hGlobal := FHandles [Loop];
      Result := ddOk;
      exit
    end;

  Result := integer(ddBadFormatEtc)
end;

procedure TCloneDataObject.GetDataHere (const FormatEtc: TFormatEtc; var Medium: TStgMedium; var Result : integer);
begin
end;

procedure TCloneDataObject.QueryGetData (const FormatEtc: TFormatEtc; var Result : integer);
var
  Loop : integer;
begin
  for Loop := 0 to FFormats.Count - 1 do
    if OleStdCompareFormatEtc (FormatEtc, FFormats[Loop].FormatEtc) > cfeNone then
    begin
      Result := ddOk;
      exit
    end;

  Result := integer(ddBadFormatEtc)
end;

procedure TCloneDataObject.GetCanonicalFormatEtc (const FormatEtcIn: TFormatEtc; var FormatEtcOut: TFormatEtc; var Result : integer);
begin
end;

procedure TCloneDataObject.SetData (const formatetc: TFormatEtc; var Medium: TStgMedium; Release: boolean; var Result : integer);
begin
end;

// When asked for supported data formats send out the enum
procedure TCloneDataObject.EnumFormatEtc (Direction: integer; var EnumFormatEtc: IEnumFormatEtc; var Result : integer);
begin
  if Direction = ddGet then
  begin
    EnumFormatEtc := TStdEnumFormatEtc.Create (FFormats);
    Result := ddOk
  end
end;

procedure TCloneDataObject.DAdvise (const FormatEtc: TFormatEtc; Advf: integer; const AdvSink: IAdviseSink; var Connection: integer; var Result : integer);
begin
end;

procedure TCloneDataObject.DUnadvise (Connection: integer; var Result : integer);
begin
end;

procedure TCloneDataObject.EnumDAdvise (var EnumAdvise: IEnumStatData; var Result : integer);
begin
end;

//=== INTERMEDIATE DELPHI DATA SOURCE CLASS ====================================
// Copy the data into an array of handles with a one:one relation to the
// formats list.  Create a new IDataObject that contains this data copy.
function TCustomDataSource.GetDataObject : IDataObject;
var
  Loop : integer;
  AMedium : TClipMedium;
  Handles : THandles;
  Formats : TFormatEtcList;
begin
  if Assigned (FBegin) then
    FBegin (Self);

  Result := nil;
  if Assigned (FWantDataObject) then
    FWantDataObject (Self, Result);

  if not Assigned (Result) then
  begin
    Formats := ProvideFormats;
    with Formats do
      if Count > 0 then
      begin
        SetLength (Handles, Count);
        for Loop := 0 to Count - 1 do
          with Items [Loop] do
          begin

  // knows about Global, GDI, MFPict and EnhMF
  // only type medium (all in global memory)
            AMedium := cmGlobal;
            if cmGDI in Medium then
              AMedium := cmGDI
            else
              if cmMFPict in Medium then
                AMedium := cmMFPict
              else
                if cmEnhMF in Medium then
                  AMedium := cmEnhMF;

            Handles [Loop] := ProvideData (Format, AMedium, Aspect, PageIndex)
          end;
        Result := TCloneDataObject.Create (Formats, Handles)
      end;
  end;

  if Assigned (FEnd) then
    FEnd (Self)
end;

procedure TCustomDataSource.CopyToClipboard;
begin
  FPreferredDropEffect := deCopy;
  OleCheck(OleSetClipboard (DataObject))
end;

procedure TCustomDataSource.CutToClipboard;
begin
  FPreferredDropEffect := deMove;
  OleCheck(OleSetClipboard (DataObject))
end;

//=== Delphi Data Source =======================================================
// override to add cfFileDescriptor and cfObjectDescriptor formats

function TDelphiDataSource.ProvideFormats : TFormatEtcList;
begin
  Result := TFormatEtcList.Create (nil);

// If create scrap file is enabled then put file descriptor and contents
// formats in
  if FScrapAllow then
  begin
    with Result.Add do
      Format := cfFileDescriptor;
    with Result.Add do
    begin
      Format := cfFileContents;
      PageIndex := 0
    end
  end;

// Create an object descriptor
  if FDescriptionMode <> dmNone then
    with Result.Add do
      Format := cfObjectDescriptor;

// Create a preferred drop effect
  if FPreferAllow then
    with Result.Add do
      Format := cfPreferredDropEffect
end;

// service a cfObjectDescriptor call by returning the app title, exe name etc
function TDelphiDataSource.ProvideData (Format : TClipFormat; Medium : TClipMedium; Aspect : TClipAspect; AIndex : integer) : THandle;
var
  O : TObjectDescriptor;
begin
  Result := 0;

  if Format = cfPreferredDropEffect then
  begin
    Result := MakeGlobal (FPreferredDropEffect);
    exit
  end;

  if Format = cfObjectDescriptor then
  begin
    ZeroMemory (@O, Sizeof (TObjectDescriptor));

    case FDescriptionMode of
      dmTitle   : O.SrcOfCopy := Application.Title;
      dmExeName : O.SrcOfCopy := Application.ExeName;
      dmName    : O.SrcOfCopy := ExtractFileName (Application.ExeName)
    end;
// check event
    if Assigned (FWantDescription) then
      FWantDescription (Self, O);
// translate and return global handle
    Result := XlatObjectDescriptor (O);
    exit
  end;
end;

//=== PICTURE SOURCE ===========================================================
// This provides support for dragging an Image, either a TPicture or a TImage.

constructor TPictureDataSource.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FAutoMF := true;
  FAutoPal := true;
  FPicture := TPicture.Create
end;

destructor TPictureDataSource.Destroy;
begin
  FPicture.Free;
  inherited Destroy
end;

procedure TPictureDataSource.SetImage (Value : TImage);
begin
  if FImage <> Value then
  begin
    FPicture.Graphic := nil;
    FImage := Value
  end
end;

function TPictureDataSource.GetPicture : TPicture;
begin
  if Assigned (FImage) then
    Result := FImage.Picture
  else
    Result := FPicture
end;

procedure TPictureDataSource.SetPicture (Value : TPicture);
begin
  if FPicture <> Value then
  begin
    FImage := nil;
    FPicture.Graphic := Value.Graphic
  end
end;

function TPictureDataSource.IsPicture : boolean;
begin
  Result := not Assigned (FImage) // Don't save the picture if there's a
end;                              // TImage linked (otherwise we get it twice)

function TPictureDataSource.ProvideFormats : TFormatEtcList;

// add a MFPict format as well?
  procedure CheckMF;
  begin
    if FAutoMF then
      with Result.Add do
      begin
        Format := cfMetafilePict;
        Medium := [cmMFPict]
      end
  end;

// make the palette available if present and wanted
  procedure CheckPalette;
  begin
    if FAutoPal and (Picture.Graphic.Palette <> 0) then
      with Result.Add do
      begin
        Format := cfPalette;
        Medium := [cmGDI]
      end
  end;

begin
  Result := inherited ProvideFormats;

  if Assigned (Picture) and Assigned (Picture.Graphic) then
  begin
    with Result.Add do
    begin

// Picture is a bitmap
      if Picture.Graphic is TBitmap then
      begin
        Format := cfBitmap;
        Medium := [cmGDI];
        CheckMF;
        CheckPalette
      end else

// Picture is a JPEG
{$IFDEF JPEG}
      if Picture.Graphic is TJPEGImage then
      begin
        Format := cfBitmap;
        Medium := [cmGDI];
        CheckMF;
        CheckPalette
      end else
{$ENDIF}

// Picture is an enhanced metafile
      if Picture.Graphic is TMetafile then
      begin
        Format := cfEnhMetafile;
        Medium := [cmEnhMF];
        CheckMF;
        CheckPalette
      end else

// Picture is an Icon
      if Picture.Graphic is TIcon then
      begin
        Format := cfIcon;
        CheckMF
      end else

// Picture is a GIF
{$IFDEF GIF}
      if Picture.Graphic is TGifImage then
      begin
        Format := cfGIF;
        with Result.Add do
        begin
          Format := cfBitmap;
          Medium := [cmGDI]
        end;
        CheckMF;
        CheckPalette
      end // else
{$ENDIF}
    end;

// more predefined formats can go here...

  end;

// Does the punter want to add formats?
  if Assigned (FWantFormats) then
    FWantFormats (Self, Result);
end;

function TPictureDataSource.ProvideData (Format : TClipFormat; Medium : TClipMedium; Aspect : TClipAspect; AIndex : integer) : THandle;
var
  T : TFileDescriptor;
  S : string;
begin
  Result := 0;

// See if the punter has the data
  if Assigned (FWantData) then
  begin
    FWantData (Self, Format, Medium, Aspect, AIndex, Result);
    if Result <> 0 then
      exit
  end;

  if (Aspect = caContent) and Assigned (Picture) then
  begin
    case Format of
      cfBitmap :   // also JPEGs which only give a bitmap, and a Gifimage which can render a bitmap
        if Medium = cmGDI then
          if Picture.Graphic is TBitmap then
            Result := MakeGlobal (Picture.Bitmap)
{$IFDEF JPEG}
           else
             if Picture.Graphic is TJPEGImage then
               Result := MakeGlobal (Picture.Graphic as TJPEGImage)
{$ENDIF}
{$IFDEF GIF}
           else
             if Picture.Graphic is TGifImage then
               Result := MakeGlobal ((Picture.Graphic as TGifImage).Bitmap)
{$ENDIF}   ;

      cfPalette :
        try
          if Medium = cmGDI then
            Result := CopyPalette (Picture.Graphic.Palette)
        except
          Result := 0
        end;

      cfEnhMetafile :
        if Medium = cmEnhMF then
          Result := OleDuplicateData (Picture.Metafile.Handle, cfEnhMetafile, 0);

      cfMetafilePict :