监视剪贴版

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, ExtCtrls, StdCtrls, Clipbrd;

type

  TForm1 = class(TForm)

    mmo1: TMemo;

    btnMonitor: TButton;

    lbl1: TLabel;

    lbl2: TLabel;

    chk1: TCheckBox;

    procedure btnMonitorClick(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  private

    { Private declarations }

    hCbChain:HWND;

    bMonitoring:Boolean;

  public

    { Public declarations }

    procedure AppendClipboard;

    procedure OnClipboardChanged(var cbMsg:TWMDrawClipboard); message WM_DRAWCLIPBOARD;

    procedure OnChangeCbChain(var cbMsg:TWMChangeCbChain); message WM_CHANGECBCHAIN ;

    PROCEDURE ShowErrorMessageByErrorNum(iErrNum:Integer);

  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.AppendClipboard;

begin

   if chk1.Checked then

      mmo1.Text :=  mmo1.Text +#13#10 + Clipboard.AsText

   else

      mmo1.Text := Clipboard.AsText + #13#10 + mmo1.Text;

      

   lbl1.Caption := IntToStr(StrToInt(lbl1.Caption)+1);

end;

procedure TForm1.btnMonitorClick(Sender: TObject);

var

  hTmpHand:HWND;

  iErrNum:Integer;

begin

   if bMonitoring then

     begin

      hTmpHand := hCbChain;

      hCbChain := 0;

      ChangeClipboardChain(handle, hTmpHand);

      btnMonitor.Caption := '&Monitor Clipboard';

      bMonitoring := False;

     end

   else

     begin

        hCbChain := SetClipboardViewer(handle);

        mmo1.Text := '';

        lbl1.Caption := '0';

        iErrNum := GetLastError();

         if iErrNum<>0 then

            begin

              ShowErrorMessageByErrorNum(iErrNum);

            end

         else

            begin

              bMonitoring := True;

              btnMonitor.Caption := '&Stop monitor';

            end;

     end;

end;

procedure TForm1.OnClipboardChanged(var  cbMsg: TWMDrawClipboard);

begin

    AppendClipboard;

    if (hCbChain<>handle)and(hCbChain<>0) then SendMessage(hCbChain, WM_DRAWCLIPBOARD, 0, 0);

    cbMsg.Result := 1;

end;

procedure TForm1.OnChangeCbChain(var cbMsg: TWMChangeCbChain);

begin

  if cbMsg.Remove= hCbChain then

    begin

     hCbChain := cbMsg.Next;

     cbMsg.Result := 0;

    end

  else

    begin

      SendMessage(hCbChain, WM_CHANGECBCHAIN, cbMsg.Remove, cbMsg.Next);

      cbMsg.Result := 0;

    end;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

  hSysMenu:HMENU;

begin

   hCbChain := 0;

  hSysMenu := GetSystemMenu(handle, False);

  if hSysMenu<>0 then

    begin

      AppendMenu(hSysMenu, MF_SEPARATOR, 0, nil);

      AppendMenu(hSysMenu, MF_STRING, 201, '&Always on top');

    end;

end;

procedure TForm1.ShowErrorMessageByErrorNum(iErrNum: Integer);

var

  hLoc: HLOCAL;

  pSrc: POINTER;

  iFormatErr:Integer;

begin

  hLoc := 0;

  pSrc := nil;

  iFormatErr := FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ALLOCATE_BUFFER,

                pSrc, iErrNum, 0,@hLoc , 100, nil);

  if iFormatErr= 0 then

      begin

        ShowMessage(Format('Format Error:Error %d', [GetLastError()]));

        if hLoc<>0 then LocalFree(hLoc);

        exit;

      end;

     

  MessageBox(GetForegroundWindow(), PCHAR(hLoc), 'Error Found', MB_OK + MB_ICONINFORMATION);

  LocalFree( hLoc );

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

   if bMonitoring then

     btnMonitorClick(Sender);

end;

end.