PC World 1999 February/PCWorld_1999-02_cd.bin/temacd/HotKeys/hkClpbrd.pas

Pascal/Delphi Source File | 1998-10-27 | 5KB | 238 lines

unit hkClpbrd;

interface

uses Classes, SysUtils, Windows, WComp;

type
  EClipboardError = class(Exception);

  TClipboards = class;

  TClipboardData = class(TObject)
    Format: UInt;
    Size  : DWord;
    Data  : THandle;
  public
    destructor DestroyMem; virtual;
  end;

  TClipboardHistory = class(TObject)
  private
    FFormats: TList;
    function CopyClipboardData(Format: UINT): TClipboardData;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Clear(FreeMemory: Boolean);

    procedure ReadClipboard;
    procedure WriteClipboard;

    property Formats: TList read FFormats;
  end;

  TClipboards = class(TObject)
  private
    FClipboards: TList;
    FActive: Integer;
    procedure SetActive(Value: Integer);
    function GetSize: Integer;
    procedure SetSize(Value: Integer);
  protected
    procedure Clear;
    procedure MakeClipboards(NumClips: Integer);
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure SwitchToClipboard(Clipboard: Integer; ReportError: Boolean);
    function  DataOnClipboard: Boolean;

    property NumClipboards: Integer read GetSize write SetSize default 5;
    property ActiveClipboard: Integer read FActive write SetActive;
  end;

implementation

{ TClipboards }
constructor TClipboards.Create;
begin
  inherited;
  FClipboards := TList.Create;
  FActive := 0;
  MakeClipboards(5);
end;

destructor TClipboards.Destroy;
begin
  Clear;
  FClipboards.Free;
end;

procedure TClipboards.Clear;
begin
  FActive := -1;
  MakeClipboards(0);
end;

procedure TClipboards.MakeClipboards(NumClips: Integer);
begin
  while FClipboards.Count>NumClips do
   begin
     TClipboardHistory(FClipboards[FClipboards.Count-1]).Free;
     FClipboards.Delete(FClipboards.Count-1);
   end;
  while FClipboards.Count<NumClips do FClipboards.Add(TClipboardHistory.Create);
  if FActive>FClipboards.Count-1 then SwitchToClipboard(FClipboards.Count-1, True);
end;

procedure TClipboards.SwitchToClipboard(Clipboard: Integer; ReportError: Boolean);
begin
  if (FActive<>Clipboard) then
   begin
     if (Clipboard<0) or (Clipboard>=FClipboards.Count) then
      begin
        if ReportError then
         raise EClipboardError.Create(IntToStr(Clipboard)+' is not a valid clipboard')
        else
         Clipboard := 0;
      end;
     if FActive<FClipboards.Count then TClipboardHistory(FClipboards[FActive]).ReadClipboard;
     FActive := Clipboard;
     TClipboardHistory(FClipboards[FActive]).WriteClipboard;
   end;
end;

function TClipboards.GetSize: Integer;
begin
  Result := FClipboards.Count;
end;

procedure TClipboards.SetSize(Value: Integer);
begin
  if (Value<>FClipboards.Count) then
   begin
     if (Value>=1) and (Value<=100) then
      MakeClipboards(Value)
     else
      raise EClipboardError.Create('Number of clipboards must be between 1 and 100');
   end;
end;

procedure TClipboards.SetActive(Value: Integer);
begin
  SwitchToClipboard(Value, True);
end;

function TClipboards.DataOnClipboard: Boolean;
begin
  OpenClipboard(0);
  try
    Result := EnumClipboardFormats(0)<>0;
  finally
    CloseClipboard();
  end;
end;

{ TClipboardHistory }

constructor TClipboardHistory.Create;
begin
  inherited Create;
  FFormats := TList.Create;
end;

destructor TClipboardHistory.Destroy;
begin
  Clear(True);
  FFormats.Free;
end;

procedure TClipboardHistory.Clear(FreeMemory: Boolean);
var
  i : integer;
begin
  for i:=0 to FFormats.Count-1 do
   if FreeMemory then
    TClipboardData(FFormats[i]).DestroyMem
   else
    TClipboardData(FFormats[i]).Destroy;
  FFormats.Clear;
end;

function TClipboardHistory.CopyClipboardData(Format: UINT): TClipboardData;
var
  ClipHandle : THandle;
  pClipHandle,
  pCopyHandle: Pointer;
begin
  ClipHandle := GetClipboardData(Format);
  if ClipHandle<>0 then
   begin
     Result := TClipboardData.Create;
     Result.Format := Format;
     Result.Size := GlobalSize(ClipHandle);
     Result.Data := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE or GMEM_ZEROINIT, Result.Size);
     pClipHandle := GlobalLock(ClipHandle);
     try
       pCopyHandle := GlobalLock(Result.Data);
       try
         CopyMemory(pCopyHandle, pClipHandle, Result.Size);
       finally
         GlobalUnlock(Result.Data);
       end;
     finally
       GlobalUnlock(ClipHandle);
     end;
   end
  else
   Result := nil;
end;

procedure TClipboardHistory.ReadClipboard;
var
  Format: UINT;
  Data  : TClipboardData;
begin
  Clear(True);
  OpenClipboard(0);
  try
    Format := EnumClipboardFormats(0);
    while Format<>0 do
     begin
       Data := CopyClipboardData(Format);
       if Data<>nil then FFormats.Add(Data);
       Format := EnumClipboardFormats(Format);
     end;
  finally
    CloseClipboard();
  end;
end;

procedure TClipboardHistory.WriteClipboard;
var
  i : integer;
begin
  OpenClipboard(0);
  try
    EmptyClipboard;
    for i:=0 to FFormats.Count-1 do
     with TClipboardData(FFormats[i]) do SetClipboardData(Format, Data);
    Clear(False);
  finally
    CloseClipboard();
  end;
end;

{ TClipboardData }

destructor TClipboardData.DestroyMem;
begin
  if (Data<>0) then GlobalFree(Data);
  inherited Destroy;
end;

end.