oleformatetc.pas

是一个delphi的流程制作软件

//--- Ole FormatEtc Stuff ------------------------------------------------------
//
// FormatEtc stuff using a TCollection to hold the information and an
// enumerator that uses it.
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//------------------------------------------------------------------------------

{$INCLUDE OLE.INC}

unit OleFormatEtc;

interface

uses
  Windows, Classes, ActiveX, Forms,
  OleConsts, OleHelpers, OleStd, OleInterface;

type
  TFormatEtcItem = class (TCollectionItem)
  private
    FFormat : TClipFormat;
    FName : TClipName;
    FAspect : TClipAspect;
    FMedium : TClipMediums;
    FIndex : integer;
    procedure SetName (const Value : TClipName);
    procedure SetFormat (const Value : TClipFormat);
    function GetFormatEtc : TFormatEtc;
  protected
    function GetDisplayName: string; override;
  public
    constructor Create (Collection: TCollection); override;
    procedure Assign (Source: TPersistent); override;
  published
    property Aspect : TClipAspect read FAspect write FAspect default caContent;
    property Format : TClipFormat read FFormat write SetFormat stored false;
    property PageIndex : integer read FIndex write FIndex;
    property Medium : TClipMediums read FMedium write FMedium default [cmGlobal];
    property Name : TClipName read FName write SetName;
    property FormatEtc : TFormatEtc read GetFormatEtc;
  end;

  TFormatEtcList = class (TCollection)
  private
    FOwner: TComponent;
    function GetItem (Index: Integer): TFormatEtcItem;
    procedure SetItem (Index: Integer; Value: TFormatEtcItem);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create (AOwner: TComponent);
    function Add: TFormatEtcItem;
    property Owner: TComponent read FOwner;
    property Items [Index: Integer]: TFormatEtcItem read GetItem write SetItem; default;
  end;

// This provides a data format enumerator that works with the format collection.
type
  TStdEnumFormatEtc = class (TBaseEnumFormatEtc)
  private
    FList : TFormatEtcList;
    FIndex : integer;
  protected
    procedure Next (Celt : integer; var FormatEtc : TFormatEtc; var Fetched, Result : integer); override;
    procedure Next (var FormatEtc : TFormatEtc; var Result : integer); overload; virtual;
    procedure Skip (Celt : integer; var Result : integer); override;
    procedure Reset (var Result : integer); override;
    procedure Clone (var Enum : IEnumFormatEtc; var Result : integer); override;
  public
    constructor Create (List : TFormatEtcList; Index : integer = 0);
    destructor Destroy; override;
  end;

implementation

// A default format item is global - text - content
constructor TFormatEtcItem.Create (Collection: TCollection);
begin
  inherited Create (Collection);
  Name := 'Text';
  Medium := [cmGlobal];
  Aspect := caContent;
  PageIndex := -1
end;

// Get the format number given the name change
procedure TFormatEtcItem.SetName (const Value : TClipName);
begin
  if FName <> Value then
  begin
    FName := Value;
    FFormat := GetPredefinedFormat (Value);
    if FFormat = 0 then
      FFormat := RegisterClipboardFormat (Value)
  end
end;

// Get the format name given a number change
procedure TFormatEtcItem.SetFormat (const Value : TClipFormat);
begin
  if FFormat <> Value then
  begin
    FFormat := Value;
    FName := GetClipboardFormatName (Value)
  end
end;

procedure TFormatEtcItem.Assign (Source: TPersistent);
var
  Item : TFormatEtcItem;
begin
  if Source is TFormatEtcItem then
  begin
    Item := TFormatEtcItem (Source);
    Name := Item.Name;
    Aspect := Item.Aspect;
    Medium := Item.Medium;
    PageIndex := Item.PageIndex
  end else
    inherited Assign (Source)
end;

function TFormatEtcItem.GetDisplayName: string;
begin
  Result := Name;
  if Result = '' then
    Result := inherited GetDisplayName
end;

// Make a TFormatEtc record from the settings
function TFormatEtcItem.GetFormatEtc : TFormatEtc;
begin
  Result := SetFormatEtc (FFormat, XlatMediums (FMedium), nil, XlatAspect (FAspect), FIndex)
end;

//=== FORMAT COLLECTION ========================================================

constructor TFormatEtcList.Create(AOwner: TComponent);
begin
  inherited Create (TFormatEtcItem);
  FOwner := AOwner
end;

function TFormatEtcList.GetItem (Index: Integer): TFormatEtcItem;
begin
  Result := TFormatEtcItem (inherited GetItem(Index))
end;

procedure TFormatEtcList.SetItem(Index: Integer; Value: TFormatEtcItem);
begin
  inherited SetItem (Index, Value)
end;

function TFormatEtcList.Add: TFormatEtcItem;
begin
  Result := TFormatEtcItem (inherited Add)
end;

function TFormatEtcList.GetOwner : TPersistent;
begin
  Result := FOwner
end;

//=== STANDARD FORMATETC ENUM USING THE COLLECTION =============================

constructor TStdEnumFormatEtc.Create (List : TFormatEtcList; Index : integer = 0);
begin
  inherited Create;
  FList := List;
  FIndex := Index
end;

destructor TStdEnumFormatEtc.Destroy;
begin
  inherited Destroy
end;

procedure TStdEnumFormatEtc.Next (Celt : integer; var FormatEtc : TFormatEtc; var Fetched, Result : integer);
var
  I : integer;
begin
  I := 0;
  while (I < Celt) and (FIndex < FList.Count) do
  begin
    FormatEtc := FList [FIndex].FormatEtc;
    inc (FIndex);
    inc (I)
  end;

  Fetched := I;

  if I <> Celt then
    Result := ddBad
end;

procedure TStdEnumFormatEtc.Next (var FormatEtc : TFormatEtc; var Result : integer);
var
  I : integer;
begin
  Next (1, FormatEtc, I, Result)
end;

procedure TStdEnumFormatEtc.Skip (Celt : integer; var Result : integer);
begin
  if Celt <= FList.Count - FIndex then
    FIndex := FIndex + Celt
  else begin
    FIndex := FList.Count;
    Result := ddBad
  end
end;

procedure TStdEnumFormatEtc.Reset (var Result : integer);
begin
  FIndex := 0
end;

procedure TStdEnumFormatEtc.Clone (var Enum : IEnumFormatEtc; var Result : integer);
begin
  Enum := TStdEnumFormatEtc.Create (FList, FIndex)
end;

end.