別アプリケーションのRichTextの内容をコピーするには (ID：41922)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

時間があったので試してみました。
コールバック関数で内容をファイルに保存後、通知するようにしました。
共有メモリ的なものを使わずに簡単に済ませたかったので、少し見にくい
コードになっています。

(1)まずは、呼び出し側（フォームにTRichEditとTBottunが各１個）

const
  HkSub = 'Project1Sub.dll';  // フック用dll名

function StartHk(hHost: HWND): HHOOK; stdcall; external HkSub;
procedure StopHk(var hHk: HHOOK); stdcall; external HkSub;
function UserMsgID: DWORD; stdcall; external HkSub;

procedure TForm1.FormCreate(Sender: TObject);
begin
  hHk := 0;
  MsgID := UserMsgID;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  StopHk(hHk);
end;

procedure TForm1.WndProc(var AMsg: TMessage);
begin
  if AMsg.Msg=UserMsgID then begin
    if AMsg.WParam<>0 then
      SendMessage(HWND(AMsg.WParam), EM_STREAMOUT, SF_RTF, AMsg.LParam)
    else begin
      ShowMessage('コピーしました');
      StopHk(hHk);
//      PostMessage(HWND_BROADCAST, WM_NULL, 0, 0);
      RichEdit1.Lines.LoadFromFile(ExtractFilePath(ParamStr(0))+'tmpbuf.rtf');
    end;
  end;
  inherited WndProc(AMsg);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hTgtApp: HWND;
  Atm: ATOM;
begin
  if hHk=0 then hHk := StartHk(Handle);
  if hHk=0 then ShowMessage('フック失敗')
  else begin
    hTgtApp := FindWindow(nil,'TargetForm');
    Atm := GlobalAddAtom(PWideChar(ExtractFilePath(ParamStr(0))));
    if hTgtApp<>0 then PostMessage(hTgtApp, MsgID, WPARAM(Handle), LPARAM(Atm));
  end;
end;

(2)次にDLL側（dllプロジェクトの*.dprに直接貼り付け）

var
  FStreamRec: TEditStream;

function UserMsgID: DWORD; stdcall;
begin
  Result := RegisterWindowMessage('USER_MESSAGE22360679');
end;

function EditStreamCallBack(dwCookie: Longint; pbBuff: PByte;
                            cb: Longint; var pcb: Longint): Longint; stdcall;
var
  FStream: TMemoryStream;
  buf: array[0..MAX_PATH-1] of WideChar;
begin
  FStream := TMemoryStream.Create;
  pcb := FStream.Write(pbBuff^, cb);
  GlobalGetAtomName(ATOM(dwCookie), @buf, MAX_PATH);
  GlobalDeleteAtom(ATOM(dwCookie));
  FStream.SaveToFile(String(buf)+'tmpbuf.rtf');
  FStream.Free;
  PostMessage(HWND_BROADCAST, UserMsgID, 0, 0);
  Result := 0;
end;

function AHookProc(nCode:integer; wP: WPARAM; lP: LPARAM):LRESULT; stdcall;
var
  hRich: HWND;
  MsgID: DWORD;
begin
  if nCode=HC_ACTION then begin
    if wP=PM_NOREMOVE then begin
      MsgID := UserMsgID;
      if (PMsg(lP).message=MsgID) then begin
        if (PMsg(lP).wParam<>0) then begin
          hRich := FindWindowEx(FindWindow(nil,'RichEdTest'), 0, 'TRichEdit', nil);
          FStreamRec.dwCookie := PMsg(lP).lParam;
          FStreamRec.pfnCallback := @EditStreamCallBack;
          PostMessage(HWND(PMsg(lP).wParam), MsgID, WPARAM(hRich), LPARAM(@FStreamRec));
        end;
      end;
    end;
  end;
  Result := CallNextHookEx(0, nCode, wP, lP);
end;

function StartHk(hHost: HWND): HHOOK; stdcall;
begin
  Result := SetWindowsHookEx(WH_GETMESSAGE, Addr(AHookProc), HInstance, 0);
end;

procedure StopHk(var hHk: HHOOK); stdcall;
begin
  if hHk<>0 then UnhookWindowsHookEx(hHk);
  hHk := 0;
end;

exports
  StartHk,
  StopHk,
  UserMsgID;

失敗した時の処理を考えていないので、あくまでテスト用としてお考えください。

←解決時は質問者本人がここをチェックしてください。

戻る