TEdit,TMemo背景透明（SetWindowLong(WS_EX_TRANSPARENT)增加透明风格）

The component below works perfectly, except for the following problem:

1) Saves the component below in a file "trancomp.pas".
Then, install this component in Delphi;
2) Later, open Delphi and create a new project;
3) Adds a TImage and a TTransMemo to the form;
4) Opens any image in the "PICTURE" property of TIMAGE. Adjust the size of TIMAGE so that TTransMEMO stays on TIMAGE;
5) Changes the "TRANSPARENT" property of TTransMemo for "TRUE". Also change the "SCROLLBARS" property for "Vertical".
6) Now, executes the project and try to slide the scroll bar (Up/Down). See that the background image "shakes" when the text is rolled upward or down.

Please, could anybody repair this problem in the component so that it works correctly?

------------------START OF COMPONENT----------------------

unit TranComp;
 
interface
 
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
 
type
TCtrl = class(TWinControl);
 
TTransEdit = class(TEdit)
private
FAlignText: TAlignment;
FTransparent: Boolean;
FPainting: Boolean;
procedure SetAlignText(Value: TAlignment);
procedure SetTransparent(Value: Boolean);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT;
procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure CNCtlColorEdit(var Message: TWMCtlColorEdit); message CN_CTLCOLOREDIT;
procedure CNCtlColorStatic(var Message: TWMCtlColorStatic); message CN_CTLCOLORSTATIC;
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
protected
procedure RepaintWindow;
procedure CreateParams(var Params: TCreateParams); override;
procedure Change; override;
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property AlignText: TAlignment read FAlignText write SetAlignText default taLeftJustify;
property Transparent: Boolean read FTransparent write SetTransparent default false;
end;
 
// Transparent Memo
TTransMemo = class(TMemo)
private
FAlignText: TAlignment;
FTransparent: Boolean;
FPainting: Boolean;
procedure SetAlignText(Value: TAlignment);
procedure SetTransparent(Value: Boolean);
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT;
procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure CNCtlColorEdit(var Message: TWMCtlColorEdit); message CN_CTLCOLOREDIT;
procedure CNCtlColorStatic(var Message: TWMCtlColorStatic); message CN_CTLCOLORSTATIC;
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
protected
procedure RepaintWindow;
procedure CreateParams(var Params: TCreateParams); override;
procedure Change; override;
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property AlignText: TAlignment read FAlignText write SetAlignText default taLeftJustify;
property Transparent: Boolean read FTransparent write SetTransparent default false;
end;
 
procedure Register;
 
implementation
 
const
BorderRec: array[TBorderStyle] of Integer = (, -);
 
procedure Register;
begin
RegisterComponents('Transparent Components', [TTransEdit, TTransMemo]);
end;
 
function GetScreenClient(Control: TControl): TPoint;
var
p: TPoint;
begin
p := Control.ClientOrigin;
ScreenToClient(Control.Parent.Handle, p);
Result := p;
end;
 
constructor TTransEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAlignText := taLeftJustify;
FTransparent := false;
FPainting := false;
end;
 
destructor TTransEdit.Destroy;
begin
inherited Destroy;
end;
 
procedure TTransEdit.SetAlignText(Value: TAlignment);
begin
if FAlignText <> Value then
begin
FAlignText := Value;
RecreateWnd;
Invalidate;
end;
end;
 
procedure TTransEdit.SetTransparent(Value: Boolean);
begin
if FTransparent <> Value then
begin
FTransparent := Value;
Invalidate;
end;
end;
 
procedure TTransEdit.WMEraseBkGnd(var Message: TWMEraseBkGnd);
var
DC: hDC;
i: integer;
p: TPoint;
begin
if FTransparent then
begin
if Assigned(Parent) then
begin
DC := Message.DC;
i := SaveDC(DC);
p := GetScreenClient(self);
p.x := -p.x;
p.y := -p.y;
MoveWindowOrg(DC, p.x, p.y);
SendMessage(Parent.Handle, $, DC, );
TCtrl(Parent).PaintControls(DC, nil);
RestoreDC(DC, i);
end;
end else inherited;
end;
 
procedure TTransEdit.WMPaint(var Message: TWMPaint);
begin
inherited;
if FTransparent then
if not FPainting then
RepaintWindow;
end;
 
procedure TTransEdit.WMNCPaint(var Message: TMessage);
begin
inherited;
end;
 
procedure TTransEdit.CNCtlColorEdit(var Message: TWMCtlColorEdit);
begin
inherited;
if FTransparent then
SetBkMode(Message.ChildDC, );
end;
 
procedure TTransEdit.CNCtlColorStatic(var Message: TWMCtlColorStatic);
begin
inherited;
if FTransparent then
SetBkMode(Message.ChildDC, );
end;
 
procedure TTransEdit.CMParentColorChanged(var Message: TMessage);
begin
inherited;
if FTransparent then
Invalidate;
end;
 
procedure TTransEdit.WMSize(var Message: TWMSize);
begin
inherited;
Invalidate;
end;
 
procedure TTransEdit.WMMove(var Message: TWMMove);
begin
inherited;
Invalidate;
end;
 
procedure TTransEdit.RepaintWindow;
var
DC: hDC;
TmpBitmap, Bitmap: hBitmap;
begin
if FTransparent then
begin
FPainting := true;
HideCaret(Handle);
DC := CreateCompatibleDC(GetDC(Handle));
TmpBitmap := CreateCompatibleBitmap(GetDC(Handle), Succ(ClientWidth), Succ(ClientHeight));
Bitmap := SelectObject(DC, TmpBitmap);
PaintTo(DC, , );
BitBlt(GetDC(Handle), BorderRec[BorderStyle], BorderRec[BorderStyle], ClientWidth, ClientHeight, DC, , , SRCCOPY);
SelectObject(DC, Bitmap);
DeleteDC(DC);
ReleaseDC(Handle, GetDC(Handle));
DeleteObject(TmpBitmap);
ShowCaret(Handle);
FPainting := false;
end;
end;
 
procedure TTransEdit.CreateParams(var Params: TCreateParams);
const
Alignments: array [TAlignment] of DWord = (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or Alignments[FAlignText];
end;
 
procedure TTransEdit.Change;
begin
RepaintWindow;
inherited Change;
end;
 
procedure TTransEdit.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
end;
 
// Transparent Memo
constructor TTransMemo.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAlignText := taLeftJustify;
FTransparent := false;
FPainting := false;
end;
 
destructor TTransMemo.Destroy;
begin
inherited Destroy;
end;
 
procedure TTransMemo.SetAlignText(Value: TAlignment);
begin
if FAlignText <> Value then
begin
FAlignText := Value;
RecreateWnd;
Invalidate;
end;
end;
 
procedure TTransMemo.SetTransparent(Value: Boolean);
begin
if FTransparent <> Value then
begin
FTransparent := Value;
Invalidate;
end;
end;
 
procedure TTransMemo.WMEraseBkGnd(var Message: TWMEraseBkGnd);
var
DC: hDC;
i: integer;
p: TPoint;
begin
if FTransparent then
begin
if Assigned(Parent) then
begin
DC := Message.DC;
i := SaveDC(DC);
p := GetScreenClient(self);
p.x := -p.x;
p.y := -p.y;
MoveWindowOrg(DC, p.x, p.y);
SendMessage(Parent.Handle, $, DC, );
TCtrl(Parent).PaintControls(DC, nil);
RestoreDC(DC, i);
end;
end else inherited;
end;
 
procedure TTransMemo.WMPaint(var Message: TWMPaint);
begin
inherited;
if FTransparent then
if not FPainting then
RepaintWindow;
end;
 
procedure TTransMemo.WMNCPaint(var Message: TMessage);
begin
inherited;
end;
 
procedure TTransMemo.CNCtlColorEdit(var Message: TWMCtlColorEdit);
begin
inherited;
if FTransparent then
SetBkMode(Message.ChildDC, );
end;
 
procedure TTransMemo.CNCtlColorStatic(var Message: TWMCtlColorStatic);
begin
inherited;
if FTransparent then
SetBkMode(Message.ChildDC, );
end;
 
procedure TTransMemo.CMParentColorChanged(var Message: TMessage);
begin
inherited;
if FTransparent then
Invalidate;
end;
 
procedure TTransMemo.WMSize(var Message: TWMSize);
begin
inherited;
Invalidate;
end;
 
procedure TTransMemo.WMMove(var Message: TWMMove);
begin
inherited;
Invalidate;
end;
 
procedure TTransMemo.RepaintWindow;
var
DC: hDC;
TmpBitmap, Bitmap: hBitmap;
begin
if FTransparent then
begin
FPainting := true;
HideCaret(Handle);
DC := CreateCompatibleDC(GetDC(Handle));
TmpBitmap := CreateCompatibleBitmap(GetDC(Handle), Succ(ClientWidth), Succ(ClientHeight));
Bitmap := SelectObject(DC, TmpBitmap);
PaintTo(DC, , );
BitBlt(GetDC(Handle), BorderRec[BorderStyle], BorderRec[BorderStyle], ClientWidth, ClientHeight, DC, , , SRCCOPY);
SelectObject(DC, Bitmap);
DeleteDC(DC);
ReleaseDC(Handle, GetDC(Handle));
DeleteObject(TmpBitmap);
ShowCaret(Handle);
FPainting := false;
end;
end;
 
procedure TTransMemo.CreateParams(var Params: TCreateParams);
const
Alignments: array [TAlignment] of DWord = (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or Alignments[FAlignText];
end;
 
procedure TTransMemo.Change;
begin
RepaintWindow;
inherited Change;
end;
 
procedure TTransMemo.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
end;
 
end.

下面的代码如果memo已有内容，回到已有内容中间处修改，旧的文本笔画会和新的文本笔画混合。文本笔画背景未完全檫除。效果不好

type
TForm1 =class(TForm)
private
  { Private declarations }
  FBitmap: TBitmap;
  FBrush: HBRUSH;
  Edit1: TEdit;
  Memo1: TMemo;
  Image2:TImage;//背景图片
protected
  procedure WndProc(var Message: TMessage); override;  
 
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  FBitmap := TBitmap.Create;
  FBitmap.SetSize(Memo1.Width,Memo1.Height);
  FBitMap.Canvas.CopyRect(
  types.Rect(,,FBitmap.Width,FBitmap.Height),
  Image2.Canvas,
  types.Rect(memo1.Left,memo1.Top,memo1.Left+Memo1.Width,memo1.Top+Memo1.Height));
  FBrush := CreateSolidBrush(FBitmap.Handle);
 
SetWindowLong(Edit1.Handle,GWL_EXSTYLE,GetWindowLong(Edit1.Handle,GWL_EXSTYLE) or WS_EX_TRANSPARENT); // 增加透明风格
SetWindowLong(Memo1.Handle,GWL_EXSTYLE,GetWindowLong(Memo1.Handle,GWL_EXSTYLE) or WS_EX_TRANSPARENT);
end;
 
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Brush.Handle:=FBrush;
Canvas.Rectangle(,,width,height);
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_CTLCOLOREDIT, WM_CTLCOLORSTATIC:
SetBkMode(Message.WParam, TRANSPARENT);
Message.Result := FBrush;//GetStockObject(NULL_BRUSH);
end;
end;