Try&Error 付箋アプリを作ってみる stickies (6)

TMemoのオーナドロー

まだやってます。Swissの方がよさそうな話になってきたので、Swissをベースにまた書きなおしてみたりしてます。

China: HackChina.com:[2012/05/05]
Swiss: SwissDelphiCenter.ch:[2012/05/05]
直接コントロールに描画せずに、一旦TBitmapに書いて、BitBltで転送することでますます描画は良い感じになったんですけど、予想通り選択範囲が一切反映されません。めんどくせー。他の問題が解決しそうにないのでやる気が湧きません。もう。
方針はSelStartとかで選択範囲かどうかを判定して、描画の色を変えるとかなんだろうけどなぁ。やればできそうなんだけどなぁ。

やる気を削がす問題は、自前で描いた時に、文字列を選択するとTMemoの描画処理がでしゃばってきてせっかく背景色とか強調表示(こっちはまだやってないけど)したところで、背景白文字列黒の標準描画に書きなおされちゃう。

***

逆に、ぜ~んぶ諦めて背景色だけ書き換えることにすると、ストレスが激減します。周囲と微妙に1行に届かない高さが一番下に残った時に変なんですけど。

コードはこんなの。めちゃ簡単。
type
TMemoEx = class(TMemo)
private
procedure WMErasbkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;

procedure TMemoEx.WMErasbkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
//inherited;
end;

procedure TMemoEx.WMPaint(var Message: TWMPaint);
begin
Brush.Color := clSkyBlue;
inherited;
end;

実行すると、最終行とか周囲数ピクセルが塗り残してあるけど...原因は、WMErasbkgndです。でもこれやめると、すごいちらつくんですよね。

文字列を選択しても良い感じ。

入力するときもずれてないし。


実際には、スクロールしたり云々でInvalidateを呼び出してるんだけど、多分このコードだけで十分な気がする。そもそもTMemoっていっぱいいろんなことをしてくれてるんでしょうね。

ちなみに、普通のTMemoをそのままおいて、マウスでウィンドウのサイズをビリビリ変更してみるとちゃんとちらつきます。背景色を変えるぐらいのことはデメリットなしにできるなぁという感じです。

最初にチビ目標にした「行ごとの背景色変更」もやってません。もうなんかね。

***

まんまSwissのパクリですが、せっかくなので、自前でTMemo標準の選択文字列がない状態を再現するソースコードです。このコードは、1行は一括で描画してます。Swissは単語単位で描画してるので、1行を描画するときに小分けにしてそのぶんX座標を進めて...とやってます。
function TMemoEx.GetFirstVisibleLineIndex: Integer;
begin
Result := SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0)
end;

function TMemoEx.GetMaxVisibleLineCount: Integer;
var
LFontHeight: Integer;
begin
LFontHeight := Abs(Font.Height) + 2;
Result := Height div (LFontHeight);
end;

function TMemoEx.GetVisibleLineCount: Integer;
begin
Result := Min(GetMaxVisibleLineCount, Lines.Count - GetFirstVisibleLineIndex);
end;

procedure TMemoEx.WMPaint(var Message: TWMPaint);
var
LDC: HDC;
LPaintStruct: TPaintStruct;
LCanvas: TCanvas;
i: Integer;
LMin: Integer;
LMax: Integer;
LX, LY: Integer;
LSize: TSize;
LText: String;
begin
LDC := Message.DC;
if (LDC = 0) then LDC := BeginPaint(Handle, LPaintStruct);
LCanvas := TCanvas.Create;
try
LCanvas.Handle := LDC;
LCanvas.Font := Font;
LCanvas.Brush.Color := clSkyBlue;
LCanvas.FillRect(ClientRect);
LY := 1;
LMin := FirstVisibleLineIndex;
LMax := LMin + VisibleLineCount;
for i := LMin to LMax do
begin
LX := 5;
LText := Lines[i];
LCanvas.TextOut(LX, LY, LText);
LText := 'W';
GetTextExtentPoint32(LDC, PChar(LText), Length(LText), LSize);
Inc(LY, LSize.cy);
end;
finally
if (Message.DC = 0) then EndPaint(Handle, LPaintStruct);
end;
LCanvas.Free;
end;

途中、LY := 1; とか LX := 5; のような意味不明の数字がありますが、メイリオ限定で辻褄をあわせてます。
今のところ、ClientRectで一括で背景を塗りつぶしてるので、塗り残しないんですけど、サイズを変更したりするとまぁそれなりになります。

マウスで文字列を選択するとこんな感じ。キーボードで選択すると選択範囲に気づきません。ちゃんと選択されてるんですけどね。

入力するときはずれてないです。


***

ついでに、オフスクリーンバッファを使ったバージョンです。
procedure TMemoEx.WMPaint(var Message: TWMPaint);
var
LDC: HDC;
LPaintStruct: TPaintStruct;
LCanvas: TCanvas;
i: Integer;
LMin: Integer;
LMax: Integer;
LX, LY: Integer;
LSize: TSize;
LText: String;
LBitBuf: Graphics.TBitmap;
begin
LDC := Message.DC;
if (LDC = 0) then LDC := BeginPaint(Handle, LPaintStruct);
LBitBuf := Graphics.TBitmap.Create;
LBitBuf.Canvas.Font := Font;
LBitBuf.Width := Width;
LBitBuf.Height := Height;
try
LBitBuf.Canvas.Brush.Color := clSkyBlue;
LBitBuf.Canvas.FillRect(ClientRect);
LY := 1;
LMin := FirstVisibleLineIndex;
LMax := LMin + VisibleLineCount;
for i := LMin to LMax do
begin
LX := 5;
LText := Lines[i];
LBitBuf.Canvas.TextOut(LX, LY, LText);
LText := 'W';
GetTextExtentPoint32(LDC, PChar(LText), Length(LText), LSize);
Inc(LY, LSize.cy + 2);
end;
BitBlt(LDC, 0, 0, ClientWidth, ClientHeight,
LBitBuf.Canvas.Handle, 0, 0, SRCCOPY);
finally
if (Message.DC = 0) then EndPaint(Handle, LPaintStruct);
LBitBuf.Free;
end;
end;

さっきにの辻褄数字に加えて、なぜか行送りの量に+2しないとずれてしまう不思議。Inc(LY, LSize.cy + 2); よくわかりません。でもウィンドウサイズの変更限定ならさすがにちらつかないです。

ちゃんと真似できてます。

マウスで文字列を選択すると一緒の症状。異常にちらつきます。

入力するときは良い感じ。


***

とりあえず先に進むために、inherited;なWM_PAINTと、滅WM_ERASEBKGNDで行きます
関連記事
スポンサーサイト