2013年10月8日火曜日

GetTextExtentPoint() の TSize.cX の値

env: Lazarus IDE 1.0.12,FPC 2.6.2,Windows 8 Pro 64bit

 LclIntf.GetTextExtentPoint() と Windows.GetTextExtentPoint() に utf8文字列を与えた場合の結果が異なるようです。
 (us-ascii の場合は同じ)


IDEのコードエディタから GetTextExtentPoint() を辿ると winapih.inc と redef.inc のどちらかが開かれます。

Windows.GetTextExtentPoint は redef.inc
LCLIntf.GetTextExtentPoint は winapih.inc

に辿り着きます。

名前空間(Windows.)の部分を省略すると、どちらが呼ばれるかは uses の後ろにあるものほど優先されます。


Windows.GetTextExtentPoint(hDC, PChar(str), len, sz);

が呼ばれると sz.cX は予想の倍ぐらいか実際のバイト数ぐらいの値になります。
UTF8 を そのまま ascii のバイトコードで画面出力した時の横幅と同じようです。
(ということでデコードされていない模様)

なので GetTextExtentPoint()に頼って文字列のExtUTF8Out()等を行うとズレまくります。

例えば

LOGFONT
lfFaceName:Meiryo UI
lfHeight:-12

の場合で

sz: TSize;
str:='新しいテキスト ドキュメント.txt'; // string,utf8
len:=length(str); // integer,len=44 (bytecount)

Windows.GetTextExtentPoint(hDC, PChar(str), len, sz); //(Windows.GetTextExtentPoint32()もGetTextExtentPoint32Wも同じ)
sz.cX=233 sz.cY=16

LCLIntf.GetTextExtentPoint(hDC, PChar(str), len, sz);
sz.cX=146 sz.cY=16

となります。


この仕様の違いに気が付かず、バグだと思い込み単純なテストアプリケーションを作成して調査した所、バグが再現せずしばらく悩んでしまいました。
LCLIntf が参照されていたために再現しなかったのです。

明示的に Windows.GetTextExtentPoint を呼び出す事で再現しました。


ということで。

ユニット順を見直したり、LCLIntf.GetTextExtentPoint() のようにして明示的に呼びだすように注意したほうがよさそうです。

以下テストコード。
クリックするたびにLCLintf, Windows, バイトコードゲージ "."に 切り替わります。
利用する場合は、UTF8で保存してください。
(文字列定数が UTF8 でなければならないので)

主要なコードは Test_ で始まる procedure です。
クラスのほうはバックグラウンドです。

unit Unit1;

{$mode delphi}{$H+}

interface

uses
  Windows, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
  LCLIntf, LCLType, LazUTF8, LConvEncoding;

const
  color_guide_h = $99ccff;
  color_end_h   = $0099ff;

  color_guide_v = $ff9999;
  color_end_v   = $cc9999;

  color_bg      = $250000;
  color_fg      = clSilver;

  margin = 8;
type
  TProcType = (prTextOut,prEnd,prGuide,prMargin);
  TTestPosition = procedure (const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize) of object;
  TTestProc = procedure (dc: THandle; rc: TRect; var x, y: integer; testpos: TTestPosition; const str: string);
  { TForm1 }

  TForm1 = class(TForm)
    procedure FormClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDblClick(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { private declarations }
    xmax: integer;
    FTest: TTestProc;
    procedure HorizontalLeft(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure HorizontalRight(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure VirticalTop(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure VirticalBottom(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure DoTest( test: TTestProc);
  public
    { public declarations }
    procedure Test;
    property TestProc:TTestProc read FTest write FTest;
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure Test_LCLIntf_GetTextExtentPoint(dc: THandle; rc: TRect; var x, y: integer;
  testpos: TTestPosition; const str: string);
var
  len: integer;
  sz: TSize;
begin
    len:= Length(str);
    LCLIntf.GetTextExtentPoint( dc, PChar(str), len, {%H-}sz);
    testpos( prTextOut, rc, x, y, sz);
    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(str), len, nil);
    testpos( prEnd    , rc, x, y, sz);
    testpos( prGuide  , rc, x, y, sz);
    testpos( prMargin , rc, x, y, sz);
end;

procedure Test_Windows_GetTextExtentPoint(dc: THandle; rc: TRect; var x, y: integer;
  testpos: TTestPosition; const str: string);

var
  len: integer;
  sz: TSize;
begin
    len:= Length(str);
    Windows.GetTextExtentPoint( dc, PChar(str), len, {%H-}sz);
    testpos( prTextOut, rc, x, y, sz);
    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(str), len, nil);
    testpos( prEnd    , rc, x, y, sz);
    testpos( prGuide  , rc, x, y, sz);
    testpos( prMargin , rc, x, y, sz);
end;

procedure Test_Windows_GetTextExtentPoint_UTF8Decode(dc: THandle; rc: TRect; var x, y: integer;
  testpos: TTestPosition; const str: string);

var
  len: integer;
  sz: TSize;
  tmp: string;
  p,e: PChar;
begin
    len:= Length(str);
    Windows.GetTextExtentPoint( dc, PChar(str), len, {%H-}sz);
    testpos( prTextOut, rc, x, y, sz);
    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(UTF8Decode(str)), len, nil);

    SetLength(tmp,len);
    copymemory(@tmp[1],@str[1],len);

    p:= @tmp[1];
    e:= p + len;
    while p<e do
    begin
      p^:='.';
      inc(p);
    end;

    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(tmp), len, nil);
    testpos( prEnd    , rc, x, y, sz);
    testpos( prGuide  , rc, x, y, sz);
    testpos( prMargin , rc, x, y, sz);
end;

procedure TForm1.FormClick(Sender: TObject);
begin
  Tag:= Tag + 1;
  case Tag of
   0:begin
     Caption:='LCLIntf.GetTextExtentPoint()';
     TestProc:= Test_LCLIntf_GetTextExtentPoint
   end;
   1:begin
     Caption:='Windows.GetTextExtentPoint()';
     TestProc:= Test_Windows_GetTextExtentPoint
   end;
   2:begin
     Caption:='Windows.GetTextExtentPoint(),ExtUTF8Out(UTF8Decode)';
     TestProc:= Test_Windows_GetTextExtentPoint_UTF8Decode
   end;
   else
   begin
     Tag:= -1;
     Click;
   end;
  end;

  Repaint;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Font.Name:='MS Gothic';
  Click;
end;

procedure TForm1.FormDblClick(Sender: TObject);
begin
  Click;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Test;
end;

procedure TForm1.HorizontalLeft(const proctype: TProcType; const rc: TRect; var x, y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: x:= rc.Left;
      prEnd:
        begin
          inc(x,sz.cX);
          if xmax<x then xmax:=x;
          dec(x,sz.cX);
          Canvas.Pen.Color:= color_end_h;
          Canvas.MoveTo(x + sz.cX ,y);
          inc(y,sz.cY);
          Canvas.LineTo(x + sz.cX ,y);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_h;
          Canvas.MoveTo(rc.Left ,y);
          Canvas.LineTo(rc.Right,y);
        end;
      prMargin : inc(y,margin);
    end;
end;

procedure TForm1.HorizontalRight(const proctype: TProcType; const rc: TRect;
  var x, y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: x:= rc.Right - sz.cX;
      prEnd:
        begin
          Canvas.Pen.Color:= color_end_h;
          dec(x,sz.cX);
          Canvas.MoveTo(x + sz.cX ,y);
          inc(y,sz.cY);
          Canvas.LineTo(x + sz.cX ,y);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_h;
          Canvas.MoveTo(rc.Left ,y);
          Canvas.LineTo(rc.Right,y);
        end;
      prMargin : inc(y,margin);
    end;
end;

procedure TForm1.VirticalTop(const proctype: TProcType; const rc: TRect; var x,
  y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: y:= rc.Top + sz.cX;
      prEnd:
        begin
          Canvas.Pen.Color:= color_end_v;
          dec(y,sz.cX);
          Canvas.MoveTo(x ,y + sz.cX);
          inc(x,sz.cY);
          Canvas.LineTo(x ,y + sz.cX);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_v;
          Canvas.MoveTo(x, rc.Top);
          Canvas.LineTo(x, rc.Bottom);
        end;
      prMargin : inc(x,margin);
    end;
end;

procedure TForm1.VirticalBottom(const proctype: TProcType; const rc: TRect;
  var x, y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: y:= rc.Bottom;
      prEnd:
        begin
          Canvas.Pen.Color:= color_end_v;
          dec( y,sz.cX);
          dec( y,sz.cX);
          Canvas.MoveTo(x, y + sz.cX);
          inc( x,sz.cY);
          Canvas.LineTo(x, y + sz.cX);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_v;
          Canvas.MoveTo(x, rc.Top);
          Canvas.LineTo(x, rc.Bottom);
        end;
      prMargin : inc(x,margin);
    end;
end;

procedure TForm1.DoTest( test: TTestProc);
const
  str0= 'ascii.txt';
  str1= '日本語あいうえお';
  str2= '日本語 + ascii';
  str3= '♥♥♥';
var
  lfText: TLOGFONT;
  hfNew, hfOld: HFONT;
  rc: TRect;
  hDC:THandle;
  gx,gy: integer;
begin
  rc := ClientRect;
  inc(rc.Left  , 8);
  inc(rc.Top   , 8);
  dec(rc.Right , 8);
  dec(rc.Bottom, 8);
  xmax:= 0;

  Canvas.Brush.Color:= color_bg;
  Canvas.FillRect(rc);

  hDC:= Canvas.Handle;
  GetObject(Font.Reference.Handle, sizeof(TLOGFONT), @lfText);

  // Horizontal

  hfNew := CreateFontIndirect(lfText);
  hfOld := SelectObject(hDC, hfNew);
  try
      SetBkMode(hDC, TRANSPARENT);
      SetTextColor( hDC, color_fg);

      gx:= rc.Left;
      gy:= rc.Top;

      test( hDC, rc, gx,gy, HorizontalLeft, str0);
      test( hDC, rc, gx,gy, HorizontalLeft, str1);
      test( hDC, rc, gx,gy, HorizontalLeft, str2);
      test( hDC, rc, gx,gy, HorizontalLeft, str3);

      test( hDC, rc, gx,gy, HorizontalRight, str0);
      test( hDC, rc, gx,gy, HorizontalRight, str1);
      test( hDC, rc, gx,gy, HorizontalRight, str2);
      test( hDC, rc, gx,gy, HorizontalRight, str3);

  finally
    hfNew:= SelectObject(hDC, hfOld);
    DeleteObject(hfNew);
  end;

  // Virtical

  lfText.lfEscapement  := 90 * 10;
  lfText.lfOrientation := lfText.lfEscapement;

  hfNew := CreateFontIndirect(lfText);
  hfOld := SelectObject(hDC, hfNew);
  try
      gx:= xmax + 10;
      gy:= rc.Bottom;

      test( hDC, rc, gx,gy, VirticalTop, str0);
      test( hDC, rc, gx,gy, VirticalTop, str1);
      test( hDC, rc, gx,gy, VirticalTop, str2);
      test( hDC, rc, gx,gy, VirticalTop, str3);

      test( hDC, rc, gx,gy, VirticalBottom, str0);
      test( hDC, rc, gx,gy, VirticalBottom, str1);
      test( hDC, rc, gx,gy, VirticalBottom, str2);
      test( hDC, rc, gx,gy, VirticalBottom, str3);

  finally
    hfNew:= SelectObject(hDC, hfOld);
    DeleteObject(hfNew);
  end;
end;

procedure TForm1.Test;
begin
  if Assigned(FTest) then
  DoTest(FTest);
end;

end.

0 件のコメント:

コメントを投稿