TextOutのXOR描画
解決文字をマウスでズリッと動かしたいのですが、通常のXOR描画では残骸が残ってしまいます。
他の図形(LineTo,Arc)等ではうまく行くのですが、TextOutでは動作が異なるようです。
どのようにすれば良いのでしょうか？
ご教授お願いします。
TextOut用のBitmap用意すればいいんじゃないですか？
てかそっちの方がトータルでは高速です。
ちょっと分かりにくいと思ったので、サンプルを書いてみました。
フォームに適当なコントロールを貼り付けた後、フォーム上でMouseDown,MouseMoveしてみてください。
反転描画ということなので全てのGUIコントロールに対して色の反転した文字を上乗せする形にしてあります。
そもそも、テキスト描画にxor無いですよね？
ちなみに、この方法なら画像でも反転描画が可能ですので応用が効くと思います。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, jpeg;
type
TForm1 = class(TForm)
Edit1: TEdit; //描画確認用
Button1: TButton; //描画確認用
Image1: TImage; //描画確認用
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private 宣言 }
fDC:HDC;
fDrawPos:TPoint;
public
{ Public 宣言 }
fBitmapA:TBitmap; //背景バッファ
fBitmapB:TBitmap; //実際に描画されるイメージ
fBitmapC:TBitmap; //テキストを描画したイメージ
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function AddRect(aRectA,aRectB:TRect):TRect;
begin
Result.Top := aRectA.Top;
if Result.Top > aRectA.Bottom then Result.Top := aRectA.Bottom;
if Result.Top > aRectB.Top then Result.Top := aRectB.Top;
if Result.Top > aRectB.Bottom then Result.Top := aRectB.Bottom;
Result.Left := aRectA.Left;
if Result.Left > aRectA.Right then Result.Top := aRectA.Right;
if Result.Left > aRectB.Left then Result.Left := aRectB.Left;
if Result.Left > aRectB.Right then Result.Top := aRectB.Right;
Result.Bottom := aRectA.Bottom;
if Result.Bottom < aRectA.Top then Result.Bottom := aRectA.Top;
if Result.Bottom < aRectB.Bottom then Result.Bottom := aRectB.Bottom;
if Result.Bottom < aRectB.Top then Result.Bottom := aRectB.Top;
Result.Right := aRectA.Right;
if Result.Right < aRectA.Left then Result.Right := aRectA.Left;
if Result.Right < aRectB.Right then Result.Right := aRectB.Right;
if Result.Right < aRectB.Left then Result.Right := aRectB.Left;
end;
procedure XORDraw(var aBackBmp,aTxtBmp:TBitmap);
var
pT,pB:PByte;
i: Integer;
begin
pT := aTxtBmp.ScanLine[aTxtBmp.Height-1];
pB := aBackBmp.ScanLine[aBackBmp.Height-1];
for i := 0 to aTxtBmp.Height*aTxtBmp.Width*4 - 1 do
begin
if pT^ < 255 then
pB^ := pB^ - Round(((pB^-128)*2) * ((255-pT^)/255));
inc(pB); inc(pT);
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
str:string;
r:TRect;
begin
fDC := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE);
fBitmapA := TBitmap.Create;
fBitmapA.SetSize(Width,Height);
BitBlt(fBitmapA.Canvas.Handle,0,0,Width,Height,fDC,0,0,SRCCOPY);
fBitmapB := TBitmap.Create;
fBitmapB.SetSize(Width,Height);
BitBlt(fBitmapB.Canvas.Handle,0,0,Width,Height,fDC,0,0,SRCCOPY);
fBitmapB.Canvas.Brush.Style := bsClear;
str := 'けせらせら';
fBitmapC := TBitmap.Create;
fBitmapC.PixelFormat := pf32bit;
fBitmapC.Canvas.Font.Size := 30;
r := Rect(0,0,0,0);
Windows.DrawText(fBitmapC.Canvas.Handle,str,Length(str),&r,DT_CALCRECT );
fBitmapC.SetSize(r.Right,r.Bottom);
Windows.DrawText(fBitmapC.Canvas.Handle,str,Length(str),&r,0);
FormMouseMove(Self,Shift,X,Y);
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
aBMP:TBitmap;
r:TRect;
begin
if fDC <> 0 then
begin
r := AddRect(Rect(X,Y,X+fBitmapC.Width,Y+fBitmapC.Height),
Rect(fDrawPos.X,fDrawPos.Y,fDrawPos.X+fBitmapC.Width,fDrawPos.Y+fBitmapC.Height));
BitBlt(fBitmapB.Canvas.Handle,fDrawPos.X,fDrawPos.Y,fBitmapC.Width,fBitmapC.Height,
fBitmapA.Canvas.Handle,fDrawPos.X,fDrawPos.Y,SRCCOPY);
aBMP := TBitmap.Create;
aBMP.PixelFormat := pf32bit;
aBMP.SetSize(fBitmapC.Width,fBitmapC.Height);
BitBlt(aBMP.Canvas.Handle,0,0,aBMP.Width,aBMP.Height,fBitmapA.Canvas.Handle,X,Y,SRCCOPY);
XORDraw(aBMP,fBitmapC);
BitBlt(fBitmapB.Canvas.Handle,X,Y,fBitmapC.Width,fBitmapC.Height,aBMP.Canvas.Handle,0,0,SRCCOPY);
BitBlt(fDC,r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top,fBitmapB.Canvas.Handle,r.Left,r.Top,SRCCOPY);
fDrawPos := Point(X,Y);
aBMP.Free;
end;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
BitBlt(fDC,0,0,Width,Height,fBitmapA.Canvas.Handle,0,0,SRCCOPY);
ReleaseDC(Handle,fDC);
fBitmapA.Free;
fBitmapB.Free;
fBitmapC.Free;
fDC := 0;
end;
end.
おおっ、見事に引きずれます。
DelphiMLでそれらしき投稿は発見したのですが、具体的なコードが全く浮かびませんでした。
大変ありがとうございました。
>そもそも、テキスト描画にxor無いですよね？
Canvas.Pen.Mode := pmNotXor;
にしてから、TextOut(...) すれば一見動作するんですが、TrueTypeの外形部にゴミが残ってしまいます。
.NETのAPIでは解決しているのかも知れませんが、いかんせん16Bit時代の古いAPI仕様ですからね。
| ツイート |  |