oledataobject.pas

是一个delphi的流程制作软件

      Format := cfFileDescriptor;
    with Result.Add do
    begin
      Format := cfFileContents;
      PageIndex := 0
    end
  end;

// does the punter want to supply or modify the format data
  if Assigned (FWantFormats) then
    FWantFormats (Self, Result)
end;

function TCustomStringDataSource.ProvideData (Format : TClipFormat; Medium : TClipMedium; Aspect : TClipAspect; AIndex : integer) : THandle;
var
  L : TStringList;
  T : TFileDescriptor;
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;

// See if we can provide the data
  Result := 0;
  if Aspect = caContent then
  begin

// Locale
    if (Format = cfLocale) and FAutoLocale then
    begin
      Result := MakeGlobal (SysLocale.DefaultLCID);
      exit
    end;

// Text, OemText and Filename or File contents for scrap operations
    if (Format = cfText) or (Format = cfOemText) or (Format=cfFilename) or
      (Format = cfFileContents) then
    begin
      Result := MakeGlobal (Text);
      exit
    end;

// CSV
    if Format = cfCSV then
    begin
      if Assigned (FControl) then
      begin
        if HasMultiSelect (FControl) then
          Result := MakeGlobal (MultiSelect (FControl))
        else
          if HasLines (FControl) then
            Result := MakeGlobal (Lines (FControl).CommaText);
        exit
      end;

      Result := MakeGlobal (FStrings.CommaText);
      exit
    end;

// HDrop and Printers
    if (Format = cfHDrop) or (Format = cfPrinters) then
    begin
      if Assigned (FControl) then
      begin
        if HasMultiSelect (FControl) then
        begin
          L := MultiSelectList (FControl);
          try
            Result := MakeGlobal (L)
          finally
            L.Free
          end;
          exit
        end;
        if HasLines (FControl) then
        begin
          L := TStringlist.Create;
          try
            L.Assign (Lines (FControl));
            Result := MakeGlobal (L)
          finally
            L.Free
          end;
          exit
        end;
        exit
      end;

      Result := MakeGlobal (FStrings);
      exit
    end;

// File descriptor for a text scrap operation
    if Format = cfFileDescriptor then
    begin
      InitFileDescriptor (T);
      with T do
      begin
        if FScrapFilename = '' then
          FileName := SysUtils.Format ('Text Scrap ''%s...''.txt', [copy (Text, 1, 10)])
        else
          Filename := FScrapFilename + '.txt';
        FileSize := length (Text)
      end;
      Result := MakeGlobal ([T]);
      exit
    end;

// inherited of cfObjectDescriptor
    Result := inherited ProvideData (Format, Medium, Aspect, AIndex);
    if Result <> 0 then
      exit;

// more string formats go here

  end
end;

//=== URL SOURCE ===============================================================

constructor TURLDataSource.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FAutoLocale := false;
  FScrapAllow := true;
  FFormats := [sfText]
end;

function TURLDataSource.ProvideFormats : TFormatEtcList;
begin
  Result := inherited ProvideFormats;

  if (Assigned (FURLControl) and (HasCaption (FURLControl) or HasText (FURLControl) or
    HasTabs (FURLControl) or (HasItemIndex (FURLControl) and HasItems (FURLControl)))) or
     (not Assigned (FURLControl) and (FURL <> '')) then
  begin
    Result.Add;
    with Result.Add do
      Format := cfURL;
    with Result.Add do
      Format := cfNetscape
  end;

  if FScrapAllow then
  begin
    with Result.Add do
      Format := cfFileDescriptor;
    with Result.Add do
    begin
      Format := cfFileContents;
      PageIndex := 0
    end
  end;

// does the punter want to supply or modify the format data
  if Assigned (FWantFormats) then
    FWantFormats (Self, Result)
end;

function TURLDataSource.ProvideData (Format : TClipFormat; Medium : TClipMedium; Aspect : TClipAspect; AIndex : integer) : THandle;

// Generate a valid filename from a string, including a url
  function ValidateFilename (const URL : string): string;
  const
    Protocols : array [1..5] of string [8] = ('http://', 'https://', 'ftp://', 'mailto:', 'file:///');
  var
    I : integer;
  begin
    if URL = '' then
      Result := 'untitled'
    else begin
      Result := URL;
// remove any protocol string
      for I := 1 to 5 do
        if CompareText (Protocols [I], copy (URL, 1, length (Protocols[I]))) = 0 then
        begin
          Result := copy (URL, length (Protocols[I]) + 1, 120);
          break
        end;
    end;

// shorten to the first /
    I := pos ('/', Result);
    if I <> 0 then
      Delete (Result, I, 255);

// strip leading drive:\
    if pos(':\', Result) = 2 then
      Delete (Result, 1, 3);

// strip any character that is not legal in a filename
    repeat
      I := pos (':/|\<>*?"''', Result);
      if I <> 0 then
        Delete (Result, I, 1)
    until I = 0;

    Result := Result + '.url'
  end;

const
  Prefix = '[InternetShortcut]'#10'URL=';

var
  LenURL : integer;
  LocalURL  : string;
  T : TFileDescriptor;
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;

// See if we can provide the data
  Result := 0;
  if Aspect = caContent then
  begin
    LocalURL := URL;
    LenURL := length (LocalURL);

// Text and URLs
    if (Format = cfText) or (Format = cfURL) or (Format = cfNetscape) then
    begin
      Result := MakeGlobal (LocalURL);
      exit
    end;

// File contents for scrap operations
    if Format = cfFileContents then
    begin
      Result := MakeGlobal (Prefix + LocalURL);
      exit
    end;

// File descriptor for a url desktop/explorer drop operation
    if Format = cfFileDescriptor then
    begin
      InitFileDescriptor (T);
      with T do
      begin
        LocalURL := Text;
        if LocalURL = '' then
          LocalURL := URL;
        Filename := ValidateFilename (LocalURL);
        FileSize := LenURL + length (Prefix)
      end;
      Result := MakeGlobal ([T]);
      exit
    end;

// object descriptor
    Result := inherited ProvideData (Format, Medium, Aspect, AIndex);
  end
end;

procedure TURLDataSource.SetURL (const Value : string);
begin
  if (not Assigned (FURLControl)) and (Value <> FURL) then
    FURL := Value
end;

function TURLDataSource.GetURL : string;
begin
  if Assigned (FURLControl) then
    Result := GetTextAvailable (FURLControl)
  else
    Result := FURL
end;

function TURLDataSource.IsURLControl : boolean;
begin
  Result := not Assigned (FURLControl)
end;

procedure TURLDataSource.Notification (AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FURLControl) then
    FURLControl := nil
end;

//=== COMPONENT SOURCE =========================================================

function TComponentDataSource.ProvideFormats : TFormatEtcList;
begin
  Result := inherited ProvideFormats;

  if Assigned (FComponent) then
  begin
    with Result.Add do
      Format := cfComponent;
    Result.Add; // cfText by default
    with Result.Add do
      Format := cfLocale;
    with Result.Add do
      Format := cfOemText
  end;

  if Assigned (FWantFormats) then
    FWantFormats (Self, Result)
end;

function TComponentDataSource.ProvideData (Format : TClipFormat; Medium : TClipMedium; Aspect : TClipAspect; AIndex : integer) : THandle;
var
  AsText   : TMemoryStream;
  AsBinary : TPersistMemStream;
begin
  Result := 0;

  if Assigned (FWantData) then
  begin
    FWantData (Self, Format, Medium, Aspect, AIndex, Result);
    if Result <> 0 then
      exit
  end;

  if (Aspect = caContent) and Assigned (FComponent) then
  begin
    if Format = cfLocale then
    begin
      Result := MakeGlobal (SysLocale.DefaultLCID);
      exit
    end;

    Result := inherited ProvideData (Format, Medium, Aspect, AIndex);
    if Result <> 0 then
      exit;

// Stream the component definition out into a persistent stream
// Use this directly for a cfComponent
    AsBinary := TPersistMemStream.Create;
    try
      AsBinary.WriteDescendent (FComponent, nil);
      if Format = cfComponent then
        Result := AsBinary.Handle
      else begin
// Or convert to text for cfText and cfOemText and return a global string
        AsText := TMemoryStream.Create;
        try
          AsBinary.Seek (0, 0);
          ObjectBinaryToText (AsBinary, AsText);
          Result := MakeGlobal (PChar(AsText.Memory));
          AsBinary.Clear
        finally
          AsText.Free
        end
      end
    finally
      AsBinary.Free
    end
  end
end;

procedure TComponentDataSource.Notification (AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FComponent) then
    FComponent := nil
end;

//=== DELPHI OBJECT DATA SOURCE ================================================
// Pass the instance by reference and the ThreadId as a validation test.

function TDelphiObjectDataSource.ProvideFormats : TFormatEtcList;
begin
  Result := inherited ProvideFormats;

  if Assigned (FControl) then
  begin
    with Result.Add do
      Format := cfObject;
    Result.Add  // cfText
  end
end;

function TDelphiObjectDataSource.ProvideData (Format : TClipFormat; Medium : TClipMedium; Aspect : TClipAspect; AIndex : integer) : THandle;
var
  Data : TDelphiObjectData;
begin
  Result := 0;
  if Assigned (FControl) and (Aspect = caContent) and (Medium = cmGlobal) then
  begin
    if Format = cfObject then
    begin
      Data.Thread := MainThreadId;
      Data.Control := FControl;
      Result := MakeGlobal (Data, sizeof (TDelphiObjectData));
      exit
    end;
    if Format = cfText then
    begin
      Result := MakeGlobal (FControl.ClassName);
      exit
    end;

    Result := inherited ProvideData (Format, Medium, Aspect, AIndex)
  end;
end;

end.