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

名前

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

本文

やっぱりだめでした。
WndProcのSendMessage後に読み込み違反です。
呼び出し元のRichEdTest（同じ名前にしました）のソースです。
フォームForm2のキャプションは[RichEdTest]にしてあります。

宣言部も問題ないと思うんですが・・・

unit UnitDLLTest;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, RichEdit;

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

type
  TForm2 = class(TForm)
    Button1: TButton;
    RichEdit1: TRichEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    MsgID:DWord;
    hHK:HHook;
  protected
    procedure WndProc(var AMsg: TMessage);override;
  public
    { Public declarations }
  end;

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

var
  Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.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');//RichTextの内容を取得するウィンドウ
    Atm := GlobalAddAtom(PChar(ExtractFilePath(ParamStr(0))));
    if hTgtApp<>0 then PostMessage(hTgtApp, MsgID, WPARAM(Handle), LPARAM(Atm));
  end;
end;

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

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

procedure TForm2.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;

end.

//-----------------------------------------------------------
library Project1Sub;

{ DLL のメモリ管理に関する重要な注意：
  もしこの DLL が引数や返り値として String 型を使う関数/手続きをエクスポー
  トする場合、以下の USES 節とこの DLL を使うプロジェクトソースの USES 節
  の両方に、最初に現れるユニットとして ShareMem を指定しなければなりません。
  （プロジェクトソースはメニューから[プロジェクト｜ソース表示] を選ぶこと
  で表示されます）
  これは構造体やクラスに埋め込まれている場合も含め String 型を DLL とやり
  取りする場合に必ず必要となります。
  ShareMem は共用メモリマネージャである BORLNDMM.DLL とのインターフェース
  です。あなたの DLL と一緒に配布する必要があります。BORLNDMM.DLL を使うの
  を避けるには、PChar または ShortString 型を使って文字列のやり取りをおこ
  なってください。}
uses
  SysUtils,
  Classes,
  RichEdit,
  Windows;

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 Char;//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
  hTarget,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
          hTarget := 0;
          hRich   := 0;
          hTarget := FindWindow(nil,'RichEdTest');//RichTextの内容を貼り付ける呼び出し元ウィンドウ
          hRich := FindWindowEx(hTarget, 0, 'TRichEdit', nil);
          if hRich <> 0 then
          begin
            FStreamRec.dwCookie := PMsg(lP).lParam;
            FStreamRec.pfnCallback := @EditStreamCallBack;
            PostMessage(HWND(PMsg(lP).wParam), MsgID, WPARAM(hRich), LPARAM(@FStreamRec));
          end;
        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;

{$R *.res}

begin
end.

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

戻る