Задний фон на TCustomObject (в частности на TTreeView)

← →
Sinka © (2006-04-14 15:31) [0]

Меня интересует как можно сделать подложку на компоненте который нельзя сделать прозрачным, например на TTreeView.
Люди добрые поделитесь готовым кодом.

Есть один пример, но его беда в том что при долгой работе(больше часа) он выдает ошибку. Если есть идеи как можно исправить пишите:

type
TMyTreeView = class(TTreeView)
private
FBitmap: TBitmap;
protected
procedure WndProc(var Message: TMessage); override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
property Bitmap: TBitmap read FBitmap write FBitmap;
end;

TTreeView = class(TMyTreeView);

TForm1 = class(TForm)
Image1: TImage;
TreeView1: TTreeView;
Button1: TButton;
XPManifest1: TXPManifest;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses
CommCtrl;

procedure TMyTreeView.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_ERASEBKGND then begin
Message.Result := 1
end else begin
case Message.Msg of
CN_NOTIFY: if TWMNotify(Message).NMHdr^.code = TVN_ITEMEXPANDING then
InvalidateRect(Handle, nil, False);
WM_KEYDOWN, WM_HSCROLL, WM_VSCROLL, WM_MOUSEWHEEL:
InvalidateRect(Handle, nil, False);
end;
inherited
end
end;

procedure TMyTreeView.WMPaint(var Message: TWMPaint);
var
DC, TempDC, TempDC1: HDC;
TempBmp, OldBmp, OldBmp1, TempBMP1: HBITMAP;
PS: TPaintStruct;
TempRect: TRect;
begin
if Message.DC <> 0 then
inherited
else begin
TempRect := ClientRect;
BeginPaint (Handle, PS);
DC := GetDC(Handle);
TempDC := CreateCompatibleDC(DC);
TempDC1 := CreateCompatibleDC(DC);
TempBMP := CreateCompatibleBitmap(DC, TempRect.Right, TempRect.Bottom);
TempBMP1 := CreateCompatibleBitmap(DC, TempRect.Right, TempRect.Bottom);
OldBmp := SelectObject(TempDC, TempBMP);
OldBmp1 := SelectObject(TempDC1, TempBMP1);
try
Message.DC := TempDC;
WMPaint(Message);
Message.DC := 0;
FillRect(TempDC1, TempRect, GetStockObject(WHITE_BRUSH));
if FBitmap <> nil then
BitBlt(TempDC1, 0, 0, FBitmap.Width, FBitmap.Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
TransparentBlt (TempDC1, 0, 0, TempRect.Right, TempRect.Bottom, TempDC, 0, 0,
TempRect.Right, TempRect.Bottom, clFuchsia);
BitBlt(DC, 0, 0, TempRect.Right, TempRect.Bottom, TempDC1, 0, 0, SRCCOPY);
finally
SelectObject (TempDC, OldBmp);
SelectObject (TempDC1, OldBmp1)
end;
DeleteObject (TempBMP);
DeleteObject (TempBMP1);
ReleaseDC (Handle, TempDC);
ReleaseDC (Handle, TempDC1);
ReleaseDC (Handle, DC);
EndPaint (Handle, PS)
end
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
TreeView1.Bitmap := Image1.Picture.Bitmap;
TreeView1.Color := clFuchsia;
TreeView1.BorderStyle := bsNone;
end;

end.

← →
Игорь Шевченко © (2006-04-14 15:41) [1]

> Если есть идеи как можно исправить пишите:

Перенести рисование в обработку сообщения WM_ERASEBKGND, например

← →
Sinka © (2006-04-17 16:00) [2]

Нельзя, потомучто я использую inherited функции WMPaint, скорее всего тут создается то что не удаляется только вот не пойму что?

> но его беда в том что при долгой работе(больше часа) он
> выдает ошибку

Утечка ресурсов. Честно говоря, лень искать в твоем коде. Посмотри хотя бы в диспетчере задач не растет ли счетчик объектов GDI

Задний фон на TCustomObject (в частности на TTreeView) Найти похожие ветки