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).
Related
I am currently trying to take a screenshot of a 2D Firemonkey (FMX) form from another process.
The following is using a well-known method based of GDI, using a BitBlt() to produce a bitmap, and WIC to save it to a PNG file.
{...}
uses
system.UITypes,
system.SysUtils,
system.Hash,
{$IF Defined(MSWINDOWS)}
winapi.Windows,
Winapi.Direct3D9,
WinApi.D3DX9,
Winapi.Wincodec,
WinApi.ActiveX,
{$ENDIF}
{ some internal units }
path.types,
path.utils,
os.utils;
{...}
Type
TWindowSnapshot = record
window_handle: THandle; // handle to window
process_id: Cardinal; // PID of the process
window_rect: TRect; // position of the window
title: string; // title
file_path: string; // path to the window's image file
end;
TWindowSnapshots = Tarray<TWindowSnapshot>;
procedure HRCHECK(r: HRESULT); inline;
begin
if r <> S_OK then abort;
end;
function pad(s,g:integer): integer; inline;
begin
dec(g);
result := (s + g) and not g;
end;
function WICSavePixelsToPng(r: TRect; stride: cardinal; pixels: PByte; filePath: string): HRESULT;
var
factory: IWICImagingFactory;
encoder: IWICBitmapEncoder;
frame: IWICBitmapFrameEncode;
encoderOptions: IPropertyBag2;
stream: IWICStream;
pf: TGUID;
coInit : HResult;
begin
result := E_INVALIDARG;
if not assigned(pixels) then exit;
if (filepath = '') then exit;
coInit := CoInitialize(nil);
pf := GUID_WICPixelFormat32bppBGRA;
result := CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER, IWICImagingFactory, factory);
if result <> S_OK then exit;
result := factory.CreateStream(&stream);
if result <> S_OK then exit;
result := stream.InitializeFromFilename(PWideChar(filePath), GENERIC_WRITE);
if result <> S_OK then exit;
result := factory.CreateEncoder(GUID_ContainerFormatPng, TGUID.Empty, encoder);
if result <> S_OK then exit;
result := encoder.Initialize(stream, WICBitmapEncoderNoCache);
if result <> S_OK then exit;
result := encoder.CreateNewFrame(frame, encoderOptions);
if result <> S_OK then exit;
result := frame.Initialize(nil);
if result <> S_OK then exit;
result := frame.SetSize(r.width, r.height);
if result <> S_OK then exit;
result := frame.SetPixelFormat(pf);
if result <> S_OK then exit;
if pf <> GUID_WICPixelFormat32bppBGRA then
begin
assert(false,'ToDo');
end;
inc(pixels,(r.Left*4) + r.Top * stride);
result := frame.WritePixels(r.height, stride, stride * r.height, pixels);
if result <> S_OK then exit;
result := frame.Commit();
if result <> S_OK then exit;
result := encoder.Commit();
if (coInit <> 0) then
CoUninitialize();
end;
function take_window_snapshot_GDI(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
Wr: TRect;
HdcSRC: HDC;
hDCDest: HDC;
hBmp: HBITMAP;
hOld: HGDIOBJ;
hFlags: Cardinal;
l: integer;
src_shot,dst_shot,lsrc,ldst: PByte;
sr: PRGBTriple;
dr: PRGBQuad;
buff_size: cardinal;
x,y, src_stride, dst_stride: integer;
bi: tagBITMAPINFO;
begin
result := false;
cs.window_handle := win_handle;
cs.title := '';
cs.window_rect := TRect.Empty;
cs.process_id := 0;
try
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
{ reserve memory for bitmaps }
src_stride := pad((wr.Width * 3),4);
dst_stride := pad((wr.Width * 4),4);
buff_size := src_stride * wr.Height;
getmem(src_shot,buff_size);
if not assigned(src_shot) then exit;
getmem(dst_shot,dst_stride * wr.Height);
if not assigned(src_shot) then
begin
freemem(src_shot);
exit;
end;
try
try
HdcSRC := GetWindowDC(win_handle);
HdcDest := CreateCompatibleDC(HdcSRC);
SetStretchBltMode(HdcDest, COLORONCOLOR);
HBmp := CreateCompatibleBitmap(HdcSRC,Wr.Width,wr.Height);
hOld := SelectObject(hDCDest,hBmp);
BitBlt(hDCDest,0,0,wr.width,wr.Height,HdcSRC,0,0,SRCCOPY);
{ target bitplane is 24 bits RGB }
bi := default(tagBITMAPINFO);
bi.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
bi.bmiHeader.biWidth := wr.Width;
bi.bmiHeader.biHeight := wr.Height;
bi.bmiHeader.biPlanes := 1;
bi.bmiHeader.biBitCount := 24;
bi.bmiHeader.biCompression := BI_RGB;
GetDIBits(hDCDest,HBmp,0,wr.Height,src_shot,bi,DIB_RGB_COLORS);
{ now convert pixels to RGBA, in correct line order.
On Windows, last line is first in bitmap }
ldst := dst_shot;
lsrc := src_shot + (src_stride * wr.Height);
for y := 0 to wr.Height - 1 do
begin
dec(lsrc,src_stride);
sr := pointer(lsrc);
dr := pointer(ldst);
for x := 0 to wr.Width - 1 do
begin
dr.rgbBlue := sr.rgbtBlue;
dr.rgbRed := sr.rgbtRed;
dr.rgbGreen := sr.rgbtGreen;
dr.rgbReserved := 255;
inc(dr);
inc(sr);
end;
inc(ldst,dst_stride);
end;
{ save to PNG with WIC }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
wr.Offset(-wr.Left,-wr.top);
if WICSavePixelsToPng(wr,dst_stride,dst_shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
result := true;
finally
freemem(src_shot);
freemem(dst_shot);
end;
finally
SelectObject(hDCDest,hold);
DeleteDC(hDCDest);
ReleaseDC(win_handle,HdcSRC);
end;
except begin
result := false;
end;
end;
end;
This method is working for Delphi forms using VCL, however with forms using Firemonkey (FMX) 2D, it only produces bitmaps filled with BLACK (0) pixels.
I have tried an alternative using Direct3D9, that is working for Firemonkey form, however with a limitation I'll explain after the code snippet
function Take_window_snapshot_D3D(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
D3D: IDirect3D9;
D3DDevice: IDirect3DDevice9;
mode: D3DDISPLAYMODE;
device: IDirect3DDevice9;
surface: IDirect3DSurface9;
parameters: D3DPRESENT_PARAMETERS;
rc: D3DLOCKED_RECT;
pitch: UINT;
shot: PByte;
shot_size: cardinal;
adapter: cardinal;
wr: TRect;
hCurWnd: THandle;
hCurThreadID: Cardinal;
L: integer;
hFlags: cardinal;
hr: HRESULT;
begin
result := false;
cs := default(TWindowSnapshot);
try
{ get the window type }
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
{ size }
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
{ title }
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
cs.window_handle := win_handle;
cs.window_rect := wr;
cs.process_id := PID;
{ Direct3D capture }
adapter := D3DADAPTER_DEFAULT;
D3D := Direct3DCreate9(D3D_SDK_VERSION);
HRCHECK(D3D.GetAdapterDisplayMode(adapter,mode));
parameters := default(D3DPRESENT_PARAMETERS);
parameters.Windowed := TRUE;
parameters.BackBufferCount := 1;
parameters.BackBufferHeight := mode.Height;
parameters.BackBufferWidth := mode.Width;
parameters.SwapEffect := D3DSWAPEFFECT_DISCARD;
parameters.hDeviceWindow := win_handle;
{ create device & capture surface }
HRCHECK(d3d.CreateDevice(adapter, D3DDEVTYPE_HAL, win_handle, D3DCREATE_SOFTWARE_VERTEXPROCESSING, #parameters, device));
{ create surface }
HRCHECK(device.CreateOffscreenPlainSurface(mode.Width, mode.Height, D3DFMT_A8R8G8B8, D3DPOOL_SYSTEMMEM, &surface, nil));
{ bring our window to front }
hCurWnd := GetForegroundWindow;
hCurThreadID := GetCurrentThreadId;
AttachThreadInput(PID,hCurThreadID,TRUE);
SetWindowPos(win_handle,HWND_TOPMOST,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
SetWindowPos(win_handle,HWND_NOTOPMOST,0,0,0,0,SWP_SHOWWINDOW or SWP_NOSIZE or SWP_NOMOVE);
SetForegroundWindow(win_handle);
SetFocus(win_handle);
SetActiveWindow(win_handle);
AttachThreadInput(PID,hCurThreadID,false);
{ Obtain stride value to allocate buffer }
HRCHECK(surface.LockRect(rc,nil,0));
pitch := rc.Pitch;
HRCHECK(surface.UnlockRect());
shot_size := pitch*mode.Height;
getmem(shot,shot_size);
if not assigned(shot) then abort;
try
{ get surface data }
HRCHECK(device.GetFrontBufferData(0, surface));
{ copy surface data }
HRCHECK(surface.LockRect(rc,nil,0));
move(rc.pBits^,shot^,shot_size);
HRCHECK(surface.UnlockRect());
{ save snapshot to file using WIC, using a temporary file name first }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
if WICSavePixelsToPng(wr,pitch,shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
finally
FreeMem(shot);
end;
except
result := false;
end;
end;
The limitation that I have with the D3D method is that in reality I don't take a snapshot of a specific window but I take a snapshot of the entire screen that I crop after to take only the window of my interest.
For that, I must bring first the target window to front, but in some case this may not be possible. For instance if the target form is behind a modal form, it might be partially or totally hidden, as one can see below
So, my question : Is it possible to take a snapshot / print a single Firemonkey 2D form from another process, even if the form is not modal / partially covered by another form.
(Sorry for an answer here rather than a comment, which I can't do.)
I know little about working with different processes, but do you realise that FMX has a snapshot ability built in?
TControl.MakeScreenshot returns a bitmap of the control (with child controls). So if you can call that from the other process and return the result, that might solve your problem.
However, this won't meet your needs if you literally need the whole form including the non-client area, as a form doesn't have that method. If the contents of the form are all you need, and you have a control (e.g. a TLayout) filling the form and containing all the child controls, you could use the .MakeScreenshot of that bottom control.
And yes, .MakeScreeshot works even if something else is covering the form.
I am trying (unsuccessfully) to copy/reproduce the background gradient of a Windows menu bar onto a bitmap.
In the IconToBitmap function below, the FillRect (wishfully) uses the GetSysColorBrush(COLOR_MENU) in an attempt have it paint the menu background the way it is in Windows (unsurprisingly, the brush isn't a gradient but, it was worth a try.)
The BitBlt below it is an attempt to "cheat". Grab a portion of the already painted menu bar and use that. That didn't work either and I suspect the reason may be because the function IconToBitmap is called during the WM_CREATE of the main window (I'm not sure the menu bar exists that early in the window creation.) I do need the background before the window is first made visible, that's the reason the function is called when processing WM_CREATE (but any other way that works before the window is visible is perfect.)
At this point, I'm out of ideas.
If someone knows how to either grab that menu background or reproduce it on a bitmap, that would be great.
Thank you.
PS: hardcoded values in the function will be removed in the final working version (hopefully, there will be one.) Also, for Delphi, the datatype ptrint has to be changed to NativeInt.
function IconToBitmap(Wnd : HWND; Icon : HICON) : HBITMAP;
var
Bitmap : HBITMAP;
BitmapDc : HDC;
BitmapRect : TRECT;
OldBitmap : HBITMAP;
dc : HDC;
MenuHeight : ptrint;
MenuY : ptrint;
WindowDc : HDC;
begin
Bitmap := 0;
BitmapDc := 0;
OldBitmap := 0;
dc := 0;
MenuY := 0;
MenuHeight := 0;
WindowDc := 0;
MenuY := GetSystemMetrics(SM_CYSIZEFRAME) +
GetSystemMetrics(SM_CYCAPTION);
MenuHeight := GetSystemMetrics(SM_CYMENUSIZE);
WindowDc := GetWindowDC(Wnd);
dc := GetDC(0);
BitmapDc := CreateCompatibleDC(dc);
Bitmap := CreateCompatibleBitmap(dc, 16, 16);
OldBitmap := SelectObject(BitmapDc, Bitmap);
with BitmapRect do
begin
Left := 0;
Top := 0;
Right := 16;
Bottom := 16;
end;
FillRect(BitmapDc, BitmapRect, GetSysColorBrush(COLOR_MENU));
BitBlt(BitmapDc, 0, 0, 16, 16, WindowDc, 20, MenuY, SRCCOPY);
DrawIconEx(BitmapDc,
0,
0,
Icon,
16,
16,
0,
0,
DI_NORMAL);
SelectObject(BitmapDc, OldBitmap);
DeleteDC(BitmapDc);
ReleaseDC(0, dc);
IconToBitmap := Bitmap;
end;
Use the visual styles API to draw theme parts. Below example paints a menu bar background in the top of the client area of a form. You can adapt it to draw onto a bitmap canvas.
uses
uxtheme, types;
procedure TForm1.FormPaint(Sender: TObject);
var
Theme: HTHEME;
Size: TSize;
Rect: TRect;
begin
Theme := OpenThemeData(Handle, VSCLASS_MENU);
GetThemePartSize(Theme, Canvas.Handle, MENU_BARBACKGROUND, MB_ACTIVE, nil,
TS_TRUE, Size);
Rect.Create(0, 0, ClientWidth, Size.cy);
DrawThemeBackground(Theme, Canvas.Handle, MENU_BARBACKGROUND, MB_ACTIVE,
Rect, nil);
CloseThemeData(Theme);
end;
In a WM_PAINT handler this could look like the following.
procedure TForm1.WMPaint(var Message: TWMPaint);
var
DC: HDC;
PS: TPaintStruct;
Theme: HTHEME;
Size: TSize;
Rect: TRect;
begin
if Message.DC = 0 then
DC := BeginPaint(Handle, PS)
else
DC := Message.DC;
Theme := OpenThemeData(Handle, VSCLASS_MENU);
GetThemePartSize(Theme, DC, MENU_BARBACKGROUND, MB_ACTIVE, nil,
TS_TRUE, Size);
Rect.Create(0, 0, ClientWidth, Size.cy);
DrawThemeBackground(Theme, DC, MENU_BARBACKGROUND, MB_ACTIVE,
Rect, nil);
CloseThemeData(Theme);
if Message.DC = 0 then begin
Message.DC := DC;
inherited;
EndPaint(Handle, PS);
end else
inherited;
end;
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 have image (500x500) but I need to resize it to 200x200 and paint it on TImage. How to achieve such result?
NoteI know about Stretch property in TImage, but I want to resize the image programmatically.
If you know that the new dimensions are not greater than the original ones, you can simply do
procedure ShrinkBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer);
begin
Bitmap.Canvas.StretchDraw(
Rect(0, 0, NewWidth, NewHeight),
Bitmap);
Bitmap.SetSize(NewWidth, NewHeight);
end;
I leave it as an exercise to write the corresponding code if you know that the new dimensions are not smaller than the original ones.
If you want a general function, you could do
procedure ResizeBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer);
var
buffer: TBitmap;
begin
buffer := TBitmap.Create;
try
buffer.SetSize(NewWidth, NewHeight);
buffer.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), Bitmap);
Bitmap.SetSize(NewWidth, NewHeight);
Bitmap.Canvas.Draw(0, 0, buffer);
finally
buffer.Free;
end;
end;
This approach has the downside of doing two pixel-copy operations. I can think of at least two solutions to that problem. (Which?)
Great usability and picture quality offers the ResizeImage function(s) from the unit 1) below. The code depends on Graphics32, GIFImage 2) and PNGImage 2).
The function takes two file names or two streams. Input is (automatically detected as) BMP, PNG, GIF or JPG, output is always JPG.
unit AwResizeImage;
interface
uses
Windows, SysUtils, Classes, Graphics, Math, JPEG, GR32, GIFImage, PNGImage,
GR32_Resamplers;
type
TImageType = (itUnknown, itBMP, itGIF, itJPG, itPNG);
TImageInfo = record
ImgType: TImageType;
Width: Cardinal;
Height: Cardinal;
end;
function GetImageInfo(const AFilename: String): TImageInfo; overload;
function GetImageInfo(const AStream: TStream): TImageInfo; overload;
function ResizeImage(const ASource, ADest: String; const AWidth,
AHeight: Integer; const ABackColor: TColor;
const AType: TImageType = itUnknown): Boolean; overload;
function ResizeImage(const ASource, ADest: TStream; const AWidth,
AHeight: Integer; const ABackColor: TColor;
const AType: TImageType = itUnknown): Boolean; overload;
implementation
type
TGetDimensions = procedure(const ASource: TStream;
var AImageInfo: TImageInfo);
TCardinal = record
case Byte of
0: (Value: Cardinal);
1: (Byte1, Byte2, Byte3, Byte4: Byte);
end;
TWord = record
case Byte of
0: (Value: Word);
1: (Byte1, Byte2: Byte);
end;
TPNGIHDRChunk = packed record
Width: Cardinal;
Height: Cardinal;
Bitdepth: Byte;
Colortype: Byte;
Compression: Byte;
Filter: Byte;
Interlace: Byte;
end;
TGIFHeader = packed record
Signature: array[0..2] of Char;
Version: array[0..2] of Char;
Width: Word;
Height: Word;
end;
TJPGChunk = record
ID: Word;
Length: Word;
end;
TJPGHeader = packed record
Reserved: Byte;
Height: Word;
Width: Word;
end;
const
SIG_BMP: array[0..1] of Char = ('B', 'M');
SIG_GIF: array[0..2] of Char = ('G', 'I', 'F');
SIG_JPG: array[0..2] of Char = (#255, #216, #255);
SIG_PNG: array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10);
function SwapBytes(const ASource: Cardinal): Cardinal; overload;
var
mwSource: TCardinal;
mwDest: TCardinal;
begin
mwSource.Value := ASource;
mwDest.Byte1 := mwSource.Byte4;
mwDest.Byte2 := mwSource.Byte3;
mwDest.Byte3 := mwSource.Byte2;
mwDest.Byte4 := mwSource.Byte1;
Result := mwDest.Value;
end;
function SwapBytes(const ASource: Word): Word; overload;
var
mwSource: TWord;
mwDest: TWord;
begin
mwSource.Value := ASource;
mwDest.Byte1 := mwSource.Byte2;
mwDest.Byte2 := mwSource.Byte1;
Result := mwDest.Value;
end;
procedure GetBMPDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
bmpFileHeader: TBitmapFileHeader;
bmpInfoHeader: TBitmapInfoHeader;
begin
FillChar(bmpFileHeader, SizeOf(TBitmapFileHeader), #0);
FillChar(bmpInfoHeader, SizeOf(TBitmapInfoHeader), #0);
ASource.Read(bmpFileHeader, SizeOf(TBitmapFileHeader));
ASource.Read(bmpInfoHeader, SizeOf(TBitmapInfoHeader));
AImageInfo.Width := bmpInfoHeader.biWidth;
AImageInfo.Height := bmpInfoHeader.biHeight;
end;
procedure GetGIFDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
gifHeader: TGIFHeader;
begin
FillChar(gifHeader, SizeOf(TGIFHeader), #0);
ASource.Read(gifHeader, SizeOf(TGIFHeader));
AImageInfo.Width := gifHeader.Width;
AImageInfo.Height := gifHeader.Height;
end;
procedure GetJPGDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
cSig: array[0..1] of Char;
jpgChunk: TJPGChunk;
jpgHeader: TJPGHeader;
iSize: Integer;
iRead: Integer;
begin
FillChar(cSig, SizeOf(cSig), #0);
ASource.Read(cSig, SizeOf(cSig));
iSize := SizeOf(TJPGChunk);
repeat
FillChar(jpgChunk, iSize, #0);
iRead := ASource.Read(jpgChunk, iSize);
if iRead <> iSize then
Break;
if jpgChunk.ID = $C0FF then
begin
ASource.Read(jpgHeader, SizeOf(TJPGHeader));
AImageInfo.Width := SwapBytes(jpgHeader.Width);
AImageInfo.Height := SwapBytes(jpgHeader.Height);
Break;
end
else
ASource.Position := ASource.Position + (SwapBytes(jpgChunk.Length) - 2);
until False;
end;
procedure GetPNGDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
cSig: array[0..7] of Char;
cChunkLen: Cardinal;
cChunkType: array[0..3] of Char;
ihdrData: TPNGIHDRChunk;
begin
FillChar(cSig, SizeOf(cSig), #0);
FillChar(cChunkType, SizeOf(cChunkType), #0);
ASource.Read(cSig, SizeOf(cSig));
cChunkLen := 0;
ASource.Read(cChunkLen, SizeOf(Cardinal));
cChunkLen := SwapBytes(cChunkLen);
if cChunkLen = SizeOf(TPNGIHDRChunk) then
begin
ASource.Read(cChunkType, SizeOf(cChunkType));
if AnsiUpperCase(cChunkType) = 'IHDR' then
begin
FillChar(ihdrData, SizeOf(TPNGIHDRChunk), #0);
ASource.Read(ihdrData, SizeOf(TPNGIHDRChunk));
AImageInfo.Width := SwapBytes(ihdrData.Width);
AImageInfo.Height := SwapBytes(ihdrData.Height);
end;
end;
end;
function GetImageInfo(const AFilename: String): TImageInfo;
var
fsImage: TFileStream;
begin
fsImage := TFileStream.Create(AFilename, fmOpenRead or fmShareDenyWrite);
try
Result := GetImageInfo(fsImage);
finally
FreeAndNil(fsImage);
end;
end;
function GetImageInfo(const AStream: TStream): TImageInfo;
var
iPos: Integer;
cBuffer: array[0..2] of Char;
cPNGBuffer: array[0..4] of Char;
GetDimensions: TGetDimensions;
begin
GetDimensions := nil;
Result.ImgType := itUnknown;
Result.Width := 0;
Result.Height := 0;
FillChar(cBuffer, SizeOf(cBuffer), #0);
FillChar(cPNGBuffer, SizeOf(cPNGBuffer), #0);
iPos := AStream.Position;
AStream.Read(cBuffer, SizeOf(cBuffer));
if cBuffer = SIG_GIF then
begin
Result.ImgType := itGIF;
GetDimensions := GetGIFDimensions;
end
else if cBuffer = SIG_JPG then
begin
Result.ImgType := itJPG;
GetDimensions := GetJPGDimensions;
end
else if cBuffer = Copy(SIG_PNG, 1, 3) then
begin
AStream.Read(cPNGBuffer, SizeOf(cPNGBuffer));
if cPNGBuffer = Copy(SIG_PNG, 4, 5) then
begin
Result.ImgType := itPNG;
GetDimensions := GetPNGDimensions;
end;
end
else if Copy(cBuffer, 1, 2) = SIG_BMP then
begin
Result.ImgType := itBMP;
GetDimensions := GetBMPDimensions;
end;
AStream.Position := iPos;
if Assigned(GetDimensions) then
begin
GetDimensions(AStream, Result);
AStream.Position := iPos;
end;
end;
procedure GIFToBMP(const ASource: TStream; const ADest: TBitmap);
var
imgSource: TGIFImage;
begin
imgSource := TGIFImage.Create();
try
imgSource.LoadFromStream(ASource);
ADest.Assign(imgSource);
finally
FreeAndNil(imgSource);
end;
end;
procedure JPGToBMP(const ASource: TStream; const ADest: TBitmap);
var
imgSource: TJPEGImage;
begin
imgSource := TJPEGImage.Create();
try
imgSource.LoadFromStream(ASource);
ADest.Assign(imgSource);
finally
FreeAndNil(imgSource);
end;
end;
procedure PNGToBMP(const ASource: TStream; const ADest: TBitmap);
var
imgSource: TPNGImage;
begin
imgSource := TPNGImage.Create();
try
imgSource.LoadFromStream(ASource);
ADest.Assign(imgSource);
finally
FreeAndNil(imgSource);
end;
end;
function ResizeImage(const ASource, ADest: String; const AWidth,
AHeight: Integer; const ABackColor: TColor;
const AType: TImageType = itUnknown): Boolean;
var
fsSource: TFileStream;
fsDest: TFileStream;
begin
Result := False;
fsSource := TFileStream.Create(ASource, fmOpenRead or fmShareDenyWrite);
try
fsDest := TFileStream.Create(ADest, fmCreate or fmShareExclusive);
try
Result := not Result; //hide compiler hint
Result := ResizeImage(fsSource, fsDest, AWidth, AHeight, ABackColor, AType);
finally
FreeAndNil(fsDest);
end;
finally
FreeAndNil(fsSource);
end;
end;
function ResizeImage(const ASource, ADest: TStream; const AWidth,
AHeight: Integer; const ABackColor: TColor;
const AType: TImageType = itUnknown): Boolean;
var
itImage: TImageType;
ifImage: TImageInfo;
bmpTemp: TBitmap;
bmpSource: TBitmap32;
bmpResized: TBitmap32;
cBackColor: TColor32;
rSource: TRect;
rDest: TRect;
dWFactor: Double;
dHFactor: Double;
dFactor: Double;
iSrcWidth: Integer;
iSrcHeight: Integer;
iWidth: Integer;
iHeight: Integer;
jpgTemp: TJPEGImage;
begin
Result := False;
itImage := AType;
if itImage = itUnknown then
begin
ifImage := GetImageInfo(ASource);
itImage := ifImage.ImgType;
if itImage = itUnknown then
Exit;
end;
bmpTemp := TBitmap.Create();
try
case itImage of
itBMP: bmpTemp.LoadFromStream(ASource);
itGIF: GIFToBMP(ASource, bmpTemp);
itJPG: JPGToBMP(ASource, bmpTemp);
itPNG: PNGToBMP(ASource, bmpTemp);
end;
bmpSource := TBitmap32.Create();
bmpResized := TBitmap32.Create();
try
cBackColor := Color32(ABackColor);
bmpSource.Assign(bmpTemp);
bmpResized.Width := AWidth;
bmpResized.Height := AHeight;
bmpResized.Clear(cBackColor);
iSrcWidth := bmpSource.Width;
iSrcHeight := bmpSource.Height;
iWidth := iSrcWidth;
iHeight := iSrcHeight;
with rSource do
begin
Left := 0;
Top := 0;
Right := iSrcWidth;
Bottom := iSrcHeight;
end;
if (iWidth > AWidth) or (iHeight > AHeight) then
begin
dWFactor := AWidth / iWidth;
dHFactor := AHeight / iHeight;
if (dWFactor > dHFactor) then
dFactor := dHFactor
else
dFactor := dWFactor;
iWidth := Floor(iWidth * dFactor);
iHeight := Floor(iHeight * dFactor);
end;
with rDest do
begin
Left := Floor((AWidth - iWidth) / 2);
Top := Floor((AHeight - iHeight) / 2);
Right := Left + iWidth;
Bottom := Top + iHeight;
end;
bmpSource.Resampler := TKernelResampler.Create;
TKernelResampler(bmpSource.Resampler).Kernel := TLanczosKernel.Create;
bmpSource.DrawMode := dmOpaque;
bmpResized.Draw(rDest, rSource, bmpSource);
bmpTemp.Assign(bmpResized);
jpgTemp := TJPEGImage.Create();
jpgTemp.CompressionQuality := 80;
try
jpgTemp.Assign(bmpTemp);
jpgTemp.SaveToStream(ADest);
Result := True;
finally
FreeAndNil(jpgTemp);
end;
finally
FreeAndNil(bmpResized);
FreeAndNil(bmpSource);
end;
finally
FreeAndNil(bmpTemp);
end;
end;
end.
Notes:
1) I surely didn't code this myself, but do not know anymore where I got it from.
2) Included in recent Delphi versions.
If compiling with more recent versions of RAD Studio/Delphi XE, remember to substitute char with ansichar for all char variable types otherwise the GetImageInfo will not work, and it will not resize the image. This is needed as the default char type is two bytes, and the function expects it to be single byte.
I've often used the SmoothResize procedure from this page: http://www.swissdelphicenter.ch/torry/printcode.php?id=1896
The scaling is much better than the StretchDraw function.
Don't let the title fool you. The page demonstrates resizing JPGs, but the SmoothResize procedure itself uses bitmaps for resizing. Resizing PNGs could be done in a similar matter, but you will loose transparency if you use this procedure.
Please see this simple example on how to resize an image using two TBitmap32 objects. The TBitmap32 is the best in terms of speed/image quality ratio.
It requires the https://github.com/graphics32 library.
uses
GR32, GR32_Resamplers;
procedure Resize(InputPicture: TBitmap; OutputImage: TImage; const DstWidth, DstHeigth: Integer);
var
Src, Dst: TBitmap32;
begin
Dst := nil;
try
Src := TBitmap32.Create;
try
Src.Assign(InputPicture);
SetHighQualityStretchFilter(Src);
Dst := TBitmap32.Create;
Dst.SetSize(DstWidth, DstHeigth);
Src.DrawTo(Dst, Rect(0, 0, DstWidth, DstHeigth), Rect(0, 0, Src.Width, Src.Height));
finally
FreeAndNil(Src);
end;
OutputImage.Assign(Dst);
finally
FreeAndNil(Dst);
end;
end;
// If you need to set a highest quality resampler, use this helper routine to configure it
procedure SetHighQualityStretchFilter(B: TBitmap32);
var
KR: TKernelResampler;
begin
if not (B.Resampler is TKernelResampler) then
begin
KR := TKernelResampler.Create(B);
KR.Kernel := TLanczosKernel.Create;
end
else
begin
KR := B.Resampler as TKernelResampler;
if not (KR.Kernel is TLanczosKernel) then
begin
KR.Kernel.Free;
KR.Kernel := TLanczosKernel.Create;
end;
end;
end;
I have done quite some extensive testing (10 algorithms/libraries) in this direction. I only mention the first three.
If you are lazy to read, skip to MY conclusions
:)
JanFX library
Now incorporated into the fat Jedi distribution. FORTUNATELY you can extract this file from Jedi without having to drag the whole mammoth into your project.
It gives a very nice smoothing (not as good as Graphics32 but good enough) but much, much faster.
Note: The JanFX.pas in Jedi is bugged: does not work when range checking is on. You need to define {$R-} before the code. That's it. The guys at Jedi entered this bug because they ALWAYS compile with range checking off.
JanFx.SmoothResize(SrcBMP, DstBMP);
Graphics32 lib
Super good output quality.
But if all you need is a resampler, it might be overkill to use the entire Graphics32 lib. JanFx is much smaller and portable. Graphics32 will give you slightly better results, BUT the processing times are about 10x higher!
StretchBlt
If you don't want to involve external libraries, look into StretchBlt.
This will not give you the best results as Graphics32, but it is ridiculously faster, compared with Graphics32.
(see code below)
Conclusion:
StretchBlt is my final choice for my programs, being the best trade between the output quality and speed. It does a good job not only in downsampling but also in upsampling.
{-------------------------------------------------------------------------------------------------------------
Uses MS Windows StretchBlt
BEST (see tester)
Zoom: In/Out
Keep aspect ration: No
Stretch provided in: pixels
Resize down: VERY smooth. Better than JanFX.SmoothResize.
Resize up: better (sharper) than JanFX.SmoothResize
Time: similar to JanFx
BitBlt only does copy. NO STRETCH
https://msdn.microsoft.com/en-us/library/windows/desktop/dd162950(v=vs.85).aspx
-------------------------------------------------------------------------------------------------------------}
function StretchF(BMP: TBitmap; OutWidth, OutHeight: Integer): TBitmap;
begin
if (BMP.Width < 12) OR (BMP.Height< 12) then
begin
ShowMessage('Cannot stretch images under 12 pixels!'); { 'WinStretchBltF' will crash if the image size is too small (below 10 pixels)}
EXIT(NIL);
end;
Result:= TBitmap.Create;
TRY
Result.PixelFormat:= BMP.PixelFormat; { Make sure we use the same pixel format as the original image }
SetLargeSize(Result, OutWidth, OutHeight);
SetStretchBltMode(Result.Canvas.Handle, HALFTONE);
SetBrushOrgEx (Result.Canvas.Handle, 0,0, NIL);
StretchBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height, BMP.Canvas.Handle, 0, 0, BMP.Width, BMP.Height, SRCCOPY);
FINALLY
FreeAndNil(Result);
RAISE;
END;
end;
for any type of images, you can use this:
img := TIMage.create(nil);
img.picture.loadfromfile('any_file_type');
Result:= TBitmap.Create;
result.Width := newWidth;
result.Height := newHeight;
Result.Canvas.Draw(0,0,img.Picture.Graphic);
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