クリップボードの監視でテキストを取得すると「アクセスが拒否されました」と表示される
解決クリップボードを監視して、クリップボードに変化があったらそのテキストを取得するプログラムを作っています。
普段は問題が無いのですが
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;
http://delfusa.main.jp/delfusafloor/archive/www.nifty.ne.jp_forum_fdelphi/samples/00023.html
//ｸﾘｯﾌﾟﾎﾞｰﾄﾞのﾃﾞｰﾀが書き変えられた時の処理
procedure TForm1.WmDrawClipboard(var msg: TWmDrawClipboard);
var
Tmp:string;
begin
//次のｳｨﾝﾄﾞｳに同じﾒｯｾｰｼﾞを送る
SendMessage(hNext, WM_DRAWCLIPBOARD, 0, 0);
//ｸﾘｯﾌﾟﾎﾞｰﾄﾞにﾃｷｽﾄﾃﾞｰﾀがあれば取得する。
if Clipboard.HasFormat(CF_TEXT) then Tmp:= ClipBoard.AsText else Exit;
//ﾘｽﾄﾎﾞｯｸｽに未登録のﾃﾞｰﾀであれば新規に登録する。
with ListBox1.Items do
if IndexOf(Tmp)=-1 then if Count= 0 then Add(Tmp) else Insert(0,Tmp);
end;
//ｸﾘｯﾌﾟﾎﾞｰﾄﾞﾋﾞｭｰﾜﾁｪｲﾝが変更された時の処理
procedure TForm1.WmChangeCBChain(var mes: TWmChangeCBChain);
begin
//次のｳｨﾝﾄﾞｳが削除された場合は、その次のｳｨﾝﾄﾞｳのﾊﾝﾄﾞﾙを取得し直す。
if mes.Remove = hNext then hNext:= mes.Next; //パット見 ここが無いかな
//次のｳｨﾝﾄﾞｳに同じﾒｯｾｰｼﾞを送る
SendMessage(hNext, WM_CHANGECBCHAIN, mes.Remove, mes.Next);
mes.Result:= 0;
end;
AAAAA様へ
リンク先の
「玉石混淆みんなで作るSample蔵」のサンプルをそのままコピーして試したところ
同じく「アクセスが拒否されました」と表示されます
WmChangeCBChainの処理が悪いのかブレークポイントをトリガーにしましたがここには飛びません
WM_DRAWCLIPBOARDメッセージのCF_TEXTが連続で来てしまうので
サンプルの処理に 1msのスリープ命令を入れるとエラーが出なくなります
WM_DRAWCLIPBOARDメッセージからイベントの発生まで遅延を設けて
CF_TEXTの連続処理を防ぐしかないものなのでしょうか？
procedure TFormMain.WmDrawClipboard(var msg: TWmDrawClipboard);
var
Tmp:string;
begin
//次のｳｨﾝﾄﾞｳに同じﾒｯｾｰｼﾞを送る
SendMessage(hNext, WM_DRAWCLIPBOARD, 0, 0);
// 追加
sleep(1);
//ｸﾘｯﾌﾟﾎﾞｰﾄﾞにﾃｷｽﾄﾃﾞｰﾀがあれば取得する。
if Clipboard.HasFormat(CF_TEXT) then Tmp:= ClipBoard.AsText else Exit;
//ﾘｽﾄﾎﾞｯｸｽに未登録のﾃﾞｰﾀであれば新規に登録する。
with ListBox1.Items do
if IndexOf(Tmp)=-1 then if Count= 0 then Add(Tmp) else Insert(0,Tmp);
end;
「アクセスが拒否されました」が出なくするには
try except で囲めばでなくなります。
Mr.XRAY さんはご不在のようですので（勝手な妄想）、（申し訳ありませんが）勝手に紹介
貼り付け操作可否のチェック - クリップボードの監視
http://mrxray.on.coocan.jp/Delphi/plSamples/823_PasteCheck.htm#00
のリスト2 ではないでしょうか。
ちょい上には、 「クリップボード アクセスが拒否されました。 を開けません.」が出るとの記載もあります。
カミーユさんへ
Mr.XRAYさんのサイトからサンプルをDLして
01_ClipboardFormat
を実行してみたところ、メモ帳でもブラウザでも
CF_TEXT と CF_UNICODETEXT のデータが送られてくるだけで両者に違いはありませんでした
サイトを読むと、この処理に
if Clipboard.HasFormat(CF_TEXT) then S := Clipboard.AsText;
を加えると
「クリップボード アクセスが拒否されました。 を開けません.」
というエラーが発生して，取得できません．
と書かれていますので今回のはこの現象ですね
「アクセス拒否 ?」と書かれていてその下の文章では
実際にクリップボードからデータを取得するコードは，アプリケーションの [貼り付け] ボタン等を使用することになるでしょう
となっていますので未解決かもしれませんね。
> のリスト2 ではないでしょうか。
^^^^^^^^ これ試しました？
うちの環境じゃ、ダウンロードさせてくれなくて、試すことができません。
Delphi の TClipboard を使用して WM_DRAWCLIPBOARD メッセージ内でクリップボードのテキストを取得するには，例えば次のようなコードで取得できます．
と、なっています。
> うちの環境じゃ、ダウンロードさせてくれなくて、試すことができません。
これはサンプルのダウンロード件
ありがとうございます。
リンクの名称が今回の件に該当しないと思って読み飛ばしていました。
このリンクの一番下の記事ですね。
http://mrxray.on.coocan.jp/Delphi/plSamples/670_SendTextThreadAttach.htm#06
サンプルを見ると処理が飛んできても最初の1回しか処理してないように見えますね。
あんまりスッキリとした対策ではないのでもうちょっと色々やってみます。
サンプルのDLはEXEが含まれているせいか警告が出ます
procedure TForm1.WMDrawClipboard(var Message: TWMDrawClipboard);
begin
if not FReceiveFlag then exit;
if (Clipboard.HasFormat(CF_TEXT)) then begin
Memo1.Text := Clipboard.AsText;
SetForegroundWindow(Handle);
FReceiveFlag := False;
end;
end;
単純にこれでよいんでない？
procedure TForm1.WmDrawClipboard(var msg: TWmDrawClipboard);
begin
if Clipboard.HasFormat(CF_TEXT) then
begin
try
ListBox1.Items.Add(ClipBoard.AsText);
except
end;
end;
SendMessage(hNext, WM_DRAWCLIPBOARD, 0, 0);
end;
GoogleChromeのURLの部分でコピー操作でも 例外発生しない事もあるけど
うーん、前回の回答のときにちゃんと答えておいた方が良かったかな
質問
xxxの処理でyyyを実行するとエラーが出ることがあります
どこに原因があるのでしょうか？
回答
try except end;
を使ってエラー表示が出ないようにしましょう
全然解決になってませんよ・・・
原因聞いてたのか
原因は簡単で GoogleChrome が URL からコピーすると２回送ってるから
（Edge も同じことが起こる）
そして
WmDrawClipboardが多重で送られてくるから（処理抜ける前に次のWmDrawClipboardが送られてくる）
送信側がopen中に受信側がOpenしてるから
受信アプリ以外から
Clipboard.AsText := 'AAAA';
Clipboard.AsText := 'BBBB';
Clipboard.AsText := 'CCCC';
Clipboard.AsText := 'DDDD';
とかやればわかる
var tmp2: String;
procedure TForm1.WmDrawClipboard(var msg: TWmDrawClipboard);
var
Tmp:string;
begin
Sleep(10); //1でも平気ぽいけど
SendMessage(hNext, WM_DRAWCLIPBOARD, 0, 0);
if Clipboard.HasFormat(CF_TEXT) then
begin
Tmp:= ClipBoard.AsText;
if Tmp <> '' then
begin
if tmp <> tmp2 then ListBox1.Items.Add(Tmp); //連続した同じ内容は出力しない
Tmp2 := Tmp;
end;
end;
end;
> 原因は簡単で GoogleChrome が URL からコピーすると２回送ってるから
http://mrxray.on.coocan.jp/Delphi/plSamples/823_PasteCheck.htm#list2
のコードでやってみました．
2 つ同じ URL が表示されました．
知りませんでした．
FireFox , Microsoft Edge, Google Chrome 共です．
> FireFox , Microsoft Edge, Google Chrome 共です．
失礼しました．
FireFox は 1 つだけでした．
AAAAAさん、ありがとうございます。
最初の質問にありますように
>WM_DRAWCLIPBOARDメッセージで Clipboard.HasFormat(CF_TEXT)のものが連続で2回発生し
ということで、これを抑えられないかということなのですが
提示して頂いた例を試すと共に、簡単なサンプルで試してみたいと思います。
今回、使用するツールでは
同じ内容のものでも、それを処理する必要があるので
別の対策も必要そうです
再度，現象を確認してみました．
解決策ではありません．
なかなか難しそうです．
[ 08_クリップボードにコピーしたテキストを自動取得 ]
http://mrxray.on.coocan.jp/Delphi/plSamples/823_PasteCheck.htm#08
何種類か試しました。
「玉石混淆みんなで作るSample蔵」にあるサンプルで WmDrawClipboardの処理を
下記の様に再入防止処理を追加するとエラーが出なくなります。
procedure TFormMain.WmDrawClipboard(var msg: TWmDrawClipboard);
var
Tmp:string;
begin
SendMessage(hNext, WM_DRAWCLIPBOARD, 0, 0);
if Clipboard.HasFormat(CF_TEXT) then Tmp:= ClipBoard.AsText else Exit;
if FBusy then exit;
FBusy := True;
ListBox1.Items.Add(Tmp);
FBusy := False;
end;
次に質問したとき、専用のクラスにしたときの WndProcの処理に同じように再入防止をしてもエラーが出ます。
procedure TClipboardEx.WndProc(var Msg: TMessage);
var
MsgC : TWMChangeCBChain;
begin
if (Msg.Msg = WM_DRAWCLIPBOARD) then begin
SendMessage(FHandleNext, WM_DRAWCLIPBOARD, 0, 0);
if FBusy then exit;
FBusy := True;
DoChangeText();
FBusy := False;
end
else if (Msg.Msg = WM_CHANGECBCHAIN) then begin
MsgC := TWMChangeCBChain(Msg);
if MsgC.Remove = FHandleNext then FHandleNext:= MsgC.Next;
SendMessage(FHandleNext, WM_CHANGECBCHAIN, MsgC.Remove, MsgC.Next);
Msg.Result := 0;
end;
//Msg.Result := DefWindowProc(FHandleNext,Msg.Msg,Msg.wParam, Msg.lParam);
end;
ハンドルを独自に作るのがダメなのかとTWinControlから継承して作っても エラーが出ます。
色々試していますが、別の現象が発生するようなので悩むぐらいならsleep(10)を使うのが最適なのかも
なんか しっくりきませんね。
(一度クリップボード関係のメッセージを受けて、メッセージが来なくなってから処理するとか？)
type
TClipboardEx2 = class(TWinControl)
private
FHandleNext : HWND;
FBusy : Boolean;
FOnChangeText: TNotifyEvent;
function GetText: string;
procedure WmDrawClipboard(var msg: TWmDrawClipboard); Message WM_DRAWCLIPBOARD;
procedure WmChangeCBChain(var mes: TWmChangeCBChain); Message WM_CHANGECBCHAIN;
protected
procedure DoChangeText();
public
{ Public 宣言 }
// 監視開始
procedure Open();
// 監視終了
procedure Close();
property Text : string read GetText;
published
property OnChangeText : TNotifyEvent read FOnChangeText write FOnChangeText;
end;
procedure TClipboardEx2.Open;
begin
FHandleNext := SetClipboardViewer(Handle);
end;
procedure TClipboardEx2.Close;
begin
ChangeClipboardChain(Handle, FHandleNext);
end;
procedure TClipboardEx2.DoChangeText;
begin
if Assigned(FOnChangeText) then begin
FOnChangeText(Self);
end;
end;
function TClipboardEx2.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 TClipboardEx2.WmChangeCBChain(var mes: TWmChangeCBChain);
begin
if mes.Remove = FHandleNext then FHandleNext:= mes.Next;
SendMessage(FHandleNext, WM_CHANGECBCHAIN, mes.Remove, mes.Next);
mes.Result:= 0;
end;
procedure TClipboardEx2.WmDrawClipboard(var msg: TWmDrawClipboard);
begin
SendMessage(FHandleNext, WM_DRAWCLIPBOARD, 0, 0);
//sleep(1);
if Clipboard.HasFormat(CF_TEXT) then begin
if FBusy then exit;
FBusy := True;
DoChangeText;
FBusy := False;
end;
end;
あれからいくつかの方法で試しましたが解決せず
スリープ命令で少し待つというのが一番安定しました。
これで解決とさせて頂きます、ありがとうございました。
| ツイート |  |