ホーム >プログラム >Delphi 6 ローテクTips

Unicode対応のヒントウィンドウ

ポップアップヒントをUnicode対応に。


参考サイト


やり方

THintWindowのPaintとCalcHintRectメソッド中のDrawText APIをDrawTextW APIに書き換えるだけでいけます。
ただしコントロールのHintプロパティにはUnicode文字を直接代入してもだめで、UnicodeとAnsiStringの可逆変換関数を使って変換した文字列を代入します。

ソースコード

unit myHintWindow;
{Unicode対応のヒントウィンドウ
http://mrxray.on.coocan.jp/Halbow/Notes/N018.html
}


interface
uses
  Controls,
  Windows;

type
  TMyHintWindow = class(THintWindow)
  protected
    procedure Paint; override;
  public
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
  end;

implementation
uses
  Classes,
  Forms;


//------------------------------------------------------------------------------
//AnsiStringとWideStringとの可逆変換関数。
const
  l_csDEFAULT_CHAR = #1;
  l_csPREFIX_CHAR  = '$';
const
  WC_NO_BEST_FIT_CHARS = $00000400;


function gfnsWideToAnsiEx(sSrc: WideString): AnsiString;
//ウムラウトなどのUnicode文字のみ$+16進の形に変換し、それ以外は普通にAnsiStringに変換した文字列を返す。
var
  i, li_Pos, li_Len: Integer;
  lb_Bool: LongBool;
  ls_PStr: PAnsiChar;
begin
  Result := '';
  if (sSrc <> '') then begin
    //WC_COMPOSITECHECKは指定してはいけない
    li_Len := WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, PWideChar(sSrc), -1, nil, 0, l_csDEFAULT_CHAR, @lb_Bool);
    if (lb_Bool = False) and (Pos(l_csPREFIX_CHAR, sSrc) = 0) then begin
      //ウムラウトのようなUnicode文字がなくプリフィクス文字($)もない場合は変換する必要なし
      Result := sSrc;
    end else begin
      ls_PStr := AllocMem(li_Len + 1);
      try
        li_Len := WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, PWideChar(sSrc), -1, ls_PStr, li_Len, l_csDEFAULT_CHAR, @lb_Bool);
        if (li_Len > 0) then begin
          Dec(li_Len);
          i      := 0; //ls_PStr のインデックス
          li_Pos := 1; //sWSrc のインデックス
          repeat
            if (ls_PStr[i] = l_csDEFAULT_CHAR) or (ls_PStr[i] = l_csPREFIX_CHAR) then begin
              //#1→'$xxxx' xxxx は元の文字の4桁の16進値
              Result := Result + l_csPREFIX_CHAR + Format('%0.4x', [Ord(sSrc[li_Pos])]);
            end else begin
              Result := Result + ls_PStr[i];
            end;
            if (IsDBCSLeadByte(Byte(ls_PStr[i]))) then begin
              //2バイト文字の先頭バイトなのでもう1バイトスキップ
              Result := Result + ls_PStr[i + 1];
              Inc(i, 2);
            end else begin
              Inc(i);
            end;
            Inc(li_Pos);
          until (i >= li_Len); //untilは条件がTrueで終了
        end;
      finally
        FreeMem(ls_PStr);
      end;
    end;
  end;
end;

function gfnsAnsiToWideEx(const sSrc: AnsiString): WideString;
//gfnsWideToAnsiExの逆
var
  li_Pos, li_Len: Integer;
  ls_WStr, ls_WCnv: WideString;
begin
  Result := '';
  if (sSrc <> '') thenbegin
    ls_WStr := WideString(sSrc);
    li_Pos  := Pos(l_csPREFIX_CHAR, ls_WStr);
    if (li_Pos = 0) thenbegin
      //プリフィクス文字($)がなければ変換する必要はない
      Result := ls_WStr;
    endelsebegin
      li_Len  := Length(ls_WStr);
      repeat
        //'$'までの文字列を足しこむ
        Result := Result + Copy(ls_WStr, 1, li_Pos - 1);
        try
          //'$'に続く(はずの)4文字の数値をUnicode文字に変換
          ls_WCnv := WideString(WideChar(StrToInt(Copy(ls_WStr, li_Pos, 5))));
          Result  := Result + ls_WCnv;
          ls_WStr := Copy(ls_WStr, li_Pos +4 +1, li_Len);  //4文字の数値の次からコピー開始
        except
          //イレギュラー
          Result  := Result + WideString(l_csPREFIX_CHAR);  //イレギュラー時はそのままにする
          ls_WStr := Copy(ls_WStr, li_Pos +1, li_Len);        //'$'の次からコピー開始
        end;
        //次の'$'までの位置を取得
        li_Pos := Pos(l_csPREFIX_CHAR, ls_WStr);
        Application.ProcessMessages;
      until (li_Pos = 0);  //untilは条件がTrueで終了
      Result := Result + ls_WStr;
    end;
  end;
end;


//------------------------------------------------------------------------------
procedure TMyHintWindow.Paint;
var
  R: TRect;
begin
  R := ClientRect;
  Inc(R.Left, 4);
  Inc(R.Top,  4);
  Canvas.Font.Color := Screen.HintFont.Color;
  DrawTextW(Canvas.Handle, PWideChar(gfnsAnsiToWideEx(Caption)), -1, R, DT_VCENTER or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly);
end;

function TMyHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect;
begin
  Result := Rect(0, 0, MaxWidth, 0);
  DrawTextW(Canvas.Handle, PWideChar(gfnsAnsiToWideEx(AHint)), -1, Result, DT_CALCRECT or DT_VCENTER or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX or DrawTextBiDiModeFlagsReadingOnly);
  //ちょっと余裕を持たせた表示に
  Inc(Result.Right,  10);
  Inc(Result.Bottom,  4);
end;


initialization
  //Unicode対応ヒントウィンドウ
  HintWindowClass      := TMyHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;

end.

initialization部でヒントウィンドウの初期化処理を行っています。

  HintWindowClass      := TMyHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;

このようにHintWindowClassにTMyHintWindowの型を代入してShowHintプロパティをFalseにしてTrueに戻すだけいいのだそうです。

initialization部でヒントウィンドウの初期化処理を行っているのでこのユニットをプログラムのuses節に追加するだけでHintがUnicode対応になります。

試してみた

procedure TForm1.WindowsMediaPlayer1PlayStateChange(Sender: TObject; NewState: Integer);
begin
  if (NewState = wmppsPlaying) then begin
    Self.Hint := gfnsWideToAnsiEx(
      WideFormat('%s'#13'%s'#13'%s', [
        WindowsMediaPlayer1.currentMedia.getItemInfo('Author'), //アーティスト名
        WindowsMediaPlayer1.currentMedia.getItemInfo('Title'),  //タイトル(曲名)
        WindowsMediaPlayer1.currentMedia.getItemInfo('Album')   //アルバム名
      ])
    );
  end;
end;

ためしに Queensrÿche の曲のタグをWindowsMediaPlayerで拾ってgfnsWideToAnsiEx関数で変換してからHintにセットしました。

ちゃんと Queensrÿche と表示されています。
OKです。
というか、ヒントって複数行対応だったんですね。

FormやPanelやその他のコントロールのHintプロパティに直接Unicodeを代入できないのが難点ですが、とりあえず手軽なのでまぁこれでいいかなと。


2008-12-18: