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;
Using Delphi 7. I have a simple routine successfully loading .bmp, .emf, .wmf, .ico and .jpg files (code given below). My problem is that every .ico (Icon) file always reports TImage.TPicture.Width and TImage.TPicture.Height as "32". All icons are 32-bit with a single page inside. It doesn't matter what the actual size is (I have tried 16x16, 32x32, 64x64 and 128x128).
If I manually set TImage.Width and TImage.Width to what I know the icon size is, the image displays nicely. All the other file types report the size correctly.
Why is there a problem with .ico files and how do I correct or workaround the problem.
procedure TfrmImageLoader.btnBrowseClick(Sender: TObject);
var
openPictureDlg: TOpenPictureDialog;
jpgImage: TJPEGImage;
testWidth, testHeight: Integer;
begin
// Browse for the image file
openPictureDlg := TOpenPictureDialog.Create(Self);
if (openPictureDlg.Execute) then
begin
// Check if file exists
if (FileExists(openPictureDlg.FileName)) then
begin
// Load the image into out image component
imgLoaded.Visible := False;
if (IsJPEG(openPictureDlg.FileName)) then
begin
jpgImage := TJPEGImage.Create();
jpgImage.LoadFromFile(openPictureDlg.FileName);
imgLoaded.Picture.Assign(jpgImage);
jpgImage.Free();
end
else
begin
imgLoaded.Picture.LoadFromFile(openPictureDlg.FileName);
end;
// Test width...here's the problem. Icons always report "32".
testWidth := m_imgLoaded.Picture.Width;
testHeight := m_imgLoaded.Picture.Height;
m_imgLoaded.Visible := True;
end
else
begin
// File does not exist
MessageDlg('File does not exist', mtWarning, [mbOK], 0);
end;
end;
// Clean up
openPictureDlg.Free();
end;
Update 1
As a test, I loaded the file as a TIcon, but the results are the same.
ico: TIcon;
// ...
ico := TIcon.Create();
ico.LoadFromFile(openPictureDlg.FileName);
testWidth := ico.Width; // Still 32, regardless of the actual size
testHeight := ico.Height;
ico.Free();
Update 2
See the accepted answer. There are basically two ways to get the correct size (a) load the icon, assign to a TBitmap, and read the bitmap size or (b) read the icon header, bytes 7 & 8 are the width/height. The latter is ~20 times faster in my tests and the code is given below:
procedure GetTrueIconSize2(const cszIcon: String; var trueW: Integer; var trueH: Integer);
var
fs: TFileStream;
firstBytes: AnsiString;
begin
// The size of image/vnd.microsoft.icon MIME files (Windows icon) is in the header
// at bytes 7 & 8. A value of "0" means "256" (the largest icon size supported).
fs := TFileStream.Create(cszIcon, fmOpenRead);
try
SetLength(firstBytes, 8);
fs.Read(firstBytes[1], 8);
trueW := Integer(firstBytes[7]);
if (trueW = 0) then
trueW := 256;
trueH := Integer(firstBytes[8]);
if (trueH = 0) then
trueH := 256;
finally
fs.Free();
end;
end;
A workaround would be to parse ICO files yourself, which is rather trivial: https://en.wikipedia.org/wiki/ICO_(file_format) - that way you easily know the dimensions for each entry. In the most simple case (only one picture) the first 6 bytes of the file must be #0#0#1#0#1#0 and byte 7 and 8 are width and height.
Yesterday I found a new setup. It has a label on a bevel line. So, how to create and setting label on bevel line like this in Inno Setup?
That looks like a group box control (known as the TGroupBox in Delphi/VCL), not the bevel.
But the group box control is not exposed in Inno Setup.
As an alternative, just place a TLabel on top of the TBevel. Make sure you set label's Transparent property to False.
On Windows Vista and newer, you can also add a hair space around for a padding. You need Unicode version of Inno Setup for that (the only version as of Inno Setup 6).
procedure InitializeWizard;
var
Page: TWizardPage;
Bevel: TBevel;
Caption: TLabel;
begin
Page := CreateCustomPage(wpWelcome, '', '');
Bevel := TBevel.Create(WizardForm);
with Bevel do
begin
Parent := Page.Surface;
Shape := bsFrame;
Left := ScaleX(0);
Top := ScaleY(8);
Width := ScaleX(417);
Height := ScaleY(220);
end;
Caption := TLabel.Create(WizardForm);
with Caption do
begin
Parent := Page.Surface;
Left := Bevel.Left + ScaleX(8);
Top := Bevel.Top - ScaleY(6);
Transparent := False;
Caption := 'Caption';
{ On Vista and newer, add padding using a hair space }
if GetWindowsVersion >= $06000000 then
Caption := #$200A + Caption + #$200A;
end;
end;
I've been trying for hours in Lazarus following from the sample code in the
AdvancedTabs unit, to make am image appear on a button.
The sample code has this:
constructor TAdvancedTabs.Create;
var
I : integer;
begin
inherited;
with SelfSession do begin
SetCodePress;
SetStyle('.new-tab{background-image:url(' + ExtPath + '/examples/feed-viewer/images/new_tab.gif) !important}');
SetStyle('.tabs{background:url(' + ExtPath + '/examples/desktop/images/tabs.gif)}');
end;
with TExtButton.Create do begin
RenderTo := 'body';
Text := 'Add Tab using AJAX!';
IconCls := 'new-tab';
Handler := Ajax(AddTab);
OnClick := HandleExtButtonClick; // Delphi style event handler
end;
...
I have this:
extPath := (CurrentFCGIThread as TExtThread).ExtPath;
(CurrentFCGIThread as TExtThread).SetStyle('.backbtn{background-image:url(' + ExtPath + '/basxv2/back.png) !important}');
btnClose := TV2ExtButton.Create;
with btnClose.AddTo(Items) do
begin
Id := 'frmManualOrder_btnClose';
X := MarginLeft;
Height := ButtonHeight;
Y := ScreenHeight-12*MarginLeft;
Width := ButtonWidth-10;
RenderTo := 'body';
IconCls := 'backbtn';
...
I have tried a number of different things, converting the image to a
gif, for example, and in most cases the button is either blank (if I
don't set the Text property) or shows the text nudged to the right a
few pixels as if making room for an invisible image. A few times the image appears with the top and bottom clipped.
Can anyone see what I am doing wrong?
TIA
Mark
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.