Drawing Transparent message to screen gives Out of system resources - delphi

Question

I have a code, that draws the message str directly to center of the screen without a visible window.
Why using this code first works OK, but after dozens of calls, it gives Out of system resources.
It seems to free BM ok, and I don't see that it allocates other resources at all.
procedure ttsplash.UpdateSplash(const Str: string);
var
R: TRect;
P: TPoint;
S: TPoint;
bm: TBitmap;
bf: TBlendFunction;
EXSTYLE: DWORD;
x, y: integer;
pixel: PRGBQuad;
TextRed,
TextGreen,
TextBlue: byte;
begin
if str='' then exit;
EXSTYLE := GetWindowLong(Handle, GWL_EXSTYLE);
SetWindowLong(Handle, GWL_EXSTYLE, EXSTYLE or $80000);
R := ClientRect;
bm := TBitmap.Create;
try
bm.PixelFormat := pf32bit;
// bm.SetSize(ClientWidth, ClientHeight);
bm.Width := clientwidth;
bm.height := clientheight;
bm.Canvas.Brush.Color := clBlack;
bm.Canvas.FillRect(ClientRect);
bm.Canvas.Font.Assign(Self.Font);
bm.Canvas.Font.Color := clWhite;
DrawText(bm.Canvas.Handle, PChar(Str), Length(Str), R,
DT_SINGLELINE or DT_VCENTER or DT_CENTER or DT_WORD_ELLIPSIS);
TextRed := GetRValue(ColorToRGB(Font.Color));
TextGreen := GetGValue(ColorToRGB(Font.Color));
TextBlue := GetBValue(ColorToRGB(Font.Color));
for y := 0 to bm.Height - 1 do
begin
pixel := bm.ScanLine[y];
x := 0;
while x < bm.Width do
begin
with pixel^ do
begin
rgbReserved := (rgbRed + rgbGreen + rgbBlue) div 3;
rgbBlue := TextBlue * rgbReserved div 255;
rgbGreen := TextGreen * rgbReserved div 255;
rgbRed := TextRed * rgbReserved div 255;
end;
inc(pixel);
inc(x);
end;
end;
P := Point(0, 0);
S := Point(bm.Width, bm.Height);
bf.BlendOp := AC_SRC_OVER;
bf.BlendFlags := 0;
bf.SourceConstantAlpha := 255;
bf.AlphaFormat := AC_SRC_ALPHA;
UpdateLayeredWindow(Handle, 0, nil, #S, bm.Canvas.Handle, #P, 0, #bf, ULW_ALPHA)
finally
bm.Free;
end;
end;

Answer 1

How to debug this.
Enable debug DCUs in your project options, disable optimizations.
When you get out of resources error, hit "Break".
Inspect call stack :
The problem happens in CopyBitmap when calling GDICheck -> double click GDICheck to go there.
Put a breakpoint. Run the program - count how many times it takes before the error shows up and break just before you expect the error.
Have a look around for anything that might be odd. A good place to start is the bitmap itself. Your first clue should be that each time you call this method your text is creeping away up into the corner of your invisible form.
Let's check the bitmap header and see what's going on :
Looks like your bitmap dimensions are negative. I wonder how that happened. In fact, if you watch each time this is called, your bitmap is shrinking each time. In fact, it is shrinking by 16px in width and 38px in height - the size of the window frame.
Each time you are calling UpdateLayeredWindow you are resizing your form (its outside dimension) to be the size of the client area - the size without the window frame. Your new window gets a new frame and the client area shrinks.
Eventually there is nothing left and you are trying to make a bitmap with negative dimensions. You should therefore take into account the frame size when building your bitmap. Use the form width and height rather than the client size :
bm.Width := Width;
bm.height := Height;
Also, when making API calls, please get into the habit of checking the return values for errors, as described in the documentation for the function in question. If you are not checking for errors you are asking for problems.

Answer 2

Without your feedback this remains a guess, but passing a device context with the size of your form's client area, you reduce the size of your form with each call to UpdateLayeredWindow. When, eventually, you request a negative value for the bitmap dimensions, CreateCompatibleBitmap in the code path returns an error.