Related
i have dxMemData with image Filed, and some png images located in ressource, i expose this images by singleton object like that:
type
ImagesRessource = class
private
constructor Create;
public
Man24: TPngImage;
Woman24: TPngImage;
RSMan24: TResourceStream;
RSWoman24: TResourceStream;
procedure Load_Man24;
procedure Load_Woman24;
end;
var
Images: ImagesRessource;
implementation
constructor ImagesRessource.Create;
begin
Load_Man24;
Load_Woman24;
end;
procedure ImagesRessource.Load_Man24;
begin
Man24 := TPngImage.Create;
RSMan24 := TResourceStream.Create(hInstance, 'men_24', RT_RCDATA);
Man24.LoadFromStream(RSMan24);
end;
procedure ImagesRessource.Load_Woman24;
begin
Woman24 := TPngImage.Create;
RSWoman24 := TResourceStream.Create(hInstance, 'woman_24', RT_RCDATA);
Woman24.LoadFromStream(RSWoman24);
end;
initialization
Images := ImagesRessource.Create;
end.
after that, filling the dxMemeData like that
if(dxMemData1.FieldByName('isMale').AsBoolean) then TBlobField(dxMemData1.FieldByName('SexeImg')).LoadFromStream(OverB.Besalama.Properties.V7.Images.RSMan24)
else TBlobField(dxMemData1.FieldByName('SexeImg')).LoadFromStream(OverB.Besalama.Properties.V7.Images.RSWoman24);
the problem now with cxGrid, the image column dosnt't show any thing! i don't know why? or how to create cxgrid image ?
To display Image on CxGrid columns, set the column propertys to ImageComboBox and set Images to a imagelist.
For full screenshots, I use this code:
form1.Hide;
sleep(500);
bmp := TBitmap.Create;
bmp.Height := Screen.Height;
bmp.Width := Screen.Width;
DCDesk := GetWindowDC(GetDesktopWindow);
BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DCDesk, 0, 0, SRCCOPY);
form1.Show ;
FileName := 'Screenshot_'+FormatDateTime('mm-dd-yyyy-hhnnss',now());
bmp.SaveToFile(Format('C:\Screenshots\%s.bmp', [FileName]));
ReleaseDC(GetDesktopWindow, DCDesk);
bmp.Free;
How can I convert that to take a screenshot of only the active window.
First of all you have to get the right window. As sharptooth already noted you should use GetForegroundWindow instead of GetDesktopWindow. You have done it right in your improved version.
But then you have to resize your bitmap to the actual size of the DC/Window. You haven't done this yet.
And then make sure you don't capture some fullscreen window!
When I executed your code, my Delphi IDE was captured and as it is on fullscreen by default, it created the illusion of a fullscreen screenshot. (Even though your code is mostly correct)
Considering the above steps, I was successfully able to create a single-window screenshot with your code.
Just a hint: You can GetDC instead of GetWindowDC if you are only interested in the client area. (No window borders)
EDIT: Here's what I made with your code:
You should not use this code! Look at the improved version below.
procedure TForm1.Button1Click(Sender: TObject);
const
FullWindow = True; // Set to false if you only want the client area.
var
hWin: HWND;
dc: HDC;
bmp: TBitmap;
FileName: string;
r: TRect;
w: Integer;
h: Integer;
begin
form1.Hide;
sleep(500);
hWin := GetForegroundWindow;
if FullWindow then
begin
GetWindowRect(hWin,r);
dc := GetWindowDC(hWin) ;
end else
begin
Windows.GetClientRect(hWin, r);
dc := GetDC(hWin) ;
end;
w := r.Right - r.Left;
h := r.Bottom - r.Top;
bmp := TBitmap.Create;
bmp.Height := h;
bmp.Width := w;
BitBlt(bmp.Canvas.Handle, 0, 0, w, h, DC, 0, 0, SRCCOPY);
form1.Show ;
FileName := 'Screenshot_'+FormatDateTime('mm-dd-yyyy-hhnnss',now());
bmp.SaveToFile(Format('C:\Screenshots\%s.bmp', [FileName]));
ReleaseDC(hwin, DC);
bmp.Free;
end;
EDIT 2: As requested I'm adding a better version of the code, but I'm keeping the old one as a reference. You should seriously consider using this instead of your original code. It'll behave much nicer in case of errors. (Resources are cleaned up, your form will be visible again, ...)
procedure TForm1.Button1Click(Sender: TObject);
const
FullWindow = True; // Set to false if you only want the client area.
var
Win: HWND;
DC: HDC;
Bmp: TBitmap;
FileName: string;
WinRect: TRect;
Width: Integer;
Height: Integer;
begin
Form1.Hide;
try
Application.ProcessMessages; // Was Sleep(500);
Win := GetForegroundWindow;
if FullWindow then
begin
GetWindowRect(Win, WinRect);
DC := GetWindowDC(Win);
end else
begin
Windows.GetClientRect(Win, WinRect);
DC := GetDC(Win);
end;
try
Width := WinRect.Right - WinRect.Left;
Height := WinRect.Bottom - WinRect.Top;
Bmp := TBitmap.Create;
try
Bmp.Height := Height;
Bmp.Width := Width;
BitBlt(Bmp.Canvas.Handle, 0, 0, Width, Height, DC, 0, 0, SRCCOPY);
FileName := 'Screenshot_' +
FormatDateTime('mm-dd-yyyy-hhnnss', Now());
Bmp.SaveToFile(Format('C:\Screenshots\%s.bmp', [FileName]));
finally
Bmp.Free;
end;
finally
ReleaseDC(Win, DC);
end;
finally
Form1.Show;
end;
end;
Your code could be a lot simpler. When you have decided on which form you want to save, try the code I use:
procedure SaveFormBitmapToBMPFile( AForm : TCustomForm; AFileName : string = '' );
// Copies this form's bitmap to the specified file
var
Bitmap: TBitMap;
begin
Bitmap := AForm.GetFormImage;
try
Bitmap.SaveToFile( AFileName );
finally
Bitmap.Free;
end;
end;
This combines all the approaches described so far. It also handles multiple-monitor scenarios.
Pass in the kind of screenshot you want, and a TJpegImage, and it will assign your requested screenshot to that image.
///////////
uses
Jpeg;
type //define an ENUM to describe the possible screenshot types.
TScreenShotType = (sstActiveWindow, sstActiveClientArea,
sstPrimaryMonitor, sstDesktop);
///////////
procedure TfrmMain.GetScreenShot(shotType: TScreenShotType;
var img: TJpegImage);
var
w,h: integer;
DC: HDC;
hWin: Cardinal;
r: TRect;
tmpBmp: TBitmap;
begin
hWin := 0;
case shotType of
sstActiveWindow:
begin
//only the active window
hWin := GetForegroundWindow;
dc := GetWindowDC(hWin);
GetWindowRect(hWin,r);
w := r.Right - r.Left;
h := r.Bottom - r.Top;
end; //sstActiveWindow
sstActiveClientArea:
begin
//only the active client area (active window minus title bars)
hWin := GetForegroundWindow;
dc := GetDC(hWin);
GetWindowRect(hWin,r);
w := r.Right - r.Left;
h := r.Bottom - r.Top;
end; //sstActiveClientArea
sstPrimaryMonitor:
begin
//only the primary monitor. If 1 monitor, same as sstDesktop.
hWin := GetDesktopWindow;
dc := GetDC(hWin);
w := GetDeviceCaps(DC,HORZRES);
h := GetDeviceCaps(DC,VERTRES);
end; //sstPrimaryMonitor
sstDesktop:
begin
//ENTIRE desktop (all monitors)
dc := GetDC(GetDesktopWindow);
w := Screen.DesktopWidth;
h := Screen.DesktopHeight;
end; //sstDesktop
else begin
Exit;
end; //case else
end; //case
//convert to jpg
tmpBmp := TBitmap.Create;
try
tmpBmp.Width := w;
tmpBmp.Height := h;
BitBlt(tmpBmp.Canvas.Handle,0,0,tmpBmp.Width,
tmpBmp.Height,DC,0,0,SRCCOPY);
img.Assign(tmpBmp);
finally
ReleaseDC(hWin,DC);
FreeAndNil(tmpBmp);
end; //try-finally
end;
JCL comes to the rescue once again..
hwnd := GetForegroundWindow;
Windows.GetClientRect(hwnd, r);
JclGraphics.ScreenShot(theBitmap, 0, 0, r.Right - r.Left, r.Bottom - r.Top, hwnd);
// use theBitmap...
Thank you for this useful submission I thought I might make the code offered into a unit to use all over my application, here is the code I have running on DX10.2 Tokyo. Please note the example, watch out for memory leaks.
unit ScreenCapture;
interface
uses Windows, Vcl.Controls, Vcl.StdCtrls, VCL.Graphics,VCL.Imaging.JPEG, VCL.Forms;
function getScreenCapture( FullWindow: Boolean = True ) : TBitmap;
implementation
function getScreenCapture( FullWindow: Boolean ) : TBitmap;
var
Win: HWND;
DC: HDC;
WinRect: TRect;
Width: Integer;
Height: Integer;
begin
Result := TBitmap.Create;
//Application.ProcessMessages; // Was Sleep(500);
Win := GetForegroundWindow;
if FullWindow then
begin
GetWindowRect(Win, WinRect);
DC := GetWindowDC(Win);
end
else
begin
Windows.GetClientRect(Win, WinRect);
DC := GetDC(Win);
end;
try
Width := WinRect.Right - WinRect.Left;
Height := WinRect.Bottom - WinRect.Top;
Result.Height := Height;
Result.Width := Width;
BitBlt(Result.Canvas.Handle, 0, 0, Width, Height, DC, 0, 0, SRCCOPY);
finally
ReleaseDC(Win, DC);
end;
end;
end.
Example :
//Any event or button click, screenCapture is a TBitmap
screenCapture := getScreenCapture();
try
//Do some things with screen capture
Image1.Picture.Graphic := screenCapture;
finally
screenCapture.Free;
end;
Use GetForegroundWindow() instead of GetDesktopWindow().
You'll have to save the handle which GetForegroundWindow() return and pass the saved value into ReleaseDC() - to be sure that GetWindowDC() and ReleaseDC() are called exactly for the same window in case the active window changes between calls.
In case anyone is looking for a more cross-platform solution, this one claims Windows and MacOS-X support:
https://github.com/z505/screenshot-delphi
The shortest version of the Brian Frost code:
Screen.ActiveForm.GetFormImage.SaveToFile(Screen.ActiveForm.Caption+'.bmp');
Just one line of the code (Screenshot of the active window in the MDI application).
to paint themed button I use this code:
var
h: HTHEME;
begin
if UseThemes then begin
SetWindowTheme(Handle, 'explorer', nil);
h := OpenThemeData(Handle, 'WINDOW');
if h <> 0 then
try
DrawThemeBackground(h, Canvas.Handle, WP_CLOSEBUTTON, GetAeroState, ClientRect, nil);
finally
CloseThemeData(h);
end;
end
else
DrawFrameControl(Canvas.Handle, ClientRect, DFC_CAPTION, DFCS_CAPTIONCLOSE or GetClassicState)
end;
This code works fine but painted button looks like from Windows 7 theme, even on Windows 8 or 10. This is possible to paint the Close button using Windows 10 or 8 theme?
One of ways to resolve this question: manual parsing active *.msstyles file. Usual this is aero.msstyles. Bitmap for different window controls stored in STREAM section. For Windows 7 ResId = 971, Windows 8: Id = 1060, Windows 10: Id = 1194. But this is manual work and this bitmaps is different.
Update:
I found, that even for one version of the Windows (tested for 8) we can have different values of the resource id for this Bitmap (png image) and now I can provide the code to obtain resource id on any Windows (tested for 7,8,10):
function EnumStreamProc(hModule: HMODULE; AType, AName: PChar; Params: LPARAM): BOOL; stdcall;
var
Id: NativeInt;
begin
PNativeInt(Params)^ := Integer(AName);
Result := False;
end;
function GetStyleResourceId(AModule: HMODULE): Integer;
begin
Result := 0;
EnumResourceNames(AMODULE, 'STREAM', #EnumStreamProc, LPARAM(#Result));
end;
var
hLib: HMODULE;
ResId: Integer;
RS: TResourceStream;
Png: TPngImage;
begin
hLib := LoadLibraryEx(PChar(GetWindowsPath + 'Resources\Themes\Aero\aero.msstyles'),
0, LOAD_LIBRARY_AS_DATAFILE);
ResId := GetStyleResourceId(hLib);
RS := TResourceStream.CreateFromID(hLib, ResId, 'STREAM');
Png := TPngImage.Create;
Png.LoadFromStream(RS);
...
end;
Update 2:
Found not hacked method using official api:
var
h: HTHEME;
Rect: TRect;
PBuf, PPBuf: Pointer;
BufSize: Cardinal;
Buf: array[0..1024*1024] of Byte;
h := OpenThemeData(Handle, 'DWMWINDOW');
if h <> 0 then
try
GetThemeRect(h, WP_MINCAPTION, MNCS_ACTIVE, TMT_ATLASRECT, Rect);
PBuf := #Buf[0];
PPBuf := #PBuf;
GetThemeStream(h, WP_MINCAPTION, MNCS_ACTIVE, TMT_ATLASRECT, PBuf, BufSize, hInstance);
finally
CloseThemeData(h);
end;
I can get Rect for minimized button, but don't understand how to use GetThemeStream? There should be used PBuf or PPBuf?
Workable solution to get bitmaps from theme:
var
h: HTHEME;
Rect: TRect;
BufSize: Cardinal;
h := OpenThemeData(Handle, 'DWMWINDOW');
if h <> 0 then
try
GetThemeRect(h, WP_MINCAPTION, MNCS_ACTIVE, TMT_ATLASRECT, Rect);
...
GetThemeStream(...);
finally
CloseThemeData(h);
end;
And how to use GetThemeStream described here: GetThemeStream usage, many thanks to Andreas Verhoeven, author of the program Vista Style Builder
I am using Barcode Studio 2011 to paint a QR Code into a Graphics32 - TImage32 Component and I want to save it in png format but with the white colour as transparent this I have specified in the OuterColor of Graphics32.
OnFormCreate I have just
procedure TForm1.FormCreate(Sender: TObject);
begin
psBarcodeComponent1.BarCode := 'some text here...';
end;
and for the moment I have the painting assigned to a Button Click Event
procedure TForm1.Button8Click(Sender: TObject); // Paint the barcode
var
bmp: TBitmap32;
Coords: TRect;
begin
bmp := TBitmap32.Create;
bmp.SetSize(image.Width, image.Height);
bmp.Canvas.Brush.Color := color;
bmp.Canvas.Rectangle(-1, -1, image.Width+2, image.Height+2);
bmp.DrawMode := dmTransparent;
bmp.OuterColor := clWhite;
// make Coords the size of image
Coords := Rect(0,0,image.Width,image.Height);
psBarcodeComponent1.PaintBarCode(bmp.Canvas, Coords);
image.Bitmap.Assign(bmp);
end;
I am using the Vampyre Imaging Library to convert the Bitmap into PNG Format but I will gladly use any library, function, and advice - I have been trying to do this now for nearly a week! I have read through and re-read the documentation of graphics32 and also of the Vampyre Imaging Library but nothing I try will convert the white to a transparent colour. I have tried clWhite, clWhite32 and also setting the drawMode to dmBlend and applying the ChromaKey Function all to no avail but plenty frustration, coffee and a little beer also ;)
This is how I am saving it...
procedure TForm1.Button7Click(Sender: TObject); // Save with Vampyre Imaging Lib
{ Try to save in PNG format with transparancy }
var
FImage: TSingleImage;
begin
FImage := TSingleImage.Create;
ConvertBitmap32ToImage(image.Bitmap, FImage);
FImage.SaveToFile('VampyreLibIMG.png');
end;
This results in a Black coloured thumbnail and when viewed in Windows Photo Viewer it is completely transparent.
I hope that I have provided enough information and that someone is able to help me.
Chris
You haven't specified the Delphi version, but if your delphi version has "PngImage"(I believe it comes with D2009+) the code bellow works perfectly(loaded in Gimp and Windows Photo Viewer, it draws a frame and some text with transparent background, feel free to play with it:
uses
PngImage;
procedure TForm1.OnBtnClick(Sender: TObject);
var
bmp: TBitmap;
png: TPngImage;
begin
bmp := TBitmap.Create;
bmp.Width := 200;
bmp.Height := 200;
bmp.Canvas.Brush.Color := clBlack;
bmp.Canvas.Rectangle( 20, 20, 160, 160 );
bmp.Canvas.Brush.Style := bsClear;
bmp.Canvas.Rectangle(1, 1, 199, 199);
bmp.Canvas.Brush.Color := clWhite;
bmp.Canvas.Pen.Color := clRed;
bmp.Canvas.TextOut( 35, 20, 'Hello transparent world');
bmp.TransparentColor := clWhite;
bmp.Transparent := True;
png := TPngImage.Create;
png.Assign( bmp );
png.SaveToFile( 'C:\test.png' );
bmp.Free;
png.Free;
end;
This approach works for me:
uses GR32, GR32_PNG, GR32_PortableNetworkGraphic;
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
with Image321 do
begin
Bitmap.ResetAlpha;
for Y := 0 to Bitmap.Height-1 do
for X := 0 to Bitmap.Width-1 do
begin
if IsWhite(Bitmap.Pixel[X, Y]) then
Bitmap.Pixel[X,Y]:=Color32(255,255,255,0);
end;
Png:= TPortableNetworkGraphic32.Create;
Png.Assign(Bitmap);
Png.SaveToFile('C:\Temp\NowTransparent.png');
Png.Free;
end;
end;
This uses the GR32 PNG library. It's a pretty direct way, setting all white pixels to transparent.
PS: Image321 is a TImage32 component, containing my TBitmap32.
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