Контроль буфера обмена

Posted by maloy under Delphi, Архив

AndrzejX

Написал простую программку для контроля буфера — содержится ли там определённая текстовая фраза. Программка должна висеть в памяти, но при этом, естественно, не мешать обычной работе. Проверка:

try
 if ClipBoard.asText='Нужная фраза'
  then ...
except
end;

Всё работает. Но при попытке, например при работе в Word’е, поместить что-либо в буфер происходит задержка в несколько секунд. Это не называется «не мешать». Можно ли что-то сделать?

Somebody

Код:

uses
  Windows, Messages;
const
  HWND_MESSAGE = HWND(-3);
  WndClassName = 'ClipboardControlWndClass';
var
  hNextWindow: HWND;

function WndProc(hWindow: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
var
  hClipboardData: THandle;
  pData: PChar;
begin
  Result := 0;
  case Msg of
    WM_CREATE:
      hNextWindow := SetClipboardViewer(hWindow);
    WM_DESTROY:
    begin
      ChangeClipboardChain(hWindow, hNextWindow);
      PostQuitMessage(0);
    end;
    WM_CLOSE:
      DestroyWindow(hWindow);
    WM_CHANGECBCHAIN:
    begin
      if HWND(wParam) = hNextWindow then
        hNextWindow := HWND(lParam)
      else if hNextWindow <> 0 then
        SendMessage(hNextWindow, Msg, wParam, lParam);
    end;
    WM_DRAWCLIPBOARD:
    begin
      if IsClipboardFormatAvailable(CF_TEXT) and
        OpenClipboard(hWindow) then
      begin
        hClipboardData := GetClipboardData(CF_TEXT);
        if hClipboardData <> 0 then
        begin
          pData := GlobalLock(hClipboardData);
          if pData <> nil then
          begin
            if Pos('Hello', pData) <> 0 then
              Beep(2000, 100);
            GlobalUnlock(hClipboardData);
          end;
        end;
        CloseClipboard();
        if hNextWindow <> 0 then
          SendMessage(hNextWindow, Msg, wParam, lParam);
      end;
    end;
    else
      Result := DefWindowProc(hWindow, Msg, wParam, lParam);
  end;
end;

var
  WindowClass: WNDCLASS;
  Mess: MSG;
begin
  FillChar(WindowClass, SizeOf(WindowClass), 0);
  WindowClass.lpfnWndProc := @WndProc;
  WindowClass.hInstance := hInstance;
  WindowClass.lpszClassName := WndClassName;
  RegisterClass(WindowClass);
  CreateWindow(WndClassName, nil, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, hInstance, nil);
  while GetMessage(Mess, 0, 0, 0) do
    DispatchMessage(Mess);
  halt(Mess.wParam);
end.

тема на форуме от 2009 года