unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    RichEdit1: TRichEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses RichEdit, CommonMemoryUnit;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  RichEdit1.ScrollBars    := ssBoth;
  RichEdit1.HideSelection := False;
end;

//=============================================================================
//  [受信]ボタンクリック
//  他のアプリのRichEditのリッチテキストを，自アプリのRichEditで受信
//  クリップボードを使用した方法
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  hTargetApp   : HWND;
  hRich        : HWND;
  CommMem      : TCommMemNT;
  CharRangeRec : TCharRange;
  RangeLen     : Integer;
  TextLenRec   : TGetTextLengthEx;
  TextLen      : Integer;
begin
  //送信側である，他のアプリのハンドルを取得
  hTargetApp := FindWindow(nil, 'TargetForm');
  if hTargetApp = 0 then exit;

  //送信側のRichEditのハンドルを取得
  hRich := FindWindowEx(hTargetApp, 0, 'TRichEdit', nil);
  if hRich = 0 then exit;


  //他のアプリの情報取得または設定のための構造体に使用する共有メモリ生成
  CommMem := TCommMemNT.Create(hRich, 500);
  try
    //テキストが選択中かを調査
    SendMessage(hRich, EM_EXGETSEL, 0, LPARAM(CommMem.MemPtr));
    CommMem.Read(0, @CharRangeRec, SizeOf(CharRangeRec));
    RangeLen := CharRangeRec.cpMax - CharRangeRec.cpMin;

    if RangeLen = 0 then begin
      //テキスト全体の長さを取得
      TextLenRec.flags    := GTL_DEFAULT;
      TextLenRec.codepage := CP_ACP;
      CommMem.Write(0, @TextLenRec, SizeOf(TextLenRec));
      TextLen := SendMessage(hRich, EM_GETTEXTLENGTHEX, WPARAM(CommMem.MemPtr), 0);

      //その長さ分選択状態にする
      CharRangeRec.cpMin := 0;
      CharRangeRec.cpMax := TextLen;
      CommMem.Write(0, @CharRangeRec, SizeOf(CharRangeRec));
      SendMessage(hRich, EM_EXSETSEL, 0, LPARAM(CommMem.MemPtr));
    end;
  finally
    CommMem.Free;
  end;

  //コピー操作のメッセージを送る
  SendMessage(hRich, WM_COPY, 0, 0);
  RichEdit1.Clear;
  //クリップボードから貼り付け
  RichEdit1.PasteFromClipboard;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    ApplicationEvents1: TApplicationEvents;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
  private
    { Private 宣言 }
    MsgID : DWORD;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  DLLName = 'GetRichText.dll';

  function StartHookOtherRich(hWnd, hSelfRich, hTargetApp, hTargeRich: HWND):
      DWORD; stdcall; external DLLName;
  procedure StopHookOtherRich; stdcall; external DLLName;
  function SendToOtherRich(hSenderApp, hSenderRich, hReceiveRich: HWND):
      DWORD; stdcall; external DLLName;

//=============================================================================
//  フォームのOnDestroyイベントでフック終了
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  StopHookOtherRich;
end;

//=============================================================================
//  [受信]
//  他のアプリのTRichEditのリッチテキストを，自アプリのTRichEditで受信
//  最初に RichEdit1.Lines.Clear; を実行して上書きモードで受信
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  hTargetApp : HWND;
  hRich      : HWND;
begin
  //ここを削除すれば挿入モードになる
  RichEdit1.Lines.Clear;

  hTargetApp := FindWindow(nil, 'TargetForm');
  if hTargetApp = 0 then exit;

  hRich := FindWindowEx(hTargetApp, 0, 'TRichEdit', nil);
  if hRich <> 0 then begin
    MsgID := StartHookOtherRich(Handle, RichEdit1.Handle, hTargetApp, hRich);
  end;
end;

//=============================================================================
//  [送信]
//  自アプリのTRichEditのリッチテキストを，他のアプリのTRichEditに送信
//  ここでは，他のアプリのテキストをクリアしてから送信．つまり上書き
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  hTargetApp : HWND;
  hRich      : HWND;
begin
  hTargetApp := FindWindow(nil, 'TargetForm');
  if hTargetApp = 0 then exit;

  hRich := FindWindowEx(hTargetApp, 0, 'TRichEdit', nil);
  if hRich <> 0 then begin
    //他のアプリのテキストをクリア
    //ここを削除すれば挿入モードとなる
    SendMessage(hRich, WM_SETTEXT, 0, LPARAM(nil));
    //送信
    MsgID := SendToOtherRich(Handle, RichEdit1.Handle, hRich);
  end;
end;

//=============================================================================
//  TApplicationEventsコンポのOnMessageイベント処理
//  DLL内の処理終了の通知を受け取ったらフック終了
//=============================================================================
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if Msg.message = MsgID then begin
    StopHookOtherRich;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, RichEdit, AppEvnts, ExtCtrls, JvExStdCtrls,
  JvRichEdit;

type
  TForm1 = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    JvRichEdit1: TJvRichEdit;
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
  private
    { Private 宣言 }
    MsgID : DWORD;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  DLLName = 'GetRichText.dll';

  function StartHookOtherRich(hWnd, hSelfRich, hTargetApp, hTargeRich: HWND):
      DWORD; stdcall; external DLLName;
  procedure StopHookOtherRich; stdcall; external DLLName;
  function SendToOtherRich(hSenderApp, hSenderRich, hReceiveRich: HWND):
      DWORD; stdcall; external DLLName;

//=============================================================================
//  フォームのOnDestroyイベントでフック終了
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  StopHookOtherRich;
end;

//=============================================================================
//  [受信]
//  他のアプリのTJvRichEditのリッチテキストを，自アプリのTJVRichEditで受信
//  最初に RichEdit1.Lines.Clear; を実行して上書きモードで受信
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  hTargetApp : HWND;
  hRich      : HWND;
begin
  JvRichEdit1.Lines.Clear;

  hTargetApp := FindWindow('TJVCL_RichEditForm', nil);
  if hTargetApp = 0 then exit;

  hRich := FindWindowEx(hTargetApp, 0, 'TJvRichEdit', nil);
  if hRich <> 0 then begin
    MsgID := StartHookOtherRich(Handle, JvRichEdit1.Handle, hTargetApp, hRich);
  end;
end;

//=============================================================================
//  [送信]
//  自アプリのTJvRichEditのリッチテキストを，他のアプリのTJvRichEditに送信
//  ここでは，DLLのコードに従って，受信側は挿入モードで受信することになる
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  hTargetApp : HWND;
  hRich      : HWND;
begin
  hTargetApp := FindWindow('TJVCL_RichEditForm', nil);
  if hTargetApp = 0 then exit;

  hRich := FindWindowEx(hTargetApp, 0, 'TJvRichEdit', nil);
  if hRich <> 0 then begin
    MsgID := SendToOtherRich(Handle, JvRichEdit1.Handle, hRich);
  end;
end;

//=============================================================================
//  TApplicationEventsコンポのOnMessageイベント処理
//  DLL内の処理終了の通知を受け取ったらフック終了
//=============================================================================
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if Msg.message = MsgID then begin
    StopHookOtherRich;
  end;
end;

end.

library GetRichText;

uses
  GetRichTextUnit in 'GetRichTextUnit.pas';

exports
  StartHookOtherRich,
  StopHookOtherRich,
  SendToOtherRich;
end.

unit GetRichTextUnit;

interface

uses
  SysUtils,
  Classes,
  RichEdit,
  Windows,
  Messages;

  function StartHookOtherRich(hSelfApp, hSelfRich, hSenderApp, hSenderRich: HWND):
      DWORD; stdcall;
  procedure StopHookOtherRich; stdcall;
  function SendToOtherRich(hSenderApp, hSenderRich, hReceiveRich: HWND):
      DWORD; stdcall;

implementation

uses CommonMemoryUnit;

type
  //---------------------------------------------------------
  //  メモリマップドファイルの構造体
  //---------------------------------------------------------
  PHookInfo = ^THookInfo;
    THookInfo = record
    HookHandle      : HHOOK;
    hReceiveFormWnd : HWND;
    hReceiveRichWnd : HWND;
    hSenderAppWnd   : HWND;
    hSenderRichWnd  : HWND;
    MsgID           : DWORD;
  end;

  //---------------------------------------------------------
  //  EM_SETTEXTEXメッセージで使用する構造体の定義と定数
  //  Microsoft SDKの記述による
  //---------------------------------------------------------
  PSetTextEx = ^TSetTextEx;
  tagSetTextEx = record
    flags    : DWORD;
    codepage : UINT;
  end;
  TSetTextEx = tagSetTextEx;
  SETTEXTEX = tagSetTextEx;

const
  EM_SETTEXTEX = WM_USER + 97;
  ST_DEFAULT   = 0;
  ST_KEEPUNDO  = 1;
  ST_SELECTION = 2;
  ST_NEWCHARS  = 4;
  ST_UNICODE   = 3;

  //---------------------------------------------------------
  //  メモリマップドファイル名
  //---------------------------------------------------------
  MapFileName = 'plHookRichCreate';

var
  //-----------------------------------------------------------------
  //  hMapFile メモリマップドファイルのハンドル
  //  FStream  取得した，送信側のリッチテキストを格納するストリーム
  //  CommMem  共有メモリ．ここに格納して他のアプリに転送または受信
  //-----------------------------------------------------------------
  hMapFile : THandle;
  FStream  : TStringStream;
  CommMem  : TCommMemNT;
  CommMem2 : TCommMemNT;

//-----------------------------------------------------------------------------
//  メモリマップドファイルアクセスのための準備
//
//  成功すると0を返す.失敗すると負数を返す
//  負の値で処理を分岐できるようになっているが,このコードでは未使用
//-----------------------------------------------------------------------------
function MapFileMemory(var h:THandle; var p:pointer):integer;
begin
  Result := 0;

  //メモリマップドファイルを開く
  h := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MapFileName));
  if h=0 then begin
    Result := -1;
  end else begin
    //メモリマップドファイルの割り当て
    p := MapViewOfFile(h, FILE_MAP_ALL_ACCESS, 0, 0, 0);
    if p = nil then begin
      Result := -2;
      CloseHandle(h);
      exit;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  メモリマップドファイルアクセスの後始末
//  割当てたメモリがあればビューを解除
//  ハンドルがあればクローズ
//-----------------------------------------------------------------------------
procedure UnMapFileMemory(h:THandle; p:Pointer);
begin
  if p <> nil then UnmapViewOfFile(p);
  if h <> 0   then CloseHandle(h);
end;

//-----------------------------------------------------------------------------
//  EM_STREAMOUTメッセージで使用するコールバック関数
//  このコールバック関数は，複数回実行されることがある(データサイズによる)
//
//  共有メモリに書き込みたいのであるが，あらかじめデータサイズを知ることができ
//  ないので，他のメモリストリームに書きこんでから共有メモリに格納する
//-----------------------------------------------------------------------------
function EditStreamCallBack(dwCookie: Longint; pbBuff: PByte;
    cb: Longint; var pcb: Longint): Longint; stdcall;
begin
  try
    pcb := FStream.Write(pbBuff^, cb);
    Result:= 0;
  except
    Result := 1;
  end;
end;

//-----------------------------------------------------------------------------
//  他のアプリへの転送と，他のアプリからの受信で共通に使用する関数
//  通信の実際の処理部分
//
//  hSenderRich  送り側のTRichEditのハンドル
//  hReciveRich  受け取る側のTRichEditのハンドル
//  hReciveApp   受け取る側のアプリケーションまたはフォームのハンドル
//  MsgID        処理が終了したことを自アプリで受け取るためのメッセージ数値
//-----------------------------------------------------------------------------
procedure SendRichText(hSenderRich, hReciveRich, hReciveApp: HWND; MsgID: DWORD);
var
  CharRangeRec : TCharRange;
  RangeLen     : Integer;
  Flags        : Integer;
  FStreamRec   : TEditStream;
  StrText      : AnsiString;
  SetTextRec   : TSetTextEx;
  ASize        : Integer;
begin
  //送り側のリッチテキストを格納するストリームを生成(TStringStream)
  FStream := TStringStream.Create('');
  try
    //テキストが選択中かを調査
    //選択テキストがある場合はそれだけを転送．それ以外は全て転送
    SendMessage(hSenderRich, EM_EXGETSEL, 0, LPARAM(@CharRangeRec));
    RangeLen := CharRangeRec.cpMax - CharRangeRec.cpMin;

    if RangeLen = 0 then begin
      Flags := SF_RTF;
    end else begin
      Flags := SF_RTF or SFF_SELECTION;
    end;

    //送り側のリッチテキストをFStreamに格納
    FStreamRec.pfnCallback := @EditStreamCallBack;
    SendMessage(hSenderRich,
                EM_STREAMOUT,
                Flags,
                Longint(@FStreamRec));

    //ストリームを文字列に変換
    //文字列はAnsiStringでないと正常に転送できない
    StrText := AnsiString(FStream.DataString);
  finally
    FStream.Free;
  end;
  ASize := Length(StrText);

  //共有メモリを生成して，文字列と構造体を共有メモリに格納
  CommMem  := TCommMemNT.Create(hReciveRich, ASize);
  CommMem2 := TCommMemNT.Create(hReciveRich, 100);
  try
    CommMem.ZeroClear;
    CommMem.Write(0, PAnsiChar(StrText), Length(StrText));

    //受け取り側に転送
    SetTextRec.flags    := ST_SELECTION;
    SetTextRec.codepage := CP_ACP;
    CommMem2.Write(0, @SetTextRec, SizeOf(SetTextRec));
    SendMessage(hReciveRich,
                EM_SETTEXTEX,
                Integer(CommMem2.MemPtr),
                LPARAM(CommMem.MemPtr));

    //自アプリに操作の終了を通知
    if hReciveApp <> 0 then begin
      PostMessage(hReciveApp, MsgID, ASize, 0);
    end;
  finally
    CommMem.Free;
    CommMem2.Free;
  end;
end;

//-----------------------------------------------------------------------------
//  フックのコールバック関数
//  このフックは，他のアプリのリッチテキストを受け取る場合のみで使用
//-----------------------------------------------------------------------------
function AHookProc(nCode:integer; wPar: WPARAM; lPar: LPARAM):LRESULT; stdcall;
var
  MapWnd : THandle;
  p      : Pointer;
begin
  Result := 0;
  MapFileMemory(MapWnd, p);
  if p <> nil then begin
    if nCode = HC_ACTION then begin
      if wPar=PM_NOREMOVE then begin
        if (PMsg(lPar).message = pHookInfo(p)^.MsgID) then begin
          if (PMsg(lPar).wParam = Integer(pHookInfo(p)^.hReceiveFormWnd)) then begin
            if pHookInfo(p)^.hSenderRichWnd <> 0 then begin
              SendRichText(pHookInfo(p)^.hSenderRichWnd,
                           pHookInfo(p)^.hReceiveRichWnd,
                           pHookInfo(p)^.hReceiveFormWnd,
                           pHookInfo(p)^.MsgID);
            end;
          end;
        end;
      end;
    end;
    Result := CallNextHookEx(pHookInfo(p)^.HookHandle, nCode, wPar, lPar);

    UnMapFileMemory(MapWnd, p);
  end;
end;

//=============================================================================
//  フックの開始
//  このフックは，他のアプリのリッチテキストを受け取る場合のみで使用
//
//  他のアプリのテキストは，単にEM_STREAMOUTメッセージを送信しても取得できない
//  そこで，他のアプリの操作をフックできるようなメッセージを送信し，フックの
//  処理の中でEM_STREAMOUTメッセージを送って取得する
//=============================================================================
function StartHookOtherRich(hSelfApp, hSelfRich, hSenderApp, hSenderRich: HWND):
    DWORD; stdcall;
var
  MapWnd     : THandle;
  p          : Pointer;
  dwThreadID : DWORD;
begin
  Result := 0;

  MapFileMemory(MapWnd, p);

  if p <> nil then begin
    if pHookInfo(p)^.HookHandle <> 0 then begin
      UnhookWindowsHookEx(pHookInfo(p)^.HookHandle);
      pHookInfo(p)^.HookHandle := 0;
     end;

    pHookInfo(p)^.hReceiveFormWnd := hSelfApp;
    pHookInfo(p)^.hReceiveRichWnd := hSelfRich;
    pHookInfo(p)^.hSenderAppWnd   := hSenderApp;
    pHookInfo(p)^.hSenderRichWnd  := hSenderRich;

    dwThreadID := GetWindowThreadProcessId(pHookInfo(p)^.hSenderAppWnd);
    if dwThreadID <> 0 then begin
      pHookInfo(p)^.MsgID      := RegisterWindowMessage('GetRichEdit_RTFTEXT');
      pHookInfo(p)^.HookHandle := SetWindowsHookEx(WH_GETMESSAGE,
                                                   Addr(AHookProc),
                                                   HInstance,
                                                   dwThreadID);
      PostMessage(pHookInfo(p)^.hSenderAppWnd,
                  pHookInfo(p)^.MsgID,
                  WPARAM(pHookInfo(p)^.hReceiveFormWnd),
                  0);

      Result := pHookInfo(p)^.MsgID;
    end;

    UnMapFileMemory(MapWnd, p);
  end;
end;

//=============================================================================
//  他のアプリへリッチテキストを送信するメソッド
//  フックは使用しない
//  実際にはDLLにしなくても，共有メモリを使用すればできる
//=============================================================================
function SendToOtherRich(hSenderApp, hSenderRich, hReceiveRich: HWND):
    DWORD; stdcall;
var
  MapWnd : THandle;
  p      : Pointer;
begin
  Result := 0;

  MapFileMemory(MapWnd, p);

  if p <> nil then begin
    pHookInfo(p)^.hReceiveFormWnd := 0;
    pHookInfo(p)^.hReceiveRichWnd := hReceiveRich;
    pHookInfo(p)^.hSenderAppWnd   := hSenderApp;
    pHookInfo(p)^.hSenderRichWnd  := hSenderRich;

    pHookInfo(p)^.MsgID := RegisterWindowMessage('GetRichEdit_RTFTEXT');
    Result := pHookInfo(p)^.MsgID;

    SendRichText(pHookInfo(p)^.hSenderRichWnd,
                 pHookInfo(p)^.hReceiveRichWnd,
                 pHookInfo(p)^.hSenderAppWnd,
                 pHookInfo(p)^.MsgID);

    UnMapFileMemory(MapWnd, p);
  end;
end;

//=============================================================================
//  フックの終了
//=============================================================================
procedure StopHookOtherRich; stdcall;
var
  MapWnd : THandle;
  p      : Pointer;
begin
  MapFileMemory(MapWnd, p);
  if p <> nil then begin
    if pHookInfo(p)^.HookHandle <> 0 then begin
      UnhookWindowsHookEx(pHookInfo(p)^.HookHandle);
      pHookInfo(p)^.HookHandle := 0;
    end;

    UnMapFileMemory(MapWnd, p);
  end;
end;

//-----------------------------------------------------------------------------
//  ユニットの初期化部
//  メモリマップドファイルを作成
//-----------------------------------------------------------------------------
initialization
begin
  hMapFile := CreateFileMapping(High(NativeUInt),
                                nil,
                                PAGE_READWRITE,
                                0,
                                SizeOf(THookInfo),
                                PChar(MapFileName));
end;
//-----------------------------------------------------------------------------
//  ユニット終了処理部
//  メモリマップドファイルのクローズ
//-----------------------------------------------------------------------------
finalization
begin
  if hMapFile <> 0 then CloseHandle(hMapFile);
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ApplicationEvents1: TApplicationEvents;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  MsgID : Cardinal;

type
  //レコード型(構造体)に，長さ不定のString型は使用しない
  //レコード型は，PTestRec = ^TTestRec;のように，そのポイント型を定義しておくと便利
  TTestRec = record
    A : Integer;
    B : PChar;
  end;
  PTestRec = ^TTestRec;

//=============================================================================
//  メッセージの発行
//  WParamパラメータもセットして送る
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ATestRec : TTestRec;
begin
  MsgID := RegisterWindowMessage('Message_Test_ID');

  ATestRec.A := 100;
  ATestRec.B := 'テスト文字列';
  PostMessage(Panel1.Handle, MsgID, WPARAM(@ATestRec), 0);
end;

//=============================================================================
//  TApplicationEventsコンポのOnMessageイベント処理
//  メッセージの値がMsgIDの時の受信処理
//  OnMessageのメッセージは，WH_GETMESSAGEフックで捕えることができる
//=============================================================================
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var
  V      : Integer;
  StrV   : String;
  StrMes : String;
begin
  if Msg.hwnd = Panel1.Handle then begin
    if Msg.message = MsgID then begin
      V      := PTestRec(Msg.wParam)^.A;
      StrV   := PTestRec(Msg.wParam)^.B;
      StrMes := IntToStr(V) + ' と "' + StrV + '" が届きました';
      MessageDlg(StrMes, mtInformation, [mbOK], 0);
    end;
  end;
end;

end.