クリップボードの監視でテキストを取得すると「アクセスが拒否されました」と表示される

解決

take 2022-10-18 01:50:24 No: 150585 IP: 192.*.*.*

クリップボードを監視して、クリップボードに変化があったらそのテキストを取得するプログラムを作っています。
普段は問題が無いのですが
GoogleChromeのURLの部分でコピー操作を行うと「アクセスが拒否されました」と表示されます。

原因は
WM_DRAWCLIPBOARDメッセージで Clipboard.HasFormat(CF_TEXT)のものが連続で2回発生し
プログラムがGetText でテキストを取得する処理中に再度GetTextが呼ばれるようです
※ブレイクポイントで止めてデバッグすると発生しないのでうまく追えません

GetTextが同時に2回呼ばれないなどの処理を追加しても駄目でした。

エラーが出なくなる良い方法はありますでしょうか？

環境：Windows10 DelphiXE5 Delphi10.4

interface

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

type
  TClipboardEx = class(TPersistent)
  private
    FHandle      : HWND;
    FHandleNext  : HWND;
    FOnChangeText: TNotifyEvent;
    procedure Draw();
    procedure WndProc(var Msg: TMessage);
    function GetText: string;
  protected
    procedure DoChangeText();
  public
    { Public 宣言 }
    constructor Create();
    destructor Destroy;override;
    // 監視開始
    procedure Open();
    // 監視終了
    procedure Close();
    property Text : string read GetText;
  published
    property OnChangeText  : TNotifyEvent  read FOnChangeText write FOnChangeText;
  end;

{ TClipboardEx }

constructor TClipboardEx.Create;
begin
  FHandle := AllocateHWnd(WndProc);
end;

destructor TClipboardEx.Destroy;
begin
  DeallocateHWND(FHandle);
  inherited;
end;

procedure TClipboardEx.Open;
begin
  FHandleNext := SetClipboardViewer(FHandle);
end;

procedure TClipboardEx.Close;
begin
  ChangeClipboardChain(FHandle, FHandleNext);
end;

procedure TClipboardEx.DoChangeText;
begin
  if Assigned(FOnChangeText) then begin
    FOnChangeText(Self);
  end;
end;

procedure TClipboardEx.Draw;
begin
  if Clipboard.HasFormat(CF_TEXT) then begin
    DoChangeText();
  end;
end;

function TClipboardEx.GetText: string;
var
  MyHandle : THandle;
begin
  ClipBoard.Open;
  MyHandle := Clipboard.GetAsHandle(CF_TEXT);
  try
    result := Clipboard.AsText;
  finally
    GlobalUnlock(MyHandle);
  end;
  Clipboard.Close;
end;

procedure TClipboardEx.WndProc(var Msg: TMessage);
var
  MsgC : TWMChangeCBChain;
begin
  if (Msg.Msg = WM_DRAWCLIPBOARD)  then begin
    Draw();
  end
  else if (Msg.Msg = WM_CHANGECBCHAIN) then begin
    MsgC := TWMChangeCBChain(Msg);
    FHandle := MsgC.Next;
    Msg.Result := 0;
  end;
  Msg.Result := DefWindowProc(FHandleNext,Msg.Msg,Msg.wParam, Msg.lParam);
end;

// メインフォーム
  private
    { Private 宣言 }
    FClip : TClipboardEx;
・・・
procedure TFormMain.FormCreate(Sender: TObject);
begin
  FClip := TClipboardEx.Create;
  FClip.OnChangeText := OnClipboardChange;
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  FClip.Free;
end;

procedure TFormMain.FormShow(Sender: TObject);
begin
  FClip.Open;
end;

procedure TFormMain.OnClipboardChange(Sender: TObject);
begin
  ListBox1.Items.Add(FClip.Text);
end;