Guten Tag liebe leute,
ich bin auf der suchen nach einer möglichkeit ein Tedit transperent zu machen das man es über ein bild legen kann und man das bild halt durchs edit sieht.
Dabei bin ich auf die TZ9Edit komponente gestoßen

die komponente funzt so wunderbar das problem ist aber wenn man was hinein schreibt frisst sich der speicher voll O.o

das ist die komponente:

zusammenfalten · markieren

Delphi-Quellcode:

unit Z9Edit;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Graphics;

type
  TZ9Edit = class(TEdit)
  private
    { Private declarations }
    FAlignText: TAlignment;
    FTransparent: Boolean;
    FPainting: Boolean;
    procedure SetAlignText(Value: TAlignment);
    procedure SetTransparent(Value: Boolean);
  protected
    { Protected declarations }
    procedure RepaintWindow;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Change; override;
    procedure SetParent(AParent: TWinControl); override;
    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;
    procedure PaintParent(ACanvas: TCanvas);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Align;
    property AlignText: TAlignment read FAlignText write SetAlignText default taLeftJustify;
    property Transparent: Boolean read FTransparent write SetTransparent default false;

  end;

implementation

{ TZ9Edit }

uses
  Forms;

type
  TParentControl = class(TWinControl);

const
  BorderRec: array[TBorderStyle] of Integer = (1, -1);

constructor TZ9Edit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAlignText := taLeftJustify;
  FTransparent := false;
  FPainting := false;
end;

destructor TZ9Edit.Destroy;
begin
  inherited Destroy;
end;

procedure TZ9Edit.SetAlignText(Value: TAlignment);
begin
  if FAlignText <> Value then
  begin
    FAlignText := Value;
    RecreateWnd;
    Invalidate;
  end;
end;


procedure TZ9Edit.SetTransparent(Value: Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    Invalidate;
  end;
end;

procedure TZ9Edit.WMEraseBkGnd(var Message: TWMEraseBkGnd);
var
  DC: hDC;
  i: integer;
  p: TPoint;
  canvas : TCanvas;
begin
  if FTransparent and not(csDesigning in componentstate) then
  begin
    canvas := TCanvas.create;
    try
      canvas.handle := message.dc;
      PaintParent(Canvas);
    finally
      canvas.free;
    end;
  end
  else
  begin
    canvas := TCanvas.create;
    try
      canvas.handle := message.dc;
      canvas.brush.color := Color;
      canvas.brush.style := bsSolid;
      canvas.fillrect(clientrect);
    finally
      canvas.free;
    end;
  end;
end;

procedure TZ9Edit.WMPaint(var Message: TWMPaint);
begin
  inherited;
  if FTransparent then
    if not FPainting then RepaintWindow;
end;

procedure TZ9Edit.WMNCPaint(var Message: TMessage);
begin

  inherited;
end;

procedure TZ9Edit.CNCtlColorEdit(var Message: TWMCtlColorEdit);
begin

  inherited;
  if FTransparent then SetBkMode(Message.ChildDC, 1);
end;

procedure TZ9Edit.CNCtlColorStatic(var Message: TWMCtlColorStatic);
begin

  inherited;
  if FTransparent then SetBkMode(Message.ChildDC, 1);
end;

procedure TZ9Edit.CMParentColorChanged(var Message: TMessage);
begin

  inherited;
  if FTransparent then Invalidate;
end;

procedure TZ9Edit.WMSize(var Message: TWMSize);
var
  r : TRect;
begin

  inherited;
  r := ClientRect;
  InvalidateRect(handle,@r,false);
end;


procedure TZ9Edit.WMMove(var Message: TWMMove);
var
  r : TRect;
begin

  inherited;
  Invalidate;
  r := ClientRect;
  InvalidateRect(handle,@r,false);
end;

procedure TZ9Edit.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, 0, 0);
    BitBlt(GetDC(Handle), BorderRec[BorderStyle] + BorderWidth, BorderRec[BorderStyle] + BorderWidth, ClientWidth, ClientHeight, DC, 1, 1, SRCCOPY);
    SelectObject(DC, Bitmap);
    DeleteDC(DC);
    ReleaseDC(Handle, GetDC(Handle));
    DeleteObject(TmpBitmap);
    ShowCaret(Handle);
    FPainting := false;

  end;
end;

procedure TZ9Edit.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 TZ9Edit.Change;
begin
  RepaintWindow;
  inherited Change;
end;

procedure TZ9Edit.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
end;

procedure TZ9Edit.PaintParent(ACanvas: TCanvas);
var
  I, Count, X, Y, SaveIndex: integer;
  DC: cardinal;
  R, SelfR, CtlR: TRect;
  Control : TControl;
begin
  Control := Self;
  if Control.Parent = nil then Exit;
  Count := Control.Parent.ControlCount;
  DC := ACanvas.Handle;

  SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
  X := -Control.Left; Y := -Control.Top;
  // Copy parent control image
  SaveIndex := SaveDC(DC);
  SetViewportOrgEx(DC, X, Y, nil);
  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
  TParentControl(Control.Parent).Perform(WM_ERASEBKGND,DC,0);
  TParentControl(Control.Parent).PaintWindow(DC);
  RestoreDC(DC, SaveIndex);


  //Copy images of graphic controls
  for I := 0 to Count - 1 do begin
    if (Control.Parent.Controls[I] <> nil) then
    begin
      if Control.Parent.Controls[I] = Control then break;

      with Control.Parent.Controls[I] do
      begin
        CtlR := Bounds(Left, Top, Width, Height);
        if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
        begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_ERASEBKGND,DC,0);
          Perform(WM_PAINT, integer(DC), 0);
          RestoreDC(DC, SaveIndex);
        end;
      end;
    end;
  end;
end;

end.

Ich hab nach einer kleinen fehler suche festgestellt das es an der procedure liegt:

zusammenfalten · markieren

Delphi-Quellcode:

procedure TZ9Edit.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, 0, 0);
    BitBlt(GetDC(Handle), BorderRec[BorderStyle] + BorderWidth, BorderRec[BorderStyle] + BorderWidth, ClientWidth, ClientHeight, DC, 1, 1, SRCCOPY);
    SelectObject(DC, Bitmap);
    DeleteDC(DC);
    ReleaseDC(Handle, GetDC(Handle));
    DeleteObject(TmpBitmap);
    ShowCaret(Handle);
    FPainting := false;

  end;
end;

kommentiert man diese aus tritt kein speicher leak auf
es ist kein leak in dem sinne das ein objekt nicht freigeben wird und das über delphi angezeigt wird man bemerkt es nur über den taskmanager
mein delphi wissen ist noch nicht so weit das ich mit der obrigen procedure etwas anfangen kann dh ich weiß nicht was daran falsch ist.

Ich hoffe ihr könnt mir helfen den bug zu beheben oder kennt jemand eine andere möglichkeit ?

schonmal danke im vorraus MFG Sportkeks

Ich glaube da fehlt noch in der RepaintWindow-Procedure ein :

markieren

Delphi-Quellcode:

//...
    DeleteObject(TmpBitmap);
    DeleteObject(Bitmap); // <--<<
    ShowCaret(Handle);

So beim schnellen drübergucken.

Zitat von turboPASCAL:

Ich glaube da fehlt noch in der RepaintWindow-Procedure ein :

markieren

Delphi-Quellcode:

//...
    DeleteObject(TmpBitmap);
    DeleteObject(Bitmap); // <--<<
    ShowCaret(Handle);

So beim schnellen drübergucken.

Hmm ne das war es leider nicht immer noch dieser bug

ich hab mal ein kleines testprogramm gemacht:

Hat den sonst keine eine idee wo der fehler liegen könnte ?
Das ist meine einzigste möglichkeit...

Zitat von sportkeks:

Hat den sonst keine eine idee wo der fehler liegen könnte ?
Das ist meine einzigste möglichkeit...

Versuch die LMD-Tool SE ist Freeware und Transparenz is auch da

naja ich hab das mal getestet ist nicht wirklich toll ist ziehmlich umständlich gemacht

http://wiki.lmd.de/index.php/LMD_VCL_-_Transparency

aber danke für den tipp, findet sich den keiner der den fehler im quelltext findet ?

Der Fehler ist ganz simpel, hab ich nach 2 Minuten gehabt.
In der RepaintWindow wird GetDC aufgerufen, aber der erzeugte DC nirgends gespeichert. Im Gegenteil: In der Zeile, die zum Freigeben gedacht war, wird extra ein weiterer erzeugt und der dann freigegeben.
Dadurch kann der SPeicher auch nicht wieder freigegeben werden. Korrekt sieht das so aus:

zusammenfalten · markieren

Delphi-Quellcode:

procedure TZ9Edit.RepaintWindow;
var
  DC, MyDC: hDC;
  TmpBitmap, Bitmap: hBitmap;
begin
  if FTransparent then
  begin

    MyDC := GetDC(Handle);
    FPainting := true;
    HideCaret(Handle);
    DC := CreateCompatibleDC(MyDC);
    TmpBitmap := CreateCompatibleBitmap(MyDC, Succ(ClientWidth), Succ(ClientHeight));
    Bitmap := SelectObject(DC, TmpBitmap);
    PaintTo(DC, 0, 0);
    BitBlt(MyDC, BorderRec[BorderStyle] + BorderWidth,
      BorderRec[BorderStyle] + BorderWidth, ClientWidth, ClientHeight, DC, 1, 1, SRCCOPY);
    SelectObject(DC, Bitmap);
    DeleteDC(DC);
    ReleaseDC(Handle, MyDC);
    DeleteObject(TmpBitmap);
    ShowCaret(Handle);
    FPainting := false;

  end;
end;