Why does this simple DLL crash before WM_ACTIVATEAPP arrives? - windows

The minimal DLL below, which uses only the Win32 API, tries to do nothing more than create an MDI frame/client window and one child window, and destroy the frame window when the DLL unloads. The DLL crashes on Windows XP with an exception upon executing an INT x2B instruction in USER32.
For testing, the DLL is simply invoked by a one-line application calling LoadLibrary('badcode.dll').
The crash happens inside the final "DestroyWindow(framewindowhandle)" just before the DLL finishes, after FrameWindowProc receives WM_ACTIVATE but before it receives WM_ACTIVEAPP.
The DLL code has been trimmed down from a much larger original as much as possible to isolate the bug. Although not destroying the frame window also makes the current crash go away, about 12 years ago it was determined that tools like Visual Basic running on NT would crash unless "DestroyWindow(framewindowhandle)" was called before the DLL was unloaded. Just recently, however, a new small program written to test some of the DLL entrypoints was suddenly found to be crashing on XP as described above.
Although written in Delphi 6, the code only relies on the vanilla Win32 API.
library badcode; // works if rewritten as a program instead of DLL
{$R *.RES} // removing this avoids crash
uses windows, messages; // only win32 calls are made
// 3 MDI window handles
var framewindowhandle, clientwindowhandle, childwindowhandle: hwnd;
function framewindowproc(windowhandle: hwnd; message: word; wparam, lparam: longint): longint; stdcall;
var ccs: tclientcreatestruct;
begin // frame window has received a message
if message = WM_CREATE then
begin // create the client window
ccs.hwindowmenu := 0; ccs.idfirstchild := 0;
clientwindowhandle := createwindow('MDICLIENT', '', ws_child + ws_clipchildren + ws_visible, 10, 10, 50, 50, windowhandle, 0, hinstance, #ccs);
result := 0; // we handled the message
end
else // do default handling
result := defframeproc(windowhandle, clientwindowhandle, message, wparam, lparam);
end;
function childwindowproc(windowhandle: hwnd; message: word; wparam, lparam: longint): longint; stdcall;
begin // child window has received a message, do default handling
result := defmdichildproc(windowhandle, message, wparam, lparam);
end;
procedure DLLHandler(reason: integer);
begin
if reason = DLL_PROCESS_DETACH then // unloading dll
DestroyWindow(framewindowhandle); // causes the crash, never returns
end;
var wc: twndclass; mcs: tmdicreatestruct;
begin // DLL loading time
DLLProc := #DLLHandler; // so we can detect unload
wc.hinstance := hinstance;
wc.lpfnwndproc := #framewindowproc;
wc.style := 0; wc.cbclsextra := 0; wc.cbwndextra := 0;
wc.hicon := loadicon(0, IDI_ASTERISK);
wc.hcursor := loadcursor(0, IDC_ARROW);
wc.hbrbackground := 0;
wc.lpszmenuname := 'MENUBAR'; // changing to '' avoids the crash
wc.lpszclassname := 'BAD';
registerclass(wc); // register the frame window
wc.lpfnwndproc := #childwindowproc;
wc.lpszmenuname := '';
wc.lpszclassname := 'DATA';
registerclass(wc); // register the child window
framewindowhandle := createwindow('BAD', 'frame', WS_OVERLAPPEDWINDOW + WS_CLIPCHILDREN, 100, 100, 400, 600, 0, 0, hinstance, nil);
mcs.szclass := 'DATA'; mcs.sztitle := 'child'; mcs.howner := hinstance;
mcs.x := 50; mcs.y := 50; mcs.cx := 50; mcs.cy := 50; mcs.style := WS_MINIMIZE; // changing the style avoids the crash
childwindowhandle := sendmessage(clientwindowhandle, WM_MDICREATE, 0, longint(#mcs));
sendmessage(clientwindowhandle, WM_MDIRESTORE, childwindowhandle, 0); // skipping this avoids the crash
end.

Using the excellent dependencywalker tool, I discovered some old scanner software on my machine had configured USER32 to hook in an OCR-related DLL upon the execution of any program, and that DLL was making some questionable-looking calls, including being loaded twice for some reason. Uninstalling the scanner software made the crash go away and all O/S DLL loading/unloading look much more reasonable. Nevertheless, I'll be modifying my DLL to do nothing during attach/detach, and include new entrypoints for starting/stopping.

Related

How to debug startup of app run by SendTo menu

On Windows, I'd like for my FMX app to run from the SendTo context menu. If the app is already running I'd like for the second instance to pass its command line to the first and then exit. Code is below. The problem is that if I have first instance running in the debugger, and then double-click an appropriate file, I see no evidence that the first instance receives a message from a newly started instance. If the app is not already running then the double click starts a new instance as expected.
Is there a way to debug the startup of the instance launched by the SendTo menu?
This code adds the app to the SendTo menu:
class procedure TInstallationController.CreateSendTo;
var
lExePath: string;
lObject: IUnknown;
lSLink: IShellLink;
lPFile: IPersistFile;
lFolderPath: array[0..MAX_PATH] of char;
lLinkName: WideString;
begin
SHGetFolderPath(0, CSIDL_SENDTO, 0, 0, lFolderPath);
lLinkName := Format('%s\%s.lnk', [lFolderPath, 'AppName']);
{$IFNDEF DEBUG}
if String(lLinkName).Contains('debug') then
Tfile.Delete(lLinkName);
{$ENDIF DEBUG}
if not TFile.Exists(lLinkName) then
if CoInitializeEx(nil, COINIT_MULTITHREADED) = S_OK then
begin
lExePath := ParamStr(0);
lObject := CreateComObject(CLSID_ShellLink);
lSLink := lObject as IShellLink;
lPFile := lObject as IPersistFile;
with lSlink do
begin
SetPath(pChar(lExePath));
SetWorkingDirectory(PChar(TPath.GetDirectoryName(lExePath)));
end;
lPFile.Save(PWChar(WideString(lLinkName)), false);
end;
end;
This code is placed before Application.Initialize in the .dpr file:
var
lWindow: HWND;
lMutex: THandle;
lCopyDataStruct: TCopyDataStruct;
i: integer;
lArg: string;
lResult: DWORD;
begin
lMutex := CreateMutex(nil, False, PChar('43671EDF1E5A4B419F213336F2387B0D'));
if lMutex = 0 then
RaiseLastOSError;
if GetLastError = Error_Already_Exists then
begin
FillChar(lCopyDataStruct, Sizeof(lCopyDataStruct), 0);
for I := 1 to ParamCount do
begin
lArg := ParamStr(i);
lCopyDataStruct.cbData := (Length(lArg) + 1)*SizeOf(Char);
lCopyDataStruct.lpData := PChar(lArg);
lWindow := FindWindow('FMT' + STRMainWindowClassName, nil);
SendMessageTimeout(lWindow, WM_COPYDATA, 0, NativeInt(#lCopyDataStruct),
SMTO_BLOCK, 3000, #lResult);
end;
exit;
end;
...
end.
Assignments in FormCreate of the main form to support Windows message forwarding:
...
FHwnd := FmxHandleToHwnd(Handle);
FOldWndProc := GetWindowLongPtr(FHwnd, GWL_WNDPROC);
SetWindowLongPtr(FHwnd, GWL_WNDPROC, NativeInt(#WindowProc));
...
This forwards Windows messages to my main FMX form:
function WindowProc (HWND: HWND; Msg: UINT; wParam: wParam; lParam: lParam): LRESULT; stdcall;
begin
Result := MasterDetailView.WndProc (HWND, Msg, wParam, lParam);
end;
This main form method receives forwarded messages:
function TViewMasterDetail.WndProc(aHwnd: HWND; aMsg: UINT; aWParam: WPARAM;
aLParam: LPARAM): LResult;
begin
Result := 0;
if aMsg = WM_COPYDATA then
begin
TUtils.Log('External file: ' + PChar(PCopyDataStruct(aLParam)^.lpData));
Viewmodel.HandleExternalFile(PChar(PCopyDataStruct(aLParam)^.lpData));
Exit;
end;
result := CallWindowProc(Ptr(fOldWndProc), aHwnd, aMsg, aWParam, aLParam);
end;
TViewMasterDetail.WndProc is called many time, but as far as I can tell aMsg is never WM_COPYDATA. The 'External file:' message never appears in the log. Thanks
Programmer error. To approximate debugging the startup code I ran a copy of the app outside the debugger and then launched a second copy of the app in the debugger, passing the path to the target file on the command line. This told me FindWindow was failing. I wrote this startup code a long time ago and since then have changed the names of UI classes in the app, including the main window. But I neglected to change the constant I used for the class name of the main window and pass to FindWindow. Fixing the constant cleared the error. Just another win for the evils of using text!

GetFontUnicodeRanges without a window

Is there a chance to call GetFontUnicodeRanges without a window? For example, it could be a Windows service not permitted to interact with desktop.
Currently I am testing this with console application:
program UnicodeConsoleOutput;
{$APPTYPE CONSOLE}
uses
SysUtils,
Windows;
var
NumWritten: DWORD;
Text: WideString;
u8s: UTF8String;
procedure Add(AStart, AEnd: Word);
var
i: Word;
begin
Text := Text + WideFormat('[%x...%x]:'#13#10, [AStart, AEnd]);
for i := AStart to AEnd do
Text := Text + WideChar(i);
Text := Text + WideString(#13#10#13#10);
end;
//Actually I want to get glyph ranges for "Consolas" font
procedure GetFontRanges();
type
TRangesArray = array[0..(MaxInt div SizeOf(TWCRange)) - 1] of TWCRange;
PRangesArray = ^TRangesArray;
const
ConsoleTitle = '{A46DD332-0D57-4310-B91E-A68957C20429}';
var
GS: PGlyphSet;
GSSize: LongWord;
i: Integer;
rng: TWCRange;
hConsole: HWND;
hDev: HDC;
begin
//A dirty hack to get console window handle suggested by Microsoft
SetConsoleTitle(PChar(ConsoleTitle));
hConsole := FindWindow(nil, PChar(ConsoleTitle));
hDev := GetDC(hConsole);
try
GSSize := GetFontUnicodeRanges(hDev, nil);
GetMem(Pointer(GS), GSSize);
try
GS.cbThis := GSSize;
GS.flAccel := 0;
GS.cGlyphsSupported := 0;
GS.cRanges := 0;
if GetFontUnicodeRanges(hDev, GS) <> 0 then begin
for i := 0 to GS.cRanges - 1 do begin
rng := PRangesArray(#GS.ranges)[i];
Add(Word(rng.wcLow), Word(rng.wcLow) + rng.cGlyphs - 1);
end;
end;
finally
FreeMem(Pointer(GS), GSSize);
end;
finally
ReleaseDC(hConsole, hDev);
end;
end;
begin
try
GetFontRanges();
SetConsoleOutputCP(CP_UTF8);
u8s := UTF8Encode(Text);
WriteConsole(GetStdHandle(STD_OUTPUT_HANDLE), PChar(u8s), Length(u8s),
NumWritten, nil);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
ReadLn;
end.
In Windows GDI, you can create a device context and select a font into it without needing a handle to a window. E.g.,
HDC hdc = CreateDC(L"DISPLAY", NULL, NULL, NULL);
//CreateCompatibleDC(NULL) also works
HFONT hFont = CreateFont(
-20, 0, 0, 0,
FW_REGULAR,
FALSE, FALSE, FALSE, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS,
CLIP_DEFAULT_PRECIS,
DEFAULT_QUALITY,
DEFAULT_PITCH || FF_DONTCARE,
L"Arial"
);
HFONT oldFont = static_cast<HFONT>(SelectObject(hdc, hFont));
Note that GDI text functions use the UTF-16 encoding, and all of them were created before Unicode had assigned any supplementary-plane characters. As a result, functions that take or return lists of characters that are not a string, such as GetFontUnicodeRanges, don't work well for much of Unicode today. GetFontUnicodeRanges returns a pointer to a GLYPHSET, which has an array of WCRANGE structs. That has a single WCHAR to represent a Unicode character. As a result, GetFontUnicodeRanges has no way to report any Unicode supplementary-plane characters. In some fonts, that might be the majority of characters supported in the font.
In this regard, GDI is not just ancient, but also obsolete. For what you're doing, DirectWrite is a better option: all of its APIs support all Unicode characters.
The DWrite method you want is IDWriteFontFace1::GetUnicodeRanges. Many DWrite APIs, including this, can be used without a window or even a device context. You'll probably want to obtain the IDWriteFontFace1 object by calling IDWriteFont::CreateFontFace, IDWriteFactory::CreateFontFace or IDWriteFontFaceReference::CreateFontFace depending upon the source of the font you're interested in—could be an installed font, a custom font set, a memory blob, or a font file.

How to show the content of a directory in File Explorer as thumbnails?

In a Delphi 10.4.2 win-32 VCL Application in Windows 10, I show the content of a directory in Windows File Explorer using this code and passing a path e.g. C:\MyDirectory\:
procedure ShellOpen(const Url: string; const Params: string = '');
begin
Winapi.ShellAPI.ShellExecute(0, 'Open', PChar(Url), PChar(Params), nil, SW_SHOWNORMAL);
end;
This works. But how can I force Explorer to show the files in this directory using THUMBNAILS? Are there any parameters for this that I could use in this procedure?
I have searched a lot for this but did not find anything.
You want to use the IFolderView::SetCurrentViewMode method.
Here is a C++ (using Visual Studio's ATL) example:
int main()
{
CoInitialize(NULL);
{
// get a shell item
CComPtr<IShellItem> folder;
ATLASSERT(SUCCEEDED(SHCreateItemFromParsingName(L"c:\\myPath1\myPath2", nullptr, IID_PPV_ARGS(&folder))));
// get its PIDL
CComHeapPtr<ITEMIDLIST> pidl;
ATLASSERT(SUCCEEDED(CComQIPtr<IPersistIDList>(folder)->GetIDList(&pidl)));
// open the item
SHELLEXECUTEINFO info = { };
info.cbSize = sizeof(info);
info.fMask = SEE_MASK_IDLIST;
info.nShow = SW_SHOW;
info.lpIDList = pidl;
ATLASSERT(ShellExecuteEx(&info));
// build a variant from the PIDL
UINT size = ILGetSize(pidl);
SAFEARRAY* psa = SafeArrayCreateVector(VT_UI1, 0, size);
CopyMemory(psa->pvData, pidl, size);
CComVariant v;
v.parray = psa;
v.vt = VT_ARRAY | VT_UI1;
// find the opened window
CComPtr<IShellWindows> windows;
ATLASSERT(SUCCEEDED(windows.CoCreateInstance(CLSID_ShellWindows)));
CComVariant empty;
long hwnd;
CComPtr<IDispatch> disp;
do
{
windows->FindWindowSW(&v, &empty, SWC_BROWSER, &hwnd, SWFO_NEEDDISPATCH, &disp);
if (disp)
break;
// we sleep for a while but using events would be better
// see https://stackoverflow.com/a/59974072/403671
Sleep(500);
} while (true);
// get IFolderView
CComPtr<IFolderView> view;
ATLASSERT(SUCCEEDED(IUnknown_QueryService(disp, IID_IFolderView, IID_PPV_ARGS(&view))));
// change view mode
ATLASSERT(SUCCEEDED(view->SetCurrentViewMode(FOLDERVIEWMODE::FVM_THUMBNAIL)));
}
CoUninitialize();
return 0;
}
Here's a Delphi version of the approach given by Simon Mourier:
uses
ComObj, ShellAPI, ShlObj, ActiveX, SHDocVw, ShLwApi;
function IUnknown_QueryService(punk: IUnknown; const guidService: TGUID;
const IID: TGUID; out Obj): HRESULT; stdcall; external 'ShLwApi'
name 'IUnknown_QueryService';
type
TFolderViewMode = (fvmAuto, fvmIcon, fvmSmallIcon, fvmList, fvmDetails,
fvmThumbnail, fvmTile, fvmThumbstrip, fvmContent);
procedure OpenFolder(AHandle: HWND; const AFolder: string; AViewMode: TFolderViewMode);
const
FolderViewModes: array[TFolderViewMode] of Cardinal =
(Cardinal(FVM_AUTO), FVM_ICON, FVM_SMALLICON, FVM_LIST, FVM_DETAILS,
FVM_THUMBNAIL, FVM_TILE, FVM_THUMBSTRIP, FVM_CONTENT);
var
ShellItem: IShellItem;
PIDL: PItemIDList;
SEInfo: TShellExecuteInfo;
ILSize: Cardinal;
SafeArray: PSafeArray;
v: OleVariant;
ShellWindows: IShellWindows;
ExplorerHWND: Integer;
disp: IDispatch;
view: IFolderView;
dummy: OleVariant;
begin
OleCheck(CoInitialize(nil));
try
OleCheck(SHCreateItemFromParsingName(PChar(AFolder), nil, IShellItem, ShellItem));
try
OleCheck((ShellItem as IPersistIDList).GetIDList(PIDL));
try
ZeroMemory(#SEInfo, SizeOf(SEInfo));
SEInfo.cbSize := SizeOf(SEInfo);
SEInfo.Wnd := AHandle;
SEInfo.fMask := SEE_MASK_IDLIST;
SEInfo.nShow := SW_SHOW;
SEInfo.lpIDList := PIDL;
Win32Check(ShellExecuteEx(#SEInfo));
ILSize := ILGetSize(PIDL);
SafeArray := SafeArrayCreateVector(VT_UI1, 0, ILSize);
CopyMemory(SafeArray.pvData, PIDL, ILSize);
PVariantArg(#v).vt := VT_ARRAY or VT_UI1;
PVariantArg(#v).parray := SafeArray;
OleCheck(CoCreateInstance(CLASS_ShellWindows, nil, CLSCTX_LOCAL_SERVER,
IShellWindows, ShellWindows));
try
dummy := Unassigned;
var c: Integer := 0;
repeat
if c > 0 then
Sleep(200);
disp := ShellWindows.FindWindowSW(v, dummy, SWC_BROWSER, ExplorerHWND,
SWFO_NEEDDISPATCH);
Inc(c);
until Assigned(disp) or (c > 15);
if disp = nil then
Exit;
OleCheck(IUnknown_QueryService(disp, IFolderView, IFolderView, view));
try
OleCheck(view.SetCurrentViewMode(FolderViewModes[AViewMode]));
finally
view := nil;
end;
finally
ShellWindows := nil;
end;
finally
CoTaskMemFree(PIDL);
end;
finally
ShellItem := nil;
end;
finally
CoUninitialize;
end;
end;
Instead of sleep-polling indefinitely for the window (and potentially killing the application!), I give up after 3 seconds.
Example usage:
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenFolder(Handle, 'C:\Users\Andreas Rejbrand\Skrivbord\Test', fvmThumbnail);
end;
The view modes,
type
TFolderViewMode = (fvmAuto, fvmIcon, fvmSmallIcon, fvmList, fvmDetails,
fvmThumbnail, fvmTile, fvmThumbstrip, fvmContent);
are mapped directly to Windows' FOLDERVIEWMODEs. Please note that your version of Windows might not support all of them.
No, EXPLORER.EXE has no parameter for this - it neither had one in Windows 7, nor does it have one in Windows 10. There are surprisingly few parameters available anyway.
Your best bet is starting the Explorer thru CreateProcessW() to then obtain the handle of its main thread and finally find the new window. Then you can manipulate individual controls, such as the file list. See this answer, based on AutoIt: Automating Windows Explorer - it basically uses IShellBrowser and (beyond Windows XP) IFolderView2.SetViewModeAndIconSize() to then apply FVM_THUMBNAIL.

Capture Minimize event for Firemonkey form?

I'm trying to do a very simple task... Detect when my form has been minimized.
But it seems Firemonkey has absolutely no way of handling this.
I've tried to use AllocateHWnd to intercept WM_SYSCOMMAND messages, but all I get is WM_ACTIVATEAPP messages and nothing else.
CreateForm:
AllocateHWnd(WndProcHandler);
WndProcHandler:
procedure TfrmMain.WndProcHandler(var Message: TMessage);
begin
if Message.msg = WM_SYSCOMMAND then
OutputDebugStringA('got command');
end;
Got it working with the following code.
Looks for the WM_SIZE command and SIZE_MINIMIZED parameter to detect all minimising events.
uses
Winapi.Windows, Winapi.Messages;
var
WndProcHook: THandle;
function WndProc(Code: integer; WParam, LParam: LongInt): LRESULT; stdcall;
var
msg: TCWPRetStruct;
begin;
if (Code >= HC_ACTION) and (LParam > 0) then begin
msg := PCWPRetStruct(LParam)^;
if (msg.Message = WM_SIZE) and (msg.WParam = SIZE_MINIMIZED) then begin
// Application has been minimized
// Check msg.wnd = WindowHandleToPlatform(Form1.Handle).wnd if necessary
end;
end;
result := CallNextHookEx(WndProcHook, Code, WParam, LParam)
end;
initialization
WndProcHook := SetWindowsHookEx(WH_CALLWNDPROCRET, #WndProc, 0, GetCurrentThreadId);
finalization
UnhookWindowsHookEx(WndProcHook);

Removing NotifyIcon from the notification area

Is it possible to remove NotifyIcon from the notification area (system tray) when an app terminates abruptly?
if no, how can I remove it when the app runs for the next time?
Abruptly? No. Your program has ceased to exist, so there's no opportunity to run any code to tell the shell that it should remove the icon.
To remove the icon, move your mouse over it. The shell will try to notify your program, realize there's nothing there anymore, and remove the icon by itself.
On Windows 7 and later, notify icons can be identified by a user-defined GUID. On earlier versions, they are identified by a combination of HWND and ID number instead. Since your app is not guaranteed to get the same HWND value the next time it runs, the only way you can do anything to an old icon that is identified by HWND is if you remembered the previous HWND value so you can use it to remove the old icon, before then using a new HWND to add a new icon. But with a GUID-identified icon, the GUID needs to be persistent (as it is stored in the Registry to store app settings associated with the icon), so you should be able to simply keep updating the existing icon as needed, or remove it if desired.
FWIW, since code doesn't exist so far, I thought I'd throw this in. I don't know if it will help or not for the OP, but it should be good guidance in the right direction.
unit csystray;
{ removes dead system tray icons, by Glenn1234 # stackoverflow.com
since this uses "less than supported by Microsoft" means, it may
not work on all operating system. It was tested on Windows XP }
interface
uses commCtrl, shellapi, windows;
type
TTrayInfo = packed record
hWnd: HWnd;
uID: UINT;
uCallBackMessage: UINT;
Reserved1: array[0..1] of longint;
Reserved2: array[0..2] of longint;
hIcon: HICON;
end;
PTBButton = ^TTBButton;
_TBBUTTON = packed record
iBitmap: Integer;
idCommand: Integer;
fsState: Byte;
fsStyle: Byte;
bReserved: array[1..2] of Byte;
dwData: Longint;
iString: Integer;
end;
TTBButton = _TBBUTTON;
procedure RemoveStaleTrayIcons;
implementation
procedure RemoveStaleTrayIcons;
const
VMFLAGS = PROCESS_VM_OPERATION or PROCESS_VM_READ OR PROCESS_VM_WRITE;
var
ProcessID: THandle;
ProcessHandle: THandle;
trayhandle: HWnd;
ExplorerButtonInfo: Pointer;
i: integer;
ButtonCount: Longint;
BytesRead: Longint;
ButtonInfo: TTBButton;
TrayInfo: TTrayInfo;
ClassNameA: Array[0..255] of char;
outlen: integer;
TrayIconData: TNotifyIconData;
begin
// walk down the window hierarchy to find the notification area window
trayhandle := FindWindow('Shell_TrayWnd', '');
trayhandle := FindWindowEx(trayhandle, 0, 'TrayNotifyWnd', nil);
trayhandle := FindWindowEx(trayhandle, 0, 'SysPager', nil);
trayhandle := FindWindowEx(trayhandle, 0, 'ToolbarWindow32', nil);
if trayhandle = 0 then exit;
// find the notification area process and open it up for reading.
GetWindowThreadProcessId(trayhandle, #ProcessID);
ProcessHandle := OpenProcess(VMFLAGS, false, ProcessID);
ExplorerButtonInfo := VirtualAllocEx(ProcessHandle, nil, Sizeof(TTBButton),
MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);
// the notification area is a tool bar. Get the number of buttons.
ButtonCount := SendMessage(trayhandle, TB_BUTTONCOUNT, 0, 0);
if ExplorerButtonInfo <> nil then
try
// iterate the buttons & check.
for i := (ButtonCount - 1) downto 0 do
begin
// get button information.
SendMessage(trayhandle, TB_GETBUTTON, i, LParam(ExplorerButtonInfo));
ReadProcessMemory(ProcessHandle, ExplorerButtonInfo, #ButtonInfo,
Sizeof(TTBButton), BytesRead);
// if there's tray data, read and process
if Buttoninfo.dwData <> 0 then
begin
ReadProcessMemory(ProcessHandle, PChar(ButtonInfo.dwData),
#TrayInfo, Sizeof(TTrayInfo), BytesRead);
// here's the validation test, this fails if the master window is invalid
outlen := GetClassName(TrayInfo.hWnd, ClassNameA, 256);
if outlen < 1 then
begin
// duplicate the shell icon removal, i.e. my component's DeleteTray
TrayIconData.cbSize := sizeof(TrayIconData);
TrayIconData.Wnd := TrayInfo.hWnd;
TrayiconData.uID := TrayInfo.uID;
TrayIconData.uCallbackMessage := TrayInfo.uCallBackMessage;
Shell_NotifyIcon(NIM_DELETE, #TrayIconData);
end;
end;
end;
finally
VirtualFreeEx(ProcessID, ExplorerButtonInfo, Sizeof(TTBButton), MEM_RELEASE);
end;
end;
end.

Resources