I use a timage in a form which load a background image.
The problem is when i choose another picture in run time and change it by
Img_Bk.Picture.LoadFromFile( SaveFileName );
It doesnt work (Picture did n't change ). I mean it shows previous picture and doesn't show the new image during run time. Id like to change application background image during run time in my company by users which main form is a mdi form .
I use delphi 7 .
try
Img_Bk.Picture := nil ;
if FileSize > 100 then
begin
Img_Bk.Picture.LoadFromFile( SaveFileName );
end;
Img_Bk.Stretch := True ;
except
end;
LoadFromFile is known to work. So there must be a more prosaic explanation.
The first possible explanation is that FileSize is not greater than 100 and the if condition evaluates false.
Another possible explanation is that the image in the file that you specify is not the one you are expecting.
Otherwise, your code has a swallow all exception handler. And so when the call to LoadFromFile fails and raises an exception, your code ignores that and carries on as if nothing un-toward had happened. Remove the try/except, and deal with the error that will be revealed.
The real lesson for you to learn is never to write such an exception handler again.
This program should prove to you that LoadFromFile is just fine:
program ImageDemo;
uses
Types, Math, IOUtils, SHFolder, Forms, Controls, StdCtrls, ExtCtrls, jpeg;
var
Form: TForm;
Image: TImage;
Timer: TTimer;
ImageIndex: Integer = -1;
MyPictures: string;
Images: TStringDynArray;
type
THelper = class
class procedure Timer(Sender: TObject);
end;
class procedure THelper.Timer(Sender: TObject);
begin
inc(ImageIndex);
if ImageIndex>high(Images) then
ImageIndex := 0;
if ImageIndex>high(Images) then
exit;
Image.Picture.LoadFromFile(Images[ImageIndex]);
end;
function GetMyPictures: string;
var
Str: array[0..260] of Char;
begin
if SHGetFolderPath(0, CSIDL_MYPICTURES, 0, 0, Str) = S_OK then
Result := Str;
end;
procedure BuildForm;
begin
Form.ClientWidth := 700;
Form.ClientHeight := 500;
Image := TImage.Create(Form);
Image.Parent := Form;
Image.Align := alClient;
Image.Stretch := True;
Timer := TTimer.Create(Form);
Timer.OnTimer := THelper.Timer;
Timer.Interval := 100;
end;
begin
MyPictures := GetMyPictures;
Images := TDirectory.GetFiles(MyPictures, '*.jpg', TSearchOption.soAllDirectories);
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm, Form);
BuildForm;
Application.Run;
end.
I had the same problem today. After the call of LoadFromFile() the image does not change. I have tried Refresh, Repaint, Invalidate and Update -> nothing helped. Then I found that resizing the from immediately updated the image.
Finally I found that setting property Visible to false and back to true updates the image, too.
FormMain.Image1.Visible := false;
FormMain.Image1.Picture.LoadFromFile(newImageFileName);
FormMain.Image1.Visible := true;
Perhaps not the best but it works for me.
Related
In Delphi 10.1 Berlin, I'm trying to change a picture on a form by loading a PNG image from a resource.
I've followed this:
Load image from embedded resource
and used a TWICImage to automatically handle different possible image formats.
In this case I specifically want to use a PNG for transparency.
For some reason the function I've created returns nothing.
However, if I call result.savetofile('test.png') within the function the resource is succesfully saved, which verifies that the resource exists in the EXE and has been found.
function LoadImageResource(NativeInstance: NativeUInt; ImageResource: string): TWICImage;
var
Strm: TResourceStream;
WICImage: TWICImage;
begin
Strm := TResourceStream.Create(NativeInstance, ImageResource, RT_RCDATA);
try
Strm.Position := 0;
WICImage := TWICImage.Create;
try
WICImage.LoadFromStream(Strm);
result := WICImage; //these return empty
result.savetofile('test.png'); //this succesfully saves the resource to disk
finally
WICImage.Free;
end;
finally
Strm.Free;
end;
end;
Outside of the function, if I attempt to assign the image by calling for example Image1.picture.assign(LoadFromResource(...)) or Image1.picture.graphic := LoadFromResource(...) nothing gets assigned. And If I then call Image1.savetofile('test.png') I get an access violation error.
What might I be missing?
The problem is that you are destroying the image that you return. It's important to understand that classes are reference types in Delphi. So after the assignment to Result, in your code, you still have only a single instance, but two references to that same single instance.
You need to remove the call to Free.
function LoadImageResource(Module: NativeUInt; const ResName: string): TWICImage;
var
Strm: TResourceStream;
begin
Strm := TResourceStream.Create(Module, ResName, RT_RCDATA);
try
Result := TWICImage.Create;
Result.LoadFromStream(Strm);
finally
Strm.Free;
end;
end;
A little tweak is needed to make the function exception safe:
function LoadImageResource(Module: NativeUInt; const ResName: string): TWICImage;
var
Strm: TResourceStream;
begin
Strm := TResourceStream.Create(Module, ResName, RT_RCDATA);
try
Result := TWICImage.Create;
try
Result.LoadFromStream(Strm);
except
Result.Free;
raise;
end;
finally
Strm.Free;
end;
end;
When you call the function it behaves like a constructor. It either succeeds and returns a new instance, handing over ownership to the caller. Or it raises an exception. Accordingly I would name the function CreateImageFromResource.
I am trying following code for a GUI to show 2 identical windows. I am using show rather than showmodal:
program RnTFormclass;
{$mode delphi}
uses
//cthreads, // for linux only.
Interfaces, Forms, StdCtrls;
type
RnTForm = class(TForm)
private
wnd: TForm;
btn: TButton;
public
constructor create;
procedure showit;
end;
constructor RnTForm.create;
begin
//Application.Initialize; //removed.
wnd := TForm.Create(Application);
with wnd do begin
Height := 300;
Width := 400;
Position:= poDesktopCenter;
Caption := 'LAZARUS WND';
end;
btn := TButton.Create(wnd);
with btn do begin
SetBounds(0, 0, 100, 50);
Caption := 'Click Me';
Parent := wnd;
end;
end;
procedure RnTForm.showit;
begin
wnd.Show;
end;
var
myform1, myform2: RnTForm;
begin
// create windows:
myform1 := RnTForm.Create;
myform2 := RnTForm.Create;
// show windows:
myform1.showit;
myform2.showit;
end.
I want two identical windows to show/open up. Though the program runs without any error or warning, not even one window is shown.
The program just terminates.
Where is the problem and how can it be solved? Thanks for your help.
Edit: As pointed out in the comments, Application.initialize is being called twice and not run. I have commented out Application.initialize and the code still does not open up any of the window. (It does open windows one by one if show is replaced by showModal).
Main question is how to keep window open after show?
Taking suggestions from comments, I got it working by following main method:
begin
Application.Initialize;
// create windows:
myform1 := RnTForm.Create;
myform2 := RnTForm.Create;
// show windows:
myform1.showit;
myform2.showit;
Application.run;
end.
Now both the windows appear and I can click and work on any of them.
However, on closing both the windows, the program still keeps running in background. An exit button with its click function needs to be added.
I am trying to load the contents of a file from one of the Windows virtual folders (for example, a camera or iPhone picture folder). Below is some sample code that I am using to play around with this:
procedure TfrmForm.ButtonClick(Sender: TObject);
Var
Dialog: TAttachDialog;
Enum: IEnumShellItems;
Name: LPWSTR;
Item: IShellItem;
Strm: IStream;
OStrm: TOLEStream;
FStrm: TFileStream;
Result: HRESULT;
Buf: Array[0..99] Of Char;
Read: LongInt;
begin
Result := CoInitializeEx(Nil, COINIT_APARTMENTTHREADED Or
COINIT_DISABLE_OLE1DDE);
If Succeeded(Result) Then
Begin
Dialog := TAttachDialog.Create(Self);
Try
Dialog.Options := [fdoAllowMultiSelect, fdoPathMustExist,
fdoFileMustExist];
Dialog.Title := 'Select Attachments';
If Dialog.Execute(Self.Handle) Then
Begin
If FAILED(Dialog.ShellItems.EnumItems(Enum)) Then
Raise Exception.Create('Could not get the list of files selected.');
While Enum.Next(1, Item, Nil) = S_OK Do
Begin
If (Item.GetDisplayName(SIGDN_NORMALDISPLAY, Name) = S_OK) Then
Begin
mResults.Lines.Add(Name);
CoTaskMemFree(Name);
End;
If Item.BindToHandler(Nil, BHID_Stream, IID_IStream, Strm) = S_OK Then
Begin
OStrm := TOLEStream.Create(Strm);
FStrm := TFileStream.Create('C:\Temp\Test.jpg', fmCreate);
FStrm.CopyFrom(OStrm, OStrm.Size);
FreeAndNil(OStrm);
FreeAndNil(FStrm);
Strm := Nil;
End;
Item := Nil;
End;
End;
Finally
FreeAndNil(Dialog);
End;
CoUninitialize;
End;
end;
TAttachDialog is just a descendant of TCustomFileOpenDialog that exposes the ShellItems property. In my actual application, I need a TStream object returned. So, in this example, I am using a TFileStream top copy the source file as proof of concept that I have successfully accessed the file using a Delphi stream. Everything works Ok until I try the FStrm.CopyFrom at which point I get a "Not Implemented" error. What am I doing wrong with this or is there a better way entirely to do what I want?
The only time TStream itself raises a "not implemented" error is if neither the 32bit or 64bit version of Seek() are overridden in a descendant class (or one of them erroneously called the inherited method). If that were true, an EStreamError exception is raised saying "ClassName.Seek not implemented".
TOLEStream does override the 32bit version of Seek() to call IStream.Seek(). However, it does not override the TStream.GetSize() property getter. So when you are reading the OStrm.Size value before calling CopyFrom(), it calls the default TStream.GetSize() method, which uses Seek() to determine the stream size - Seek() to get the current position, then Seek() again to the end of the stream, saving the result, then Seek() again to go back to the previous position.
So, my guess would be that the IStream you have obtained likely does not support random seeking so its Seek() method is returning E_NOTIMPL, which TOLEStream.Seek() would detect and raise an EOleSysError exception saying "Not implemented".
Try calling IStream.Stat() to get the stream size (or derive a class from TOLEStream and override the GetSize() method to call Stat()), and then pass the returned size to CopyFrom() if > 0 (if you pass Count=0 to CopyFrom(), it will read the source stream's Position and Size properties, thus causing the same Seek() error), eg:
var
...
Stat: STATSTG;
begin
...
if Item.BindToHandler(Nil, BHID_Stream, IID_IStream, Strm) = S_OK Then
try
OStrm := TOLEStream.Create(Strm);
try
FStrm := TFileStream.Create('C:\Temp\Test.jpg', fmCreate);
try
OleCheck(Strm.Stat(Stat, STATFLAG_NONAME));
if Stat.cbSize.QuadPart > 0 then
FStrm.CopyFrom(OStrm, Stat.cbSize.QuadPart);
finally
FreeAndNil(FStrm);
end;
finally
FreeAndNil(OStrm);
end;
finally
Strm := Nil;
end;
...
end;
The alternative would be to simply avoid TStream.CopyFrom() and manually copy the bytes yourself, by allocating a local buffer and then calling OStrm.Read() in a loop, writing each read buffer to FStrm, until OStrm.Read() reports that there is no more bytes to read:
var
...
Buf: array[0..1023] of Byte;
NumRead: Integer;
begin
...
if Item.BindToHandler(Nil, BHID_Stream, IID_IStream, Strm) = S_OK Then
try
OStrm := TOLEStream.Create(Strm);
try
FStrm := TFileStream.Create('C:\Temp\Test.jpg', fmCreate);
try
repeat
NumRead := OStrm.Read(Buf[0], SizeOf(Buf));
if NumRead <= 0 then Break;
FStrm.WriteBuffer(Buf[0], NumRead);
until False;
finally
FreeAndNil(FStrm);
end;
finally
FreeAndNil(OStrm);
end;
finally
Strm := Nil;
end;
...
end;
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.
I'm trying to iterate all the controls on a form and enable ClearType font smoothing. Something like this:
procedure TForm4.UpdateControls(AParent: TWinControl);
var
I: Integer;
ACtrl: TControl;
tagLOGFONT: TLogFont;
begin
for I := 0 to AParent.ControlCount-1 do
begin
ACtrl:= AParent.Controls[I];
// if ParentFont=False, update the font here...
if ACtrl is TWinControl then
UpdateControls(Ctrl as TWinControl);
end;
end;
Now, is there a easy way to check if ACtrl have a Font property so i can pass the Font.Handle to somethink like:
GetObject(ACtrl.Font.Handle, SizeOf(TLogFont), #tagLOGFONT);
tagLOGFONT.lfQuality := 5;
ACtrl.Font.Handle := CreateFontIndirect(tagLOGFONT);
Thank you in advance.
You use TypInfo unit, more specifically methods IsPublishedProp and GetOrdProp.
In your case, it would be something like:
if IsPublishedProp(ACtrl, 'Font') then
ModifyFont(TFont(GetOrdProp(ACtrl, 'Font')))
A fragment from one of my libraries that should put you on the right path:
function ContainsNonemptyControl(controlParent: TWinControl;
const requiredControlNamePrefix: string;
const ignoreControls: string = ''): boolean;
var
child : TControl;
iControl: integer;
ignored : TStringList;
obj : TObject;
begin
Result := true;
if ignoreControls = '' then
ignored := nil
else begin
ignored := TStringList.Create;
ignored.Text := ignoreControls;
end;
try
for iControl := 0 to controlParent.ControlCount-1 do begin
child := controlParent.Controls[iControl];
if (requiredControlNamePrefix = '') or
SameText(requiredControlNamePrefix, Copy(child.Name, 1,
Length(requiredControlNamePrefix))) then
if (not assigned(ignored)) or (ignored.IndexOf(child.Name) < 0) then
if IsPublishedProp(child, 'Text') and (GetStrProp(child, 'Text') <> '') then
Exit
else if IsPublishedProp(child, 'Lines') then begin
obj := TObject(cardinal(GetOrdProp(child, 'Lines')));
if (obj is TStrings) and (Unwrap(TStrings(obj).Text, child) <> '') then
Exit;
end;
end; //for iControl
finally FreeAndNil(ignored); end;
Result := false;
end; { ContainsNonemptyControl }
There's no need to use RTTI for this. Every TControl descendant has a Font property. At TControl level its visibility is protected but you can use this workaround to access it:
type
THackControl = class(TControl);
ModifyFont(THackControl(AParent.Controls[I]).Font);
One other thing worth mentioning. Every control has a ParentFont property, which - if set - allows the Form's font choice to ripple down to every control. I tend to make sure ParentFont is set true wherever possible, which also makes it easier to theme forms according to the current OS.
Anyway, surely you shouldn't need to do anything to enable ClearType smoothing? It should just happen automatically if you use a TrueType font and the user has enabled the Cleartype "effect".
Here's a C++Builder example of TOndrej's answer:
struct THackControl : TControl
{
__fastcall virtual THackControl(Classes::TComponent* AOwner);
TFont* Font() { return TControl::Font; };
};
for(int ControlIdx = 0; ControlIdx < ControlCount; ++ControlIdx)
{
((THackControl*)Controls[ControlIdx])->Font()->Color = clRed;
}