Can a TEdit show color emoji? - windows

I'd like to see emojis in color in a TEdit or TMemo control using VCL and Delphi 10+.
Can it be done?
Text entered:
πŸ‘¨πŸΌβ€πŸŽ€πŸ‘©πŸΎβ€πŸ‘©πŸΌβ€πŸ‘§πŸ»β€πŸ‘¦πŸΏ
What I see:
What I'd like to see:

Your question made me curious, so tried and here is the result:
Drawing colored fonts in general
Apparently FMX supports this out of the box in later versions, but not in Seattle, which I happen to have. I don't know if the VCL also supports it out of the box in your version, but if not, you can achieve using Direct2D. The trick is to draw text using the D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT option.
In Seattle (10), this constant is not defined, and - unfortunately - not used in the default TCanvas-compatible functions. But you can call DrawText or one of the other functions yourself and specify the option.
The general structure is based on this Embarcadero docwiki. The rest is peeked from TDirect2DCanvas, combined with the DrawText documentation.
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
procedure TForm1.FormPaint(Sender: TObject);
const
str: string = 'xyzπŸ‘¨πŸΌβ€πŸŽ€πŸ‘©πŸΎβ€πŸ‘©πŸΌβ€πŸ‘§πŸ»β€πŸ‘¦πŸΏ';
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
c := TDirect2DCanvas.Create(Canvas.Handle, Rect(0, 0, 100, 100));
c.BeginDraw;
try
r.left := 0;
r.top := 0;
r.right := 100;
r.bottom := 50;
// Brush determines the font color.
c.Brush.Color := clBlack;
c.RenderTarget.DrawText(
PWideChar(str), Length(Str), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;
This little piece of code works in a fairly ugly way (in terms of positioning the text), but you can also peek in TDirect2DCanvas, and copy the implementation of one of its text methods to create a function for outputting text in a specific way that you want. And after that it should be fairly easy to apply this to your own TGraphicControl or TCustomControl descendant to create an emoji-supporting label.
Doing that in TEdit
To manage this in TEdit is harder, since drawing the text (and the emoji) is handled by the control itself. It should be possible to create a TEdit descendant and/or hook into its WM_PAINT message and paint over the text using this same trick, but I'm not sure how well that would work.
I gave that a quick shot, but it doesn't really work well perfectly, especially when editing. So I've made this descendant of TEdit. When focused, it draws the text in a normal way, and the colored emoji will be black and white, and split into two characters (the emoji and the color combination character). When the edit loses its focus, the custom paint code takes over, which works well in that scenario. Maybe you can attempt to polish it to make it work while editing as well, but then you have to take scrolling, positioning the caret and other stuff into account. For a TMemo descendant that would be even harder. I hope you're happy with just colored display for now. :-)
type
TMyEdit = class(Vcl.StdCtrls.TEdit)
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
end;
implementation
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
const
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
constructor TMyEdit.Create(AOwner: TComponent);
begin
inherited;
DoubleBuffered := True;
end;
procedure TMyEdit.PaintWindow(DC: HDC);
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
// Default drawing when focused. Otherwise do the custom draw.
if Focused then
begin
Inherited;
Exit;
end;
c := TDirect2DCanvas.Create(dc, ClientRect);
c.BeginDraw;
try
r.left := ClientRect.Left;
r.top := ClientRect.Top;
r.right := ClientRect.Right;
r.bottom := ClientRect.Bottom;
// Basic font properties
c.Font.Assign(Font);
// Brush determines the font color.
c.Brush.Color := Font.Color;
c.RenderTarget.DrawText(
PWideChar(Text), Length(Text), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;

Related

Change background color of TListView header in older Delphi

An old app using Delphi 7, but should be similar code in older Delphi versions up to perhaps 2010. I need to change the background color of a TListView header so I can offer a dark theme. I can change the colors of everything else. I found the thread below which apparently works for changing the font color on a column header, but I need to adjust the background color of the entire header as well.
Delphi: ListView (vsReport) single column header caption with custom font color?
Can someone please help as I am lost. Windows message notifications are beyond my comprehension.
Many thanks.
I'm fairly proud of myself and somehow found bits and pieces of code that all went together to make it all work. Something like this...
procedure TTntListView.WMNotify(var AMessage: TWMNotify);
const
DT_ALIGN: array[TAlignment] of integer = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
NMCustomDraw: TNMCustomDraw;
i: Integer;
r: TRect;
begin
if (AMessage.NMHdr.hwndFrom = FHeaderHandle) and
(AMessage.NMHdr.code = NM_CUSTOMDRAW) then
begin
NMCustomDraw := PNMCustomDraw(TMessage(AMessage).LParam)^;
case NMCustomDraw.dwDrawStage of
CDDS_PREPAINT: AMessage.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: begin
i := NMCustomDraw.dwItemSpec;
r := NMCustomDraw.rc;
FillRect(NMCustomDraw.hdc, r, Sender.Canvas.Brush.Handle);
SetBkColor(NMCustomDraw.hdc, ColorToRGB(Sender.Canvas.Brush.Color));
SetTextColor(NMCustomDraw.hdc, ColorToRGB(Sender.Canvas.Font.Color));
DrawEdge(NMCustomDraw.hdc,r,EDGE_SUNKEN,BF_LEFT);
Inc(r.Left,2);
Dec(r.Right,2);
if Sender.Column[i].Alignment = taLeftJustify then Inc(r.Left,3)
else Dec(r.Right,3);
DrawTextW(NMCustomDraw.hdc,
pWideChar(Sender.Column[i].Caption),
length(Sender.Column[i].Caption),
r,
DT_SINGLELINE or DT_ALIGN[Sender.Column[i].Alignment] or
DT_VCENTER or DT_END_ELLIPSIS);
Message.Result := CDRF_SKIPDEFAULT;
end;
else AMessage.Result := CDRF_DODEFAULT;
end;
end
else inherited;
end;

Find out in WM_PAINT handler which region is being invalidated by InvalidateRgn

My task is to create indicator with a background scale and a pointer. When pointer moves, I would like to redraw a part of background on its previous place and then draw a new pointer.
The pointer shape is defined as a polygon from which I have created a GDI+ region.
So I have 2 region objects: the old one and the new one.
Once in 50 milliseconds I call a following routine:
procedure TForm1._timerTick(Sender: TObject);
var
g: TGPGraphics;
mx: TGPMatrix;
hr: HRGN;
begin
if _newRegion <> nil then _newRegion.Free();
if _oldRegion <> nil then _oldRegion.Free();
_newRegion := _baseRegion.Clone();
_oldRegion := _baseRegion.Clone();
mx := TGPMatrix.Create();
try
mx.RotateAt(_angle, MakePoint(250.0, 120.0));
_oldRegion.Transform(mx);
mx.Reset();
Inc(_angle);
if _angle >= 360 then _angle := 0;
mx.RotateAt(_angle, MakePoint(250.0, 120.0));
_newRegion.Transform(mx);
finally
mx.Free();
end;
g := TGPGraphics.Create(Canvas.Handle);
try
hr := _oldRegion.GetHRGN(g);
try
InvalidateRgn(Handle, hr, False); //Restore background
finally
DeleteObject(hr);
end;
hr := _newRegion.GetHRGN(g);
try
InvalidateRgn(Handle, hr, False); //Draw new region
finally
DeleteObject(hr);
end;
finally
g.Free();
end;
end;
As you can see, I have no better idea than calling InvalidateRgn twice: once for background restore and once for pointer drawing.
The WM_PAINT handler looks as follows:
procedure TForm1.Paint();
var
g: TGPGraphics;
mx: TGPMatrix;
brs: TGPSolidBrush;
begin
inherited;
g := TGPGraphics.Create(Canvas.Handle);
mx := TGPMatrix.Create();
brs := TGPSolidBrush.Create(MakeColor(255, 255, 0));
try
if _fullDraw then begin
_fullDraw := False;
end
else begin
g.IntersectClip(_oldRegion);
end;
g.DrawImage(_img, 0, 0);
if _newRegion <> nil then begin
g.ResetClip();
g.FillRegion(brs, _newRegion);
end;
finally
brs.Free();
mx.Free();
g.Free();
end;
end;
It always does two operations: restores background and draws the pointer.
If I perform InvalidateRgn twice, then Paint will also be called twice resulting in four operations instead of two.
Is there some way to find out on Windows level inside of Paint method which region is being invalidated?
Inside your WM_PAINT handler, you can use either:
GetUpdateRect() or GetUpdateRgn(), or GetClipBox() or GetClipRgn(), on the HDC that BeginPaint() returns (in VCL, GetClipBox() is wrapped by the TCanvas.ClipRect property for easier reading).
the PAINTSTRUCT.rcPaint member that BeginPaint() fills in upon output. This is the same rectangle that GetUpdateRect() returns.
Either way will give you an update/clipping area within which the HDC needs to be painted. Any drawing you do outside of that area will simply be discarded. So you can use this as an optimization to not waste effort painting anything that would just be discarded.
If I perform InvalidateRgn twice, then Paint will also be called twice resulting in four operations instead of two.
Not true. Window invalidations are cached and consolidated until the window is actually painted and validated. You can call InvalidateRect()/InvalidateRgn() as many times as you want, and the window will not be painted until you return control to the message loop so a WM_PAINT message can then be generated (unless you force a paint by calling UpdateWindow() or RedrawWindow()). WM_PAINT is a low-priority message, it is only generated by the message queue when the window has a non-empty Update Region and no other higher-priority messages are pending. The window is not validated until WM_PAINT is processed (unless you force it by calling ValidateRect()/ValidateRgn()). See Invalidating and Validating the Update Region on MSDN for more details.

Scintilla Horizontal Scrollbar

How do I make it appear as if it were automatic like the vertical one?
The window is 300 wide so I tried setting SCI_SETSCROLLWIDTH to 300 and then less than 300 with SCI_SETSCROLLWIDTHTRACKING turned on but the scrollbar will either still always show or not show at all.
If you want to show/hide the horizontal SB, you need SCI_SETHSCROLLBAR(bool visible), but you need to know where the end of the line is. So you can try what I have below. It is fairly low impact since you are only looking at the currently visible lines.
Note that I use a Delphi wrapper for the scintilla control/DLL, but the calls can all be made with the regular scintilla messages (same basic names), and I have a few functions I use which are below as well. You could call this where you get the SCN_UPDATEUI message.
function GetFirstVisiblePos: Integer;
begin
Result := PositionFromPoint(0,0);
end;
function GetLastVisiblePos: Integer;
begin
Result := PositionFromPoint(clientwidth,clientheight);
end;
function GetFirstVisibleLine: Integer;
begin
Result := LineFromPosition(GetFirstVisiblePos);
end;
function GetLastVisibleLine: Integer;
begin
Result := LineFromPosition(GetLastVisiblePos);
end;
[...]
var
i: integer;
x, endPos: integer;
needHSB: boolean;
begin
if not WordWrap then //Only need to do this if not wordwrapped
begin
x := ClientWidth ;
needHSB := false;
//Check currently visible lines only
for i := GetFirstVisibleLine to GetLastVisibleLine do
begin
//GetXOffset adds left scroll spacing if we are already scrolled left some.
endPos := PointXFromPosition(GetLineEndPosition(i) ) - x + GetXOffset ;
needHSB := endPos > ClientWidth;
if needHSB then break; //once set, don't need to set again...
end;
SetHScrollBar( needHSB );
end;
end;
Try that and that should do what you are after (if I read the original question correctly). It worked for me, although I was after something a little different originally.
I needed a way to try and control the horizontal scroll width which the sci control does not do automatically (for me anyway; SCI_SETSCROLLWIDTHTRACKING seems to be what you'd use for this but I was never able to get to work (at least in the way it implies it should work in the docs). I came up with the code below. In my app the code is in SCN_UPDATEUI message area.
//Set new scroll width if there's a line longer than the current scroll
//width can show:
if not WordWrap then //Only need to do this if not wordwrapped
begin
//vars: i, x, endPos, LeftScrollPos : integer;
x := ClientWidth ;
//Check currently visible lines only
for i := GetFirstVisibleLine to GetLastVisibleLine do
begin
//GetXOffset adds extra left scroll space if we are already scrolled left some.
//24 is just a fudge factor to add a little visual space after a long line.
endPos := PointXFromPosition(GetLineEndPosition(i) ) - x + GetXOffset + 24;
if endPos > 2000 then //Greater than the control's default
if endPos > ( GetScrollWidth ) then //Only need to proceed if we need more room
begin
LeftScrollPos := GetXOffset; //Store our current left scroll position
SetScrollWidth( endPos ) ; //This sets left scroll to 0, so...
SetXOffset( LeftScrollPos ); //Restore current left scroll position
end;
end;
end;

Adding non-VCL window into VCL align queue

Some background (kind of a continuation of TLabel and TGroupbox Captions Flicker on Resize):
So, I have an application that loads different plugins and creates a
new tab on a TPageControl for each one.
Each DLL has a TForm associated with it.
The forms are created with their parent hWnd as the new TTabSheet.
Since the TTabSheets aren't a parent of the form as far as VCL is
concerned (didn't want to use dynamic RTL, and plugins made in
other languages) I have to handle resizes manually.
I just seem to be running into a lot of new issues (but great learning experiences) for this "plugin" type of application.
So, my current struggle is trying to have a plugin that doesn't get inserted into a TTabSheet but will be resized and aligned directly on the form.
Since this would be easier to explain with a picture:
Now I could manually do the alignment and the resize, but I'd much rather have the VCL alignment procedures (alClient, alTop, etc) do it for me. That way I would just have to set the plugins alignment on its form without thinking.
After looking through the VCL source I began to step through the align code and how it's called. Basically when a TControl gets a WM_RESIZE it will:
Call Realign() which calls AlignControl()
AlignControl() will get the client rect and call AlignControls()
AlignControls() will call DoAlign() for each TAlignment type in this order: alTop, alBottom, alLeft, alRight, alClient, alCustom, alNone
DoAlign() will loop through FControls and FWinControls (which are TLists) and will align them appropriately
So my thought process is that if I create a new TWinControl, set it's handle to the plugins form (window) handle, and insert it into the FControls list with the proper align it should do my work for me.
Of course I'm here, so it failed miserably. I even get an AV when exiting the application about an invalid window handle. My guess is that the TWinControl I created is trying to free the handle of the plugins form (window) which doesn't exist any more.
What I've tried:
procedure AddHandleToControlList(AHandle: DWORD; Align: TAlign);
var
NewWinControl : TWinControl;
begin
NewWinControl := TWinControl.Create(frmMain);
NewWinControl.WindowHandle := AHandle;
NewWinControl.Align := Align;
NewWinControl.Width := frmMain.ClientWidth;
NewWinControl.Height := 30;
NewWinControl.Parent := frmMain;
end;
procedure AddHandleToControlList(AHandle: DWORD; Align: TAlign);
var
NewWinControl : TWinControl;
begin
NewWinControl := TWinControl.Create(frmMain);
NewWinControl.WindowHandle := AHandle;
NewWinControl.Align := Align;
NewWinControl.Width := frmMain.ClientWidth;
NewWinControl.Height := 30;
TWinControl(frmMain).Insert(NewWinControl);
end;
Soooo, thoughts?
EDIT 1:
Ok, so this correctly adds the control to the list and conforms the the TAlign set (why is it that I spend 8 hours trying to figure something out, I post here, and then the answer just appears...oh well someone might find this question and my ramblings useful):
procedure AddHandleToControlList(AHandle: DWORD; AName: PChar; ATop, ALeft, AWidth, AHeight: Integer; AAlign: TAlign);
var
NewWinControl : TWinControl;
begin
NewWinControl := TWinControl.Create(frmMain);
With NewWinControl Do
begin
Name := AName;
Top := ATop;
Left := ALeft;
Width := AWidth;
Height := AHeight;
Align := AAlign;
WindowHandle := AHandle;
Visible := True;
end;
TWinControl(frmMain).InsertControl(NewWinControl);
end;
The issue now is that when the application closes, I get the invalid error AV...I shall continue!!
EDIT 2:
Ok, so it is TWinControl.DestroyWindowHandle that raises the AV because the window handle doesn't exist any more. I'm trying to think of a clean solution.
Derive a new class from TWinControl and override its virtual DestroyWindowHandle() method to not free the HWND you provide. The default implementation of TWinControl.DestroyWindowHandle() calls the Win32 API DestroyWnd() function.

How do I load icons from a resource without suffering from aliasing?

I have a GUI application which includes a number of icons used for toolbar buttons, menu glyphs, notification icons etc. These icons are linked to the application as resources and a variety of different sizes are available. Typically, for toolbar button images I have available 16px, 24px and 32px versions. My icons are 32bpp with partial transparency.
The application is high DPI aware and adjusts the size of all visual elements according to the prevailing font scaling. So, for example, at 100% font scaling, 96dpi, the toolbar icon size is 16px. At 125% scaling, 120dpi, the toolbar icon size is 20px. I need to be able to load an icon of size 20px without any aliasing effects. How can I do this? Note that I would like to support Windows 2000 and later.
On Vista and up a number of new functions were added that make this task trivial. The function that is most appropriate here is LoadIconWithScaleDown.
This function will first search the icon file for an icon having exactly the same size. If a match is not found, then unless both cx and cy match one of the standard icon sizesβ€”16, 32, 48, or 256 pixelsβ€” the next largest icon is selected and then scaled down to the desired size. For example, if an icon with an x dimension of 40 pixels is requested by the callign application, the 48-pixel icon is used and scaled down to 40 pixels. In contrast, the LoadImage function selects the 32-pixel icon and scales it up to 40 pixels.
If the function is unable to locate a larger icon, it defaults to the standard behavior of finding the next smallest icon and scaling it up to the desired size.
In my experience this function does an excellent job of scaling and the results show no signs of aliasing.
For earlier versions of Windows there is, to the very best of my knowledge, no single function that can perform this task adequately. The results obtained from LoadImage are of very poor quality. Instead the best approach I have found is as follows:
Examine the available images in the resource to find the image with the largest size that is less than desired icon size.
Create a new icon of the desired size and initialise it to be fully transparent.
Place the smaller icon from the resource in the centre of the new (larger) icon.
This means that there will be a small transparent border around the icon, but typically this is small enough to be insignificant. The ideal option would be to use code that could scale down just as LoadIconWithScaleDown does, but that is non-trivial to write.
So, without further ado here is the code I use.
unit uLoadIconResource;
interface
uses
SysUtils, Math, Classes, Windows, Graphics, CommCtrl;
function LoadIconResourceSize(const ResourceName: string; IconSize: Integer): HICON;//will not throw an exception
function LoadIconResourceMetric(const ResourceName: string; IconMetric: Integer): HICON;
implementation
function IconSizeFromMetric(IconMetric: Integer): Integer;
begin
case IconMetric of
ICON_SMALL:
Result := GetSystemMetrics(SM_CXSMICON);
ICON_BIG:
Result := GetSystemMetrics(SM_CXICON);
else
raise EAssertionFailed.Create('Invalid IconMetric');
end;
end;
procedure GetDIBheaderAndBits(bmp: HBITMAP; out bih: BITMAPINFOHEADER; out bits: Pointer);
var
pbih: ^BITMAPINFOHEADER;
bihSize, bitsSize: DWORD;
begin
bits := nil;
GetDIBSizes(bmp, bihSize, bitsSize);
pbih := AllocMem(bihSize);
Try
bits := AllocMem(bitsSize);
GetDIB(bmp, 0, pbih^, bits^);
if pbih.biSize<SizeOf(bih) then begin
FreeMem(bits);
bits := nil;
exit;
end;
bih := pbih^;
Finally
FreeMem(pbih);
End;
end;
function CreateIconFromSmallerIcon(IconSize: Integer; SmallerIcon: HICON): HICON;
procedure InitialiseBitmapInfoHeader(var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := IconSize;
bih.biHeight := 2*IconSize;//height of xor bitmap plus height of and bitmap
bih.biPlanes := 1;
bih.biBitCount := 32;
bih.biCompression := BI_RGB;
end;
procedure CreateXORbitmap(const sbih, dbih: BITMAPINFOHEADER; sptr, dptr: PDWORD);
var
line, xOffset, yOffset: Integer;
begin
xOffset := (IconSize-sbih.biWidth) div 2;
yOffset := (IconSize-sbih.biHeight) div 2;
inc(dptr, xOffset + IconSize*yOffset);
for line := 0 to sbih.biHeight-1 do begin
Move(sptr^, dptr^, sbih.biWidth*SizeOf(DWORD));
inc(dptr, IconSize);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr, sbih.biWidth);//likewise
end;
end;
var
SmallerIconInfo: TIconInfo;
sBits, xorBits: PDWORD;
xorScanSize, andScanSize: Integer;
xorBitsSize, andBitsSize: Integer;
sbih: BITMAPINFOHEADER;
dbih: ^BITMAPINFOHEADER;
resbitsSize: DWORD;
resbits: Pointer;
begin
Result := 0;
Try
if not GetIconInfo(SmallerIcon, SmallerIconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(SmallerIconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biWidth>IconSize) or (sbih.biHeight>IconSize) or (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(IconSize, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*IconSize);
andScanSize := BytesPerScanline(IconSize, 1, 32);
xorBitsSize := IconSize*xorScanSize;
andBitsSize := IconSize*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(dbih^);
xorBits := resbits;
inc(PByte(xorBits), SizeOf(BITMAPINFOHEADER));
CreateXORbitmap(sbih, dbih^, sBits, xorBits);
//don't need to fill in the mask bitmap when using RGBA
Result := CreateIconFromResourceEx(resbits, resbitsSize, True, $00030000, IconSize, IconSize, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if SmallerIconInfo.hbmMask<>0 then begin
DeleteObject(SmallerIconInfo.hbmMask);
end;
if SmallerIconInfo.hbmColor<>0 then begin
DeleteObject(SmallerIconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(SmallerIcon);
End;
end;
function LoadIconResourceSize(const ResourceName: string; IconSize: Integer): HICON;//will not throw an exception
function LoadImage(IconSize: Integer): HICON;
begin
Result := Windows.LoadImage(HInstance, PChar(ResourceName), IMAGE_ICON, IconSize, IconSize, LR_DEFAULTCOLOR);
end;
type
TGrpIconDir = packed record
idReserved: Word;
idType: Word;
idCount: Word;
end;
TGrpIconDirEntry = packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wPlanes: Word;
wBitCount: Word;
dwBytesInRes: DWORD;
wID: WORD;
end;
var
i, BestAvailableIconSize, ThisSize: Integer;
ResourceNameWide: WideString;
Stream: TResourceStream;
IconDir: TGrpIconDir;
IconDirEntry: TGrpIconDirEntry;
begin
//LoadIconWithScaleDown does high quality scaling and so we simply use it if it's available
ResourceNameWide := ResourceName;
if Succeeded(LoadIconWithScaleDown(HInstance, PWideChar(ResourceNameWide), IconSize, IconSize, Result)) then begin
exit;
end;
//XP: find the closest sized smaller icon and draw without stretching onto the centre of a canvas of the right size
Try
Stream := TResourceStream.Create(HInstance, ResourceName, RT_GROUP_ICON);
Try
Stream.Read(IconDir, SizeOf(IconDir));
Assert(IconDir.idCount>0);
BestAvailableIconSize := high(BestAvailableIconSize);
for i := 0 to IconDir.idCount-1 do begin
Stream.Read(IconDirEntry, SizeOf(IconDirEntry));
Assert(IconDirEntry.bWidth=IconDirEntry.bHeight);
ThisSize := IconDirEntry.bHeight;
if ThisSize=0 then begin//indicates a 256px icon
continue;
end;
if ThisSize=IconSize then begin
//a perfect match, no need to continue
Result := LoadImage(IconSize);
exit;
end else if ThisSize<IconSize then begin
//we're looking for the closest sized smaller icon
if BestAvailableIconSize<IconSize then begin
//we've already found one smaller
BestAvailableIconSize := Max(ThisSize, BestAvailableIconSize);
end else begin
//this is the first one that is smaller
BestAvailableIconSize := ThisSize;
end;
end;
end;
if BestAvailableIconSize<IconSize then begin
Result := CreateIconFromSmallerIcon(IconSize, LoadImage(BestAvailableIconSize));
if Result<>0 then begin
exit;
end;
end;
Finally
FreeAndNil(Stream);
End;
Except
;//swallow because this routine is contracted not to throw exceptions
End;
//final fallback: make do without
Result := 0;
end;
function LoadIconResourceMetric(const ResourceName: string; IconMetric: Integer): HICON;
begin
Result := LoadIconResourceSize(ResourceName, IconSizeFromMetric(IconMetric));
end;
end.
Using these function is quite obvious. They assume that the resource is located in the same module as the code. The code could readily be generalised to receive an HMODULE in case you needed support for that level of generality.
Call LoadIconResourceMetric if you wish to load icons of size equal to the system small icon or system large icon. The IconMetric parameter should be either ICON_SMALL or ICON_BIG. For toolbars, menus and notification icons, ICON_SMALL should be used.
If you wish to specify the icon size in absolute terms use LoadIconResourceSize.
These functions return an HICON. You can of course assign this to the Handle property of a TIcon instance. More likely you will wish to add to an image list. The easiest way to do this is to call ImageList_AddIcon passing the Handle of the TImageList instance.
Note 1: Older versions of Delphi do not have LoadIconWithScaleDown defined in CommCtrl. For such Delphi versions you need to call GetProcAddress to load it. Note that this is a Unicode only API and so you must send it a PWideChar for the resource name. Like this: LoadIconWithScaleDown(..., PWideChar(WideString(ResourceName)),...).
Note 2: The definition of LoadIconWithScaleDown is flawed. If you call it after the common controls library has been initialised then you will have no problems. However, if you call the function early on in the life of your process then LoadIconWithScaleDown can fail. I have just submitted QC#101000 to report this problem. Again, if you are afflicted by this then you have to call GetProcAddress yourself.

Resources