Related
I'm creating a toggle button using the SwinGame library. Right now I'm struggling with actually making it toggle. That bit looks like this:
var
clr: Color;
clicked: Boolean;
boolcheck: String;
begin
OpenGraphicsWindow('Toggle button test', windowsWidth, windowsHeight);
clr := ColorWhite;
clicked := true;
boolcheck := 'true';
repeat
ClearScreen(clr);
ProcessEvents();
//Play button and Pause button
if (ButtonClicked(buttonX-buttonRadius, buttonY-buttonRadius, buttonRadius*2, buttonRadius*2) = true) and (clicked = true) then
begin
clr := ColorRed;
clicked := false;
boolcheck := 'false';
DrawAButton();
end
else if (ButtonClicked(buttonX-buttonRadius, buttonY-buttonRadius, buttonRadius*2, buttonRadius*2) = true) and (clicked = false) then
begin
clr := ColorBlue;
clicked := true;
boolcheck := 'true';
DrawADifferentButton();
end;
DrawText(echo, ColorBlack, 'arial.ttf', 14, 55, 55);
RefreshScreen();
until WindowCloseRequested();
end;
Basically I intended to make it so if the user clicks on this area of the window via ButtonClicked() (a SwinGame function), and the clicked variable is false, then the background color will be red, if not then blue. But for some reason I could only change it to red, blue did not appear at all. I did some troubleshooting by creating a boolcheck variable and I saw the variable was constantly being put at true, I did see it change to false for a fraction of a second then back to true....But I did not put the clicked variable initial definition inside the loop, so why isn't it staying false?
EDIT: Here's the definition to the ButtonClicked function
function ButtonClicked(posX, posY: Single; w, h: Integer): Boolean;
var
x, y: Single;
begin
x := MouseX();
y := MouseY();
result := false;
if MouseClicked(LeftButton) then
begin
if (x >= posX) and (x <= w + posX) and (y >= posY) and (y <= h + posY) then
begin
result := true;
end;
end;
end;
Ok, thanks to #lurker 's suggestion, I've solved it. After spending some time thinking about #lurker 's suggestion, I realized that once the procedure gets reset, it'll start off with clicked being at 0 again. So what I had to do, was making the the ButtonClicked check a function that returns 1 or 0, or true or false into clicked in Main(). That way clicked will always be updated, and the procedure won't be reset with clicked being at 0 all the time.
function Toggle(clicked): Integer;
if ButtonClicked(buttonX-buttonRadius, buttonY-buttonRadius, buttonRadius*2, buttonRadius*2) then
if (clicked := true) then
begin
clr := ColorRed;
result := false;
DrawAButton();
end
else
begin
clr := ColorBlue;
result := true;
DrawADifferentButton();
end;
then in `Main()` I would call it as follow:
//Stuffs
begin
clicked := true;
repeat
clicked := Toggle(clicked);
//Other stuffs
program GameMain;
uses SwinGame, sgTypes;
function buttonClicked(p1, Next_PARAM_thingie: Single; W, lastOne: Integer): Boolean;
var blah, blee: Single; _r_, BTMOB: Single;
begin blah := MouseX(); blee := MouseY(); _r_ := p1 + W; BTMOB := Next_PARAM_thingie + lastOne; result := false;
if MouseClicked( LeftButton ) then
begin
if (blah >= p1) and (blah <= _r_) then
begin result := true;
end;
end;
end;
procedure Main();
var
clr: Color;
begin
OpenGraphicsWindow('Test Program for Button Click Code', 800, 600);
ShowSwinGameSplashScreen();
clr := ColorWhite;
repeat
clearScreen(clr);
drawframerate(0,0);
fillRectangle(ColorGrey, 50, 50, 100, 30);
drawtext('Click Me', ColorBlack, 'arial.ttf', 14, 55, 55);
RefreshScreen();
Processevents();
if buttonClicked(50, 50, 100, 30) then
begin
clr := RandomRGBcolor(255);
end;
until WindowCloseRequested();
end;
begin
main();
end.
I have been trying to figure out what does what but it isn't going to well. I could use some help trying to figure out what each of these random words do so I can change the name so the code is more understanding
The first thing that I would do is work through removing things that are unneeded. In the code sample given, BTMOB is entirely unused, so I would remove it and the code that sets its value. With BTMOB removed, the lastOne parameter is no longer needed, so it goes away.
Keep chipping away things that don't belong at all and using whatever context clues are available to give things that are used more meaningful names. There will be some things that you may not be able to guess just by analyzing the code and potentially not even through runtime debugging, but you should be able to make it far more readable. Here's an example of how buttonClicked might look after the first pass (you'd also have to change the code that calls it to no longer pass the unused parameters that were removed).
function buttonClicked(p1: Single; W: Integer): Boolean;
var posX: Single; _r_: Single;
begin posX := MouseX(); _r_ := p1 + W; result := false;
if MouseClicked( LeftButton ) then
begin
if (posX >= p1) and (posX <= _r_) then
begin result := true;
end;
end;
end;
I'm stuck in a class derived from TShape.
In the Paint method, I use the Canvas to draw a rectangle. In the Form, I have a TTrackBar that allows to change Left and Top coordinates of the TShape.
It does not matter what values I set to the Left and Top using the TTrackBar, the rectangle does not move accordingly. Instead, when I set those values via code, the rectangle appears in the correct position.
I'm coding a FireMonkey app with Delphi 10.1 Berlin on Windows 10.
unit frmShapeStudy;
interface
type
tMy_Shape = class (tShape)
protected
procedure Paint; override;
public
constructor Create (aOwner: tComponent); override;
procedure Draw;
end;
tformShapeStudy = class (tForm)
trkBarLeft: TTrackBar;
trkBarTop: TTrackBar;
procedure FormCreate (Sender: tObject);
procedure TrackBarChange (Sender: tObject);
end;
var
formShapeStudy: tformShapeStudy;
implementation
{$R *.fmx}
var
My_Shape : tMy_Shape;
lvShapeRect : tRectF ;
procedure tformShapeStudy.FormCreate (Sender: tObject);
begin
My_Shape := tMy_Shape.Create (Self);
with My_Shape do begin
Parent := Self;
TrackBarChange (Self);
end;
end;
procedure tformShapeStudy.TrackBarChange (Sender: TObject);
begin
My_Shape.Draw;
end;
constructor tMy_Shape.Create (aOwner: tComponent);
begin
inherited;
with lvShapeRect do begin
Left := Self.Left;
Top := Self.Top ;
Height := 20;
Width := 20;
end;
end;
procedure tBS_Shape.Draw;
begin
l := formShapeStudy.trkBarLeft.Value;
t := formShapeStudy.trkBarTop .Value;
{`Left & Top` are set with `l & t` or with `120 & 150`
and tested separately, by commenting the propper code lines}
lvShapeRect.Left := l; // this does no work
lvShapeRect.Top := t; // this does no work
lvShapeRect.Left := 120; // this works
lvShapeRect.Top := 150; // this works
Repaint;
end;
procedure tMy_Shape.Paint;
begin
inherited;
with Canvas do begin
Fill .Color := tAlphaColorRec.Aqua;
Stroke.Color := tAlphaColorRec.Blue;
BeginScene;
FillRect (lvShapeRect, 0, 0, Allcorners, 1, tCornerType.Bevel);
DrawRect (lvShapeRect, 0, 0, Allcorners, 1, tCornerType.Bevel);
EndScene;
end;
end;
end.
Sorry Folks! Is the old habit of using Left & Top instead of Position.X & Position.Y. I agree with the new Position way to set Left & Top, but it doesn't make sense that Embarcadero still makes available this properties, but they do nothing in terms of setting Left & Top of the control. Saying it in other words, since those old properties are still available, they should set the Left & Top properties same as Position.X & Position.Y, otherwise it leads to this kind of mistake, where you sware you are setting Left & Top, but the control does not move.
The correct way to set Left & Top is:
Position.X := aLeft;
Position.Y := aTop;
unless Embarcadero changes the behavior of Left & Top properties (wich is very unlikely).
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).
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