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.
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;
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.
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;
Please see the attached screenshot which illustrates a TToolBar from one of my programs:
Notice the last two images of the Toolbar, they are disabled. The way they have been drawn to appear disabled is not very appealing, in fact in the Delphi IDE some of the images look the same.
The issue I have with it is I want my application to look a lot cleaner. The way the disabled items are drawn doesn't look very good. The TToolBar allows to set a disabled TImageList, I tried making my images black & white but they didn't look right, and would rather not have to always make the images black and white (time and effort). This problem also shows in my menus and popup menus, which don't allow for disabled images anyway.
Is there a way to paint the disabled items to look better on the eye?
If possible I would rather not look to use 3rd Party Controls. I know the Jedi Components allow disabled images for the menu etc, but would prefer a way to not resort too 3rd Party Components, when possible I would much prefer to use the standard issue VCL, especially as sometimes I use the TActionMainMenuBar to draw Office Style menus, which match the TToolBar when DrawingStyle is set to gradient.
EDIT
I have accepted RRUZ's answer, is it possible though to accept David's answer as well, both are very good answers and would like the answer to be shared between them if possible.
Thanks.
Sometime Ago i wrote a patch to fix this behavior. the key is patch the code of the TCustomImageList.DoDraw function, the technique used is similar to the used by the delphi-nice-toolbar app, but instead of patch a bpl IDE in this case we patch the function in memory.
Just include this unit in your project
unit uCustomImageDrawHook;
interface
uses
Windows,
SysUtils,
Graphics,
ImgList,
CommCtrl,
Math;
implementation
type
TJumpOfs = Integer;
PPointer = ^Pointer;
PXRedirCode = ^TXRedirCode;
TXRedirCode = packed record
Jump: Byte;
Offset: TJumpOfs;
end;
PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
TAbsoluteIndirectJmp = packed record
OpCode: Word;
Addr: PPointer;
end;
TCustomImageListHack = class(TCustomImageList);
var
DoDrawBackup : TXRedirCode;
function GetActualAddr(Proc: Pointer): Pointer;
begin
if Proc <> nil then
begin
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
Result := PAbsoluteIndirectJmp(Proc).Addr^
else
Result := Proc;
end
else
Result := nil;
end;
procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
n: DWORD;
Code: TXRedirCode;
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
if ReadProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n) then
begin
Code.Jump := $E9;
Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
WriteProcessMemory(GetCurrentProcess, Proc, #Code, SizeOf(Code), n);
end;
end;
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
n: Cardinal;
begin
if (BackupCode.Jump <> 0) and (Proc <> nil) then
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
WriteProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n);
BackupCode.Jump := 0;
end;
end;
procedure Bitmap2GrayScale(const BitMap: TBitmap);
type
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;
var
x, y, Gray: Integer;
Row : PRGBArray;
begin
BitMap.PixelFormat := pf24Bit;
for y := 0 to BitMap.Height - 1 do
begin
Row := BitMap.ScanLine[y];
for x := 0 to BitMap.Width - 1 do
begin
Gray := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3;
Row[x].rgbtRed := Gray;
Row[x].rgbtGreen := Gray;
Row[x].rgbtBlue := Gray;
end;
end;
end;
//from ImgList.GetRGBColor
function GetRGBColor(Value: TColor): DWORD;
begin
Result := ColorToRGB(Value);
case Result of
clNone:
Result := CLR_NONE;
clDefault:
Result := CLR_DEFAULT;
end;
end;
procedure New_Draw(Self: TObject; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);
var
MaskBitMap : TBitmap;
GrayBitMap : TBitmap;
begin
with TCustomImageListHack(Self) do
begin
if not HandleAllocated then Exit;
if Enabled then
ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0, GetRGBColor(BkColor), GetRGBColor(BlendColor), Style)
else
begin
GrayBitMap := TBitmap.Create;
MaskBitMap := TBitmap.Create;
try
GrayBitMap.SetSize(Width, Height);
MaskBitMap.SetSize(Width, Height);
GetImages(Index, GrayBitMap, MaskBitMap);
Bitmap2GrayScale(GrayBitMap);
BitBlt(Canvas.Handle, X, Y, Width, Height, MaskBitMap.Canvas.Handle, 0, 0, SRCERASE);
BitBlt(Canvas.Handle, X, Y, Width, Height, GrayBitMap.Canvas.Handle, 0, 0, SRCINVERT);
finally
GrayBitMap.Free;
MaskBitMap.Free;
end;
end;
end;
end;
procedure HookDraw;
begin
HookProc(#TCustomImageListHack.DoDraw, #New_Draw, DoDrawBackup);
end;
procedure UnHookDraw;
begin
UnhookProc(#TCustomImageListHack.DoDraw, DoDrawBackup);
end;
initialization
HookDraw;
finalization
UnHookDraw;
end.
and the result will be
I submitted a QC report for a related issue over a year ago, but that was for menus. I've never seen this for TToolbar since it is a wrapper to the common control and the drawing is handled by Windows.
However, the images you are seeing are clearly as result of the VCL calling TImageList.Draw and passing Enabled=False β nothing else looks that bad! Are you 100% sure this really is a TToolbar?
The fix will surely be to avoid TImageList.Draw and call ImageList_DrawIndirect with the ILS_SATURATE.
You may need to modify some VCL source. First find the location where the toolbar is being custom drawn and call this routine instead of the calls to TImageList.Draw.
procedure DrawDisabledImage(DC: HDC; ImageList: TCustomImageList; Index, X, Y: Integer);
var
Options: TImageListDrawParams;
begin
ZeroMemory(#Options, SizeOf(Options));
Options.cbSize := SizeOf(Options);
Options.himl := ImageList.Handle;
Options.i := Index;
Options.hdcDst := DC;
Options.x := X;
Options.y := Y;
Options.fState := ILS_SATURATE;
ImageList_DrawIndirect(#Options);
end;
An even better fix would be to work out why the toolbar is being custom drawn and find a way to let the system do it.
EDIT 1
I've looked at the Delphi source code and I'd guess that you are custom drawing the toolbar, perhaps because it has a gradient. I never even knew that TToolbar could handle custom drawing but I'm just a plain vanilla kind of guy!
Anyway, I can see code in TToolBar.GradientDrawButton calling the TImageList.Draw so I think the explanation above is on the right track.
I'm fairly sure that calling my DrawDisabledImage function above will give you better results. If could find a way to make that happen when you call TImageList.Draw then that would, I suppose, be the very best fix since it would apply wholesale.
EDIT 2
Combine the function above with #RRUZ's answer and you have an excellent solution.
Solution from #RRUZ dosn't work if you use LargeImages in ActionToolBar. I made changes to the #RRUZ code to work with LargeImages in ActionToolBar.
unit unCustomImageDrawHook;
interface
uses
Windows,
SysUtils,
Graphics,
ImgList,
CommCtrl,
Math,
Vcl.ActnMan,
System.Classes;
implementation
type
TJumpOfs = Integer;
PPointer = ^Pointer;
PXRedirCode = ^TXRedirCode;
TXRedirCode = packed record
Jump: Byte;
Offset: TJumpOfs;
end;
PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
TAbsoluteIndirectJmp = packed record
OpCode: Word;
Addr: PPointer;
end;
TCustomImageListHack = class(TCustomImageList);
TCustomActionControlHook = class(TCustomActionControl);
var
DoDrawBackup : TXRedirCode;
DoDrawBackup2 : TXRedirCode;
function GetActualAddr(Proc: Pointer): Pointer;
begin
if Proc <> nil then
begin
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
Result := PAbsoluteIndirectJmp(Proc).Addr^
else
Result := Proc;
end
else
Result := nil;
end;
procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
n: SIZE_T;
Code: TXRedirCode;
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
if ReadProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n) then
begin
Code.Jump := $E9;
Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
WriteProcessMemory(GetCurrentProcess, Proc, #Code, SizeOf(Code), n);
end;
end;
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
n: SIZE_T;
begin
if (BackupCode.Jump <> 0) and (Proc <> nil) then
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
WriteProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n);
BackupCode.Jump := 0;
end;
end;
procedure Bitmap2GrayScale(const BitMap: TBitmap);
type
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;
var
x, y, Gray: Integer;
Row : PRGBArray;
begin
BitMap.PixelFormat := pf24Bit;
for y := 0 to BitMap.Height - 1 do
begin
Row := BitMap.ScanLine[y];
for x := 0 to BitMap.Width - 1 do
begin
Gray := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3;
Row[x].rgbtRed := Gray;
Row[x].rgbtGreen := Gray;
Row[x].rgbtBlue := Gray;
end;
end;
end;
//from ImgList.GetRGBColor
function GetRGBColor(Value: TColor): DWORD;
begin
Result := ColorToRGB(Value);
case Result of
clNone:
Result := CLR_NONE;
clDefault:
Result := CLR_DEFAULT;
end;
end;
procedure New_Draw(Self: TObject; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);
var
MaskBitMap : TBitmap;
GrayBitMap : TBitmap;
begin
with TCustomImageListHack(Self) do
begin
if not HandleAllocated then Exit;
if Enabled then
ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0, GetRGBColor(BkColor), GetRGBColor(BlendColor), Style)
else
begin
GrayBitMap := TBitmap.Create;
MaskBitMap := TBitmap.Create;
try
GrayBitMap.SetSize(Width, Height);
MaskBitMap.SetSize(Width, Height);
GetImages(Index, GrayBitMap, MaskBitMap);
Bitmap2GrayScale(GrayBitMap);
BitBlt(Canvas.Handle, X, Y, Width, Height, MaskBitMap.Canvas.Handle, 0, 0, SRCERASE);
BitBlt(Canvas.Handle, X, Y, Width, Height, GrayBitMap.Canvas.Handle, 0, 0, SRCINVERT);
finally
GrayBitMap.Free;
MaskBitMap.Free;
end;
end;
end;
end;
procedure New_Draw2(Self: TObject; const Location: TPoint);
var
ImageList: TCustomImageList;
DrawEnabled: Boolean;
LDisabled: Boolean;
begin
with TCustomActionControlHook(Self) do
begin
if not HasGlyph then Exit;
ImageList := FindImageList(True, LDisabled, ActionClient.ImageIndex);
if not Assigned(ImageList) then Exit;
DrawEnabled := LDisabled or Enabled and (ActionClient.ImageIndex <> -1) or
(csDesigning in ComponentState);
ImageList.Draw(Canvas, Location.X, Location.Y, ActionClient.ImageIndex,
dsTransparent, itImage, DrawEnabled);
end;
end;
procedure HookDraw;
begin
HookProc(#TCustomImageListHack.DoDraw, #New_Draw, DoDrawBackup);
HookProc(#TCustomActionControlHook.DrawLargeGlyph, #New_Draw2, DoDrawBackup2);
end;
procedure UnHookDraw;
begin
UnhookProc(#TCustomImageListHack.DoDraw, DoDrawBackup);
UnhookProc(#TCustomActionControlHook.DrawLargeGlyph, DoDrawBackup2);
end;
initialization
HookDraw;
finalization
UnHookDraw;
end.
Take a look at this Delphi IDE fix. Maybe you can mimic it's implementation.
Use TActionToolbar , TActionmanager , Timagelist
Set action managers image list to a Timagelist. and set Disabledimages to another imagelist