Как запечатлеть изменения буфера обмена от Lazarus? - PullRequest
Новая
       27

Как запечатлеть изменения буфера обмена от Lazarus?

1 голос
/ 22 марта 2011

Как я могу записать изменения, внесенные в буфер обмена из программы Lazarus в Windows. Например, чтобы сохранить историю буфера обмена в файл.

Спасибо

Ответы [ 3 ]

0 голосов
/ 08 февраля 2016

Я нашел это и сумел заставить его работать, но забыл сохранить его и теперь пытаюсь понять, как мне удалось заставить его работать: 

unit Unit1;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
  Clipbrd, StdCtrls, Windows, Messages;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FNextClipboardOwner: HWnd;   // handle to the next viewer
    // Here are the clipboard event handlers
    function WMChangeCBChain(wParam: WParam; lParam: LParam):LRESULT;
    function WMDrawClipboard(wParam: WParam; lParam: LParam):LRESULT;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}
var
  PrevWndProc:windows.WNDPROC;

function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam;
  lParam: LParam): LRESULT; stdcall;
begin
  if uMsg = WM_CHANGECBCHAIN then begin
    Result := Form1.WMChangeCBChain(wParam, lParam);
    Exit;
  end 
  else if uMsg=WM_DRAWCLIPBOARD then begin
    Result := Form1.WMDrawClipboard(wParam, lParam);
    Exit;
  end;
  Result := CallWindowProc(PrevWndProc, Ahwnd, uMsg, WParam, LParam);
end;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  PrevWndProc := Windows.WNDPROC(SetWindowLong(Self.Handle, GWL_WNDPROC, PtrInt(@WndCallback)));
  FNextClipboardOwner := SetClipboardViewer(Self.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ChangeClipboardChain(Handle, FNextClipboardOwner);
end;

function TForm1.WMChangeCBChain(wParam: WParam; lParam: LParam): LRESULT;
var
  Remove, Next: THandle;
begin
  Remove := WParam;
  Next := LParam;
  if FNextClipboardOwner = Remove then FNextClipboardOwner := Next
    else if FNextClipboardOwner <> 0 then
      SendMessage(FNextClipboardOwner, WM_ChangeCBChain, Remove, Next)
end;

function TForm1.WMDrawClipboard(wParam: WParam; lParam: LParam): LRESULT;
begin
  if Clipboard.HasFormat(CF_TEXT) Then Begin
    ShowMessage(Clipboard.AsText);
  end;
  SendMessage(FNextClipboardOwner, WM_DRAWCLIPBOARD, 0, 0);   // VERY IMPORTANT
  Result := 0;
end;

end.

Код выше http://wiki.lazarus.freepascal.org/Clipboard и в теории это должно работать.Он компилируется и запускается, но при изменении содержимого буфера обмена окно не появляется.Может быть, у кого-то здесь есть лучшие глаза, чтобы понять, почему.

0 голосов
/ 13 марта 2017

В Vista и более поздних версиях вы должны использовать AddClipboardFormatListener () вместо SetClipboardViewer ().
Этот рабочий пример, первоначально опубликованный на форумах Lazarus ASerge и Remy: Не реагирует на изменение буфера обмена - windows 

unit ClipboardListener;

{$mode objfpc}{$H+}

interface

uses
  Windows, Messages, Classes;

type
  { TClipboardListener }

  TClipboardListener = class(TObject)
  strict private
    FOnClipboardChange: TNotifyEvent;
    FWnd: HWND;
    class function GetSupported: Boolean; static;
    procedure WindowProc(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    property OnClipboardChange: TNotifyEvent read FOnClipboardChange
      write FOnClipboardChange;
    class property Supported: Boolean read GetSupported;
  end;

implementation

uses SysUtils, LCLIntf;

var
  AddClipboardFormatListener: function(Wnd: HWND): BOOL; stdcall;
  RemoveClipboardFormatListener: function(Wnd: HWND): BOOL; stdcall;

procedure InitClipboardFormatListener;
var
  HUser32: HMODULE;
begin
  HUser32 := GetModuleHandle(user32);
  Pointer(AddClipboardFormatListener) :=
    GetProcAddress(HUser32, 'AddClipboardFormatListener');
  Pointer(RemoveClipboardFormatListener) :=
    GetProcAddress(HUser32, 'RemoveClipboardFormatListener');
end;

{ TClipboardListener }

constructor TClipboardListener.Create;
begin
  inherited;
  if GetSupported then
  begin
    FWnd := LCLIntf.AllocateHWnd(@WindowProc);
    if not AddClipboardFormatListener(FWnd) then
      RaiseLastOSError;
  end;
end;

destructor TClipboardListener.Destroy;
begin
  if FWnd <> 0 then
  begin
    RemoveClipboardFormatListener(FWnd);
    LCLIntf.DeallocateHWnd(FWnd);
  end;
  inherited;
end;

class function TClipboardListener.GetSupported: Boolean;
begin
  Result := Assigned(AddClipboardFormatListener) and
    Assigned(RemoveClipboardFormatListener);
end;

procedure TClipboardListener.WindowProc(var Msg: TMessage);
begin
  if (Msg.msg = WM_CLIPBOARDUPDATE) and Assigned(FOnClipboardChange) then
  begin
    Msg.Result := 0;
    FOnClipboardChange(Self);
  end;
end;

initialization
  InitClipboardFormatListener;
end.



unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  ClipboardListener, Classes, Forms, StdCtrls;

type
  { TForm1 }

  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FListener: TClipboardListener;
    procedure ClipboardChanged(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.ClipboardChanged(Sender: TObject);
begin
   Memo1.Lines.Append(timetostr(Now)+' ['+Clipboard.AsText+']')   
// Memo1.Lines.Append('Clipboard changed');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FListener := TClipboardListener.Create;
  FListener.OnClipboardChange := @ClipboardChanged;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FListener.Free;
end;

end.
0 голосов
/ 23 марта 2011

В Lazarus то же самое, что и в любой среде разработки Windows. Вы должны добавить себя в цепочку просмотра буфера обмена.

В Интернете есть много статей, описывающих, как это сделать. Например:

...