procedure TForm2.ListView1CustomDrawSubItem(Sender: TCustomListView;
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
var DefaultDraw: Boolean);
var
rc: TRect;
oldColor: TColor;
s: string;
sz: TSize;
pt: TPoint;
begin
if (SubItem = 1) then
begin
ListView_GetSubItemRect(ListView1.Handle, Item.Index, SubItem, LVIR_BOUNDS, @rc);
oldColor := Sender.Canvas.Brush.Color;
Sender.Canvas.Brush.Color := clBtnFace;
Sender.Canvas.FillRect(rc);
Sender.Canvas.Brush.Color := oldColor;
s := DateToStr(Now);
sz := Sender.Canvas.TextExtent(s);
Sender.Canvas.Font := ListView1.Font;
Sender.Canvas.TextOut(rc.Left, Round((rc.Top+rc.Bottom-sz.cy)/2), s);
DefaultDraw := False;
end;
end;
Then subsequent subitems will draw with the system STOCK_FONT:
The bug that causes this is located in Vcl.ComCtrls.pas, in CNNotify:
procedure TCustomListView.CNNotify(var Message: TWMNotifyLV);
begin
//...snip...
with Message do
case NMHdr.code of
NM_CUSTOMDRAW:
if Assigned(FCanvas) then
with NMCustomDraw{$IFNDEF CLR}^{$ENDIF} do
try
//...snip
if (dwDrawStage and CDDS_ITEM) = 0 then
begin
//...snip...
end
else
begin
//...snip...
if (dwDrawStage and CDDS_ITEMPREPAINT) = CDDS_ITEMPREPAINT then
begin
try
//...snip...
// This is the function that should run every time, undoing the damage because someone chose to use TCanvas for drawing.
// Since the use of the TCanvas ship has sailed, the only thing ListView can do now is undo the damage caused by using TCanvas.
// This block should run every time, rather than when they *think* the canvas has changed.
// The problem is that TCanvas is not used for drawing on a GDI device context; it is not an object-oriended wrapper around GDI drawing functions.
// We know this because when a TCanvas is destroyed (or disconnected by a target device context by setting .Handle := 0),
// the last thing the TCanvas does in a violent tantrum is vandalize and destroy everyting about the DC it was drawing on:
// - it destroys the current font, and resets the DC to STOCK_FONT (a Windows 2 era thing)
// - it destroys the current background mode
// - it changes the current foreground and background colors
// It does everything possible to vandalaize as much as possible.
//
// TCanvas was not meant to "draw" on an HDC for you, it was meant to **own it**. And fundamentally it cannot own the DC owned by a listview,
// because the listview owns it. We're only here to draw on it for a while; not trash it when we're done drawing one small thing.
// The use of TCanvas is completely inappropriate, and ideally the VCL would have a TDrawCanvas that simply wraps GDI functions onto a destination HDC.
// But they don't, so we have to be sure to preserve everything about the HDC when we get rid of the TCanvas in order to put everything back.
if FCanvasChanged then
begin
FCanvasChanged := False;
FCanvas.Font.OnChange := nil;
FCanvas.Brush.OnChange := nil;
with LVCustomDraw{$IFNDEF CLR}^{$ENDIF} do
begin
clrText := ColorToRGB(FCanvas.Font.Color);
clrTextBk := ColorToRGB(FCanvas.Brush.Color);
if GetObject(FCanvas.Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then
begin
// BUG: Setting the canvas handle to zero destroys the font, and everything else about the DC
FCanvas.Handle := 0; // disconnect from hdc
//...snip...
Result := Result or CDRF_NEWFONT;
end;
end;
end;
finally
// This was where the font would have been removed from the DC if FCanvasChanged was false.
// It would happen because FCanvas.Handle would be non-zero.
FCanvas.Handle := 0;
end;
//...snip...
end
//...snip...
finally
FCanvas.Unlock;
end;
end;
//...snip...
end;
The problem is that TCanvas should not be used for drawing on a DC.
the listview provides a DC during a callback
we must draw on that supplied DC during the callback
But TCanvas is not meant to draw on a supplied DC. It is meant to own a DC. This lack of understanding of what a TCanvas is, is exemplified by the line:
FCanvas.Handle := 0; // disconnect from hdc
There is no way to "disconnect" a DC from a TCanvas. Like a psycho girlfriend, any attempt to cut it out of your life and it will go rogue:
procedure TCanvas.SetHandle(Value: HDC);
begin
//...snip
if FHandle <> 0 then
begin
DeselectHandles;
end;
//..nip...
end;
In which DeselectHandles is the crazy part:
procedure TCanvas.DeselectHandles;
begin
SelectObject(FHandle, StockPen); //trash whatever pen you had in your DC
SelectObject(FHandle, StockBrush); //trash whatever brush you had in your DC
SelectObject(FHandle, StockFont); //trash whatever font you had in your DC
end;
Ideally we would use a TCustomCanvas descendant that didn't expect to be the owner of the DC.
Instead we use a horrible hack. Before disconnecting the DC from the TCanvas:
memorize the current pen
memorize the current brush
memorize the current font
memorize the current BackgroundMode
then disconnect the DC
then restore the current pen
then restore the current brush
then restore the current font
then restore the current BackgroundMode
Patches
procedure TCustomListView.CNNotify(var Message: TWMNotifyLV);
var
nMode : Integer;
begin
//...snip...
with Message do
case NMHdr.code of
NM_CUSTOMDRAW:
if Assigned(FCanvas) then
begin
// Remember the BkMode this DC started with before any custom draw calls (likely TRANSPARENT).
// If the BkMode is altered by FCanvas.Brush and not restored then the text painted on the next ListItem
// will have a black background when the ListView is in themed mode. We initially decided to change the
// brush style but that was not picking up all cases. That likely happens because a brush style change
// doesn't necessarily materialize until some form of painting happens using the brush. We decided that
// this code should assume that the DC needs to be put back to exactly how we received it after the custom
// painting so we do that in the finally near the bottom of this case statement.
nMode := GetBkMode(NMCustomDraw{$IFNDEF CLR}^{$ENDIF}.hdc); // Record the BkMode of the HDC it was initially passed to us
with NMCustomDraw{$IFNDEF CLR}^{$ENDIF} do
try
//...snip
if (dwDrawStage and CDDS_ITEM) = 0 then
begin
//...snip...
end
else
begin
//...snip...
if (dwDrawStage and CDDS_ITEMPREPAINT) = CDDS_ITEMPREPAINT then
begin
try
FCanvas.Handle := hdc; //here we mistakenly give a ListView-supplied DC to a TCanvas object
FCanvas.Font := Font; //and setup the Font for drawing
FCanvas.Brush := Brush; //and setup the Brush for drawing
//...snip...
// This is the function that should run every time, undoing the damage because someone chose to use TCanvas for drawing.
// Since the use of the TCanvas ship has sailed, the only thing ListView can do now is undo the damage caused by using TCanvas.
// This block should run every time, rather than when they *think* the canvas has changed.
// The problem is that TCanvas is not used for drawing on a GDI device context; it is not an object-oriended wrapper around GDI drawing functions.
// We know this because when a TCanvas is destroyed (or disconnected by a target device context by setting .Handle := 0),
// the last thing the TCanvas does in a violent tantrum is vandalize and destroy everyting about the DC it was drawing on:
// - it destroys the current font, and resets the DC to STOCK_FONT (a Windows 2 era thing)
// - it destroys the current background mode
// - it changes the current foreground and background colors
// It does everything possible to vandalaize as much as possible.
//
// TCanvas was not meant to "draw" on an HDC for you, it was meant to **own it**. And fundamentally it cannot own the DC owned by a listview,
// because the listview owns it. We're only here to draw on it for a while; not trash it when we're done drawing one small thing.
// The use of TCanvas is completely inappropriate, and ideally the VCL would have a TDrawCanvas that simply wraps GDI functions onto a destination HDC.
// But they don't, so we have to be sure to preserve everything about the HDC when we get rid of the TCanvas in order to put everything back.
//if FCanvasChanged then BUGFIX: Run this every time; not just if we think the canvas has changed.
begin
//FCanvasChanged := False; BUGFIX: do this now at the end
if FCanvasChanged then
begin
FCanvas.Font.OnChange := nil;
FCanvas.Brush.OnChange := nil;
end;
with LVCustomDraw{$IFNDEF CLR}^{$ENDIF} do
begin
if FCanvasChanged then // It seems reasonable to leave these alone unless we "think" they are different.
begin
clrText := ColorToRGB(FCanvas.Font.Color);
clrTextBk := ColorToRGB(FCanvas.Brush.Color);
end;
// This is the code we really want to run all the time because it fixes the font in the hdc
if GetObject(FCanvas.Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then
begin
// BUG: Setting the canvas handle to zero destroys the font, and everything else about the DC
// The comment reveals the flawed thinking of the original developer" "Disconnect from HDC".
// There is no way to disconnect a canvas from an HDC; there's no way to cut it off.
// During the act of setting FCanvas.Handle := 0, the TCanvas vandalizes everything it possibly can about the DC
FCanvas.Handle := 0; // disconnect from hdc
//...snip...
// BUGFIX: We only set the flag if someone has changed the canvas
if FCanvasChanged then
Result := Result or CDRF_NEWFONT;
end;
end;
{$IFDEF CLR}
NMLVCustomDraw := LVCustomDraw;
{$ENDIF}
FCanvasChanged := False; //BUGFIX: this moved now here to the bottom
end;
finally
// This was where the font would have been removed from the DC if FCanvasChanged was false.
// It would happen because FCanvas.Handle would be non-zero.
// Now the code above runs, fixes the font and sets FCanvas.Handle := 0 before it gets here.
// In that case the call below does nothing because the handle value is already 0.
FCanvas.Handle := 0;
end;
//...snip...
end
//...snip...
finally
FCanvas.Unlock;
// see the note above the try statement in this block
SetBkMode(hdc, nMode);
end;
end;
//...snip...
end;
Tested
Background
If you perform drawing during a TListView.OnCustomDrawSubItem:
Then subsequent subitems will draw with the system
STOCK_FONT:The bug that causes this is located in Vcl.ComCtrls.pas, in CNNotify:
The problem is that
TCanvasshould not be used for drawing on a DC.But TCanvas is not meant to draw on a supplied DC. It is meant to own a DC. This lack of understanding of what a TCanvas is, is exemplified by the line:
There is no way to "disconnect" a DC from a TCanvas. Like a psycho girlfriend, any attempt to cut it out of your life and it will go rogue:
In which
DeselectHandlesis the crazy part:Ideally we would use a TCustomCanvas descendant that didn't expect to be the owner of the DC.
Instead we use a horrible hack. Before disconnecting the DC from the TCanvas:
then disconnect the DC
Patches