☆メモ上でマウス下のテキスト取得

ブラウザでのGoogleの翻訳機能ってどうしてるのかなという疑問から、マウス下のテキストの取得に挑戦してみましたが、ブラウザでの取得は全くわかりませんでした。ということで簡単なところから、エディットコントロールでのサンプルです(笑)

実行するとこんな感じです。






ごちゃごちゃと検索する関数です。（日本語の処理は面倒ですね）
きちんとまとめるともう少しすっきりしそうですが、サンプルということで・・・。

unit GetWordAndPhrase;

interface

uses
  Windows;

//マウス下の語句を返します。＜Delimiterで区切られているか英単語単位＞
//Ptには、語句の開始位置と終了位置を返します。
function GetWordAndPhraseUnderMouse(const Index: Integer;const  S: String;
  var StartPos, EndPos: Integer): String;

implementation

//半角アルファベットかどうか
function IsAlphabet(C: Byte): Boolean;
begin
  Result := (C in [65..90, 97..122]);
end;

//英単語を取得するかどうか
function IsAlphabetMode(Index: Integer; S: String): Boolean;
var
  P: PChar;
begin
  P := PChar(S);
  Result := (Ord(P[Index]) in [65..90, 97..122]);
end;

//IndexがDelimiterかどうか
function IsDelimiter(Index: Integer; S: String): Boolean;
var
  P: PChar;
  wc: Word;
begin
  Result := True;
  P := PChar(S);

  //Delimiterの場合には終了
  if Ord(P[Index]) in [9,10,13,32] then Exit;

  //全角スペースの１バイト目
  if IsDBCSLeadByte(Byte(P[Index])) then
  begin
    wc := (Byte(P[Index]) shl 8) or Byte(P[Index+1]);
    //$8140-全角スペース $8141-、$8142-。
    if (wc = $8140) or (wc = $8141) or (wc = $8142) then Exit;
  end;

  //Indexが0の場合は、全角スペースの２バイト目はありえないので処理を終了します。
  if Index = 0 then
  begin
    Result := False;
    Exit;
  end;

  //全角スペースの２バイト目
  if IsDBCSLeadByte(Byte(P[Index-1])) then
  begin
    wc := (Byte(P[Index-1]) shl 8) or Byte(P[Index]);
    //$8140-全角スペース $8141-、$8142-。
    if  (wc = $8140) or (wc = $8141) or (wc = $8142) then Exit;
  end;
  Result := False;
end;

//前方検索
function PrevCheckAlphabetMode(Index: Integer; S: String): Integer;
var
  P: PChar;
begin
  if Index = 0 then
  begin
    Result := 0;
    Exit;
  end;

  P := PChar(S);
  repeat
    // 全角かどうかのチェック -- ２バイト目かどうか
    // 前方検索なので、１バイト目が先に出てくることはない。
    // ２バイト目が確認できたら、１バイト目分も移動させる。
    if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then
      begin
        //全角の場合は終了する。
        Inc(Index);
        Break;
      end
    else if not IsAlphabet(Byte(P[Index])) then
      begin
        Inc(Index);
        Break;
      end
    else if Ord(P[Index]) in [9,10,13,32] then //半角Delimiter文字のチェック
      begin
        Inc(Index); //IndexがDelimiterなら一つ戻して終了する。
        Break;
      end
    else
      Dec(Index);
  until Index <= 0;
  if Index < 0 then Index := 0;
  Result := Index;
end;

//後方検索
function NextCheckAlphabetMode(Index: Integer; S: String): Integer;
var
  P: PChar;
  max: Integer;
begin
  Result := -1;
  P := PChar(S);
  Max := Length(S);

  //Indexが全角の２バイトの場合一つ戻しておきます。
  if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then Exit;

  repeat
    // 全角の場合
    if IsDBCSLeadByte(Byte(P[Index])) then //１バイト目かどうかのチェック
      Break
    else if not IsAlphabet(Byte(P[Index])) then
      Break
    else if Ord(P[Index]) in [9,10,13,32] then
      Break
    else
      Inc(Index);
  until Index >= max;  //Index=maxというのは文字列より一つ多い。
  Dec(Index);
  Result := Index;
end;


//前方検索 -- Delimiterのみで判定する
function PrevCheck(Index: Integer; S: String): Integer;
var
  P: PChar;
  wc: Word;
begin
  if Index = 0 then
  begin
    Result := 0;
    Exit;
  end;

  P := PChar(S);
  // Indexが２バイト目の先頭バイトの場合には、一つ進めておきます。
  if IsDBCSLeadByte(Byte(P[Index])) then
  begin
    if Index = 0 then
    begin
      Result := 0;
      Exit;
    end;
    Dec(Index);
  end;

  repeat
    // 全角かどうかのチェック -- ２バイト目かどうか
    // 前方検索なので、１バイト目が先に出てくることはない。
    // ２バイト目が確認できたら、１バイト目分も移動させる。
    if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then
      begin
        wc := (Byte(P[Index-1]) shl 8) or Byte(P[Index]);
        //$8140-全角スペース $8141-、$8142-。
        if  (wc = $8140) or (wc = $8141) or (wc = $8142) then
          begin
            Inc(Index); //Indexが２バイト文字だと確認できたら一つ戻して終了する。
            Break;
          end
        else
          Index := Index - 2; //全角文字の一つ前に進める。
      end
    else if Ord(P[Index]) in [9,10,13,32] then //半角Delimiter文字のチェック
      begin
        Inc(Index); //IndexがDelimiterなら一つ戻して終了する。
        Break;
      end
    else
      Dec(Index);
  until Index <= 0;
  if Index < 0 then Index := 0;
  Result := Index;
end;

//後方検索 -- Delimiterのみ判定する
function NextCheck(Index: Integer; S: String): Integer;
var
  P: PChar;
  wc: Word;
  max: Integer;
begin
  P := PChar(S);
  Max := Length(S);

  //Indexが全角の２バイトの場合一つ戻しておきます。
  if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then
    Dec(Index);

  repeat
    // 全角の場合
    if IsDBCSLeadByte(Byte(P[Index])) then //１バイト目かどうかのチェック
      begin
        //全角スペースのチェック
        wc := (Byte(P[Index]) shl 8) or Byte(P[Index+1]);
        //$8140-全角スペース $8141-、$8142-。
        if  (wc = $8140) or (wc = $8141) or (wc = $8142) then
          Break;
        Index := Index + 2;
      end
    else if Ord(P[Index]) in [9,10,13,32] then
      Break
    else
      Inc(Index);
  until Index >= max;  //Index=maxというのは文字列より一つ多い。
  Dec(Index);
  Result := Index;
end;


//マウス下の語句を返します。＜Delimiterで区切られているか英単語単位＞
//Ptには、語句の開始位置と終了位置を返します。
function GetWordAndPhraseUnderMouse(const Index: Integer;const  S: String;
  var StartPos, EndPos: Integer): String;
begin
  StartPos := -1;
  EndPos := -1;
  Result := '';
  if not IsDelimiter(Index,S) then
  begin
    if IsAlphabetMode(Index,S)  then
      begin
        // 英単語のみの取得
        StartPos := PrevCheckAlphabetMode(Index,S);
        EndPos := NextCheckAlphabetMode(Index,S);
      end
    else
      begin
        // delimiterによる語句の取得
        StartPos := PrevCheck(Index,S);
        EndPos := NextCheck(Index,S);
      end;
  end;
  if (StartPos = -1) and (EndPos = -1) then
    Result := ''
  else
    Result := Copy(S, StartPos+1, EndPos-StartPos+1);
end;

end.

上記、関数の利用例です。
メモとタイマーを各１個ずつ配置して、それぞれの手続きを設定します。

unit Sample2_UseMemo;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Timer1: TTimer;
    procedure Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    HW: THintWindow;
    procedure ShowHintWindow(X, Y: Integer; S: String);
    procedure HideHintWindow;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses GetWordAndPhrase;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  HW := THintWindow.Create(Self);
end;

var
  bkPos: TPoint;

procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
const
  A = 5; //マウスの感度調整
begin
  if ((X < bkPos.X -A) or (X > bkPos.X +A)) or
     ((Y < bkPos.Y -A) or (Y > bkPos.Y +A)) then
    HideHintWindow;
end;

// ヒントウィンドウの表示
procedure TForm1.Timer1Timer(Sender: TObject);
var
  I, sp, ep: Integer;
  S: String;
  csPos,clPos: TPoint;
begin
  GetCursorPos(csPos);
  clPos := Memo1.ScreenToClient(csPos);
  bkPos := clPos;
  I := LoWord(Memo1.Perform(EM_CHARFROMPOS, 0, MakeLParam(clPos.X, clPos.Y)));
  S := GetWordAndPhraseUnderMouse(I, Memo1.Text, sp, ep);
  if (S <> '') then
  begin
    ShowHintWindow(csPos.X, csPos.Y, S);
    Timer1.Enabled := False;
  end;
end;

// ヒントウィンドウ
procedure TForm1.ShowHintWindow(X, Y: Integer; S: String);
var
  Rect: TRect;
begin
  if not HW.HandleAllocated then
    HW.HandleNeeded;

  Rect := Bounds(0, 0, 0, 0);
  DrawText(HW.Canvas.Handle, PChar(S), -1, Rect, DT_CALCRECT or DT_LEFT);
  OffsetRect(Rect, X,Y + 10);
  //ヒントウィンドウの微調整
  Inc(Rect.Right, 6);
  Inc(Rect.Bottom, 2);
  //表示
  HW.ActivateHint(Rect, S);
end;

procedure TForm1.HideHintWindow;
begin
  if HW.HandleAllocated then
  begin
    HW.ReleaseHandle;
    Timer1.Enabled := True;
  end;
end;

end.

delimiterは、全角スペース、半角スペース、改行(CRLF)、句読点（。、）としています。