cliboarddate.pas

类似Wor剪切板收集器的功能。由于时间关系只做了部分剪切板数据的收集

unit CliBoardDate;

interface
uses
  Clipbrd, Windows, Classes, Graphics;

type
  TClipBoradFormatData = record
    Size: Integer;
    Data: PChar;
    Format: Integer;
  end;

  PClipBoardData = ^TClipBoardDate;
  TClipBoardDate = record
    ID: string;
    nCount: Integer;
    bitmap: TBitmap;
    MemDataArr: array of TClipBoradFormatData;
  end;

  TClipBoardMgr = class
  private
    FToAdd: Boolean;
    FDataList: TList;
    function HasFormate(index, f: Integer): Integer;
    function FetchClipBoardDataAtom(Index: Integer): PClipBoardData;
  public
    function AddClipBoardData: string;
    function AllowAdd: Boolean;
    procedure StopAdd;
    procedure ReStoreAdd;
    function IndexofData(ID: String): Integer;
    function HasBitMap(Index:Integer): Integer;
    function AssignDataToClipBoard(Index: Integer): Boolean;
    procedure FetchBitmap(var BitMap: TBitmap; index: Integer);
    procedure MakeDataPreview(canvas: TCanvas; ARect: TRect; Index: Integer);
    constructor Create;
    destructor Destroy; override;
  end;
implementation

uses
  SysUtils;

{ TClipBoardMgr }
type
   _ClipBoard = Class(TClipboard);

function TClipBoardMgr.AddClipBoardData: string;
var
  I, f: Integer;
  pData:          PChar;
  lpData:         PClipBoardData;
  cbfData:        TClipBoradFormatData;
  h:              THandle;
begin
  if FToAdd then
  begin
    Clipboard.Open;
    New(lpData);
    try
      Randomize;
      lpData.ID := DateTimeToStr(Now) + IntToStr(Random(10000));
      lpData^.nCount := Clipboard.FormatCount;
      SetLength(lpData^.MemDataArr, Clipboard.FormatCount);
      lpData.bitmap := nil;
      for I := 0 to Clipboard.FormatCount - 1 do
      begin
        if not Assigned(lpData.bitmap) and ((Clipboard.Formats[I] = CF_BITMAP) or (Clipboard.Formats[I] = CF_DIB)) then
        begin
          lpData.bitmap := TBitmap.Create;
          _ClipBoard(Clipboard).AssignTo(lpData^.bitmap);
        end;
        FillChar(cbfData, SizeOf(cbfData), 0);
        f := Clipboard.Formats[I];
        h := GetClipboardData(f);
        if h <> 0 then
        begin
          cbfData.Format := f;
          cbfData.Size := GlobalSize(h);
          GetMem(cbfData.Data, cbfData.Size);
          try
            pData := GlobalLock(h);
            Move(pData^, cbfData.Data^, cbfData.Size);
          finally
            GlobalUnlock(h);
          end;
        end;
        lpData.MemDataArr[I] := cbfData;
      end;
      FDataList.Add(lpData);
    finally
      Result := lpData.ID;
      Clipboard.Close;
    end;
  end;
end;

function TClipBoardMgr.AllowAdd: Boolean;
begin
  Result := FToAdd;
end;

function TClipBoardMgr.AssignDataToClipBoard(Index: Integer): Boolean;
var
  cbfData: TClipBoradFormatData;
  lpcbData: PClipBoardData;
  h: HGLOBAL;
  pData: PChar;
  I: Integer;
begin
  lpcbData := FetchClipBoardDataAtom(Index);
  Result := False;
  if lpcbData = nil then
    Exit;

  for I := 0 to lpcbData^.nCount - 1 do
  begin
    cbfData := lpcbData^.MemDataArr[I];
    Clipboard.Open;
    try
      EmptyClipboard;
      h := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, cbfData.Size);
      if h <> 0 then
      begin
        pData := GlobalLock(h);                   
        Move(cbfData.Data^, pData^, cbfData.Size);
        SetClipboardData(cbfData.Format, h);
        GlobalUnlock(h);
      end;
    finally
      Clipboard.Close;
    end;
  end;
end;

constructor TClipBoardMgr.Create;
begin
  FToAdd := True;
  FDataList := TList.Create;
end;

destructor TClipBoardMgr.Destroy;
begin

  inherited;
end;

procedure TClipBoardMgr.FetchBitmap(var BitMap: TBitmap; index: Integer);
var
  lpClpData: PClipBoardData;
begin
  lpClpData := FDataList.Items[index];
  if Assigned(lpClpData.bitmap) then
    BitMap := lpClpData.bitmap;
end;

function TClipBoardMgr.FetchClipBoardDataAtom(Index: Integer): PClipBoardData;
begin
  Result := nil;
  if Index > FDataList.Count - 1 then
    Exit;

  Result := FDataList.Items[Index];
end;

function TClipBoardMgr.HasBitMap(Index:Integer): Integer;
begin
  Result := HasFormate(index, CF_BITMAP);
end;

function TClipBoardMgr.HasFormate(index, f: Integer): Integer;
var
  lpClpData: PClipBoardData;
  I: Integer;
begin
  Result := -1;
  lpClpData := FDataList.Items[Index];
  for I := 0 to lpClpData.nCount - 1 do
  begin
    if lpClpData.MemDataArr[I].Format = f then
    begin
      Result := I;
      Exit;
    end;
  end;
end;

function TClipBoardMgr.IndexofData(ID: String): Integer;
var
  I: Integer;
  lpData: PClipBoardData;
begin
  Result := 0;
  for I := 0 to fdatalist.Count - 1 do
  begin
    lpData := FDataList.Items[I];
    if lpData.ID = ID then
    begin
      Result := I;
      Exit;
    end;
  end;
end;

procedure TClipBoardMgr.MakeDataPreview(canvas: TCanvas; ARect: TRect; Index: Integer);
var
  lpCbData: PClipBoardData;
  nhRate, nwRate: Integer;
  ncbDataIndex: Integer;
  tmpStr: PChar;
  nStrLength, nTextWidth: Integer;
  Metrics: TTextMetric;
  tmpRect: TRect;

  procedure DrawText(const Text: PChar);
  var
    str: string;
  begin
    str := Text;
    if Length(str) > 15 then
      str := Copy(str, 1, 15) + '...'
    else
      str := Text;
    canvas.TextOut(ARect.Left + 10, ARect.Top + 17, str);
  end;
begin
  lpCbData := FetchClipBoardDataAtom(Index);
  if Assigned(lpCbData) then
  begin
    ncbDataIndex := HasFormate(Index, CF_TEXT);
    if ncbDataIndex >= 0 then
    begin
      tmpStr := PChar(FetchClipBoardDataAtom(Index).MemDataArr[ncbDataIndex].Data);
      canvas.Brush.Style := bsClear;
      DrawText(tmpStr);
    end;
    if Assigned(lpCbData.bitmap) then
    begin
      if (tmpStr <> nil)  then
        nStrLength := 0
      else
      if (Length(tmpStr) > 15) then
        nStrLength := 18
      else
        nStrLength := Length(tmpStr);
      GetTextMetrics(canvas.Handle, Metrics);
      nTextWidth := nStrLength*Metrics.tmAveCharWidth;

      nhRate := lpCbData.bitmap.Height div (ARect.Bottom - ARect.Top - 8);
      nwRate := lpCbData.bitmap.Width div (ARect.Right - ARect.Left - 8);
      if nhRate > nwRate then
      begin
        tmpRect := Rect(ARect.Left + nTextWidth + 4, ARect.Top + 4,
        ARect.Left + nTextWidth + 4 + lpCbData.bitmap.Width div nhRate, ARect.Bottom - 4);
        canvas.StretchDraw(tmpRect, lpCbData.bitmap);
      end;
    end;
  end;
end;

procedure TClipBoardMgr.ReStoreAdd;
begin
  FToAdd := True;
end;

procedure TClipBoardMgr.StopAdd;
begin
  FToAdd := False;
end;

end.