Related
Edit: the problem didn't lie in NtQuerySystemInformation but in the file type (bObjectType) having changed in this new edition of Windows 10 to the value 34. in Creators Update it's 35.
I have been using the following code successfully to retrieve a list of files in use by a given process, but since the Windows 10 "anniversary update" it's no longer working.
Windows 10 version 1607 Build 14393.105
Any idea?
function GetFileNameHandle(hFile: THandle): String;
var lpExitCode: DWORD;
pThreadParam: TGetFileNameThreadParam;
hThread: THandle;
Ret: Cardinal;
begin
Result := '';
ZeroMemory(#pThreadParam, SizeOf(TGetFileNameThreadParam));
pThreadParam.hFile := hFile;
hThread := CreateThread(nil, 0, #GetFileNameHandleThr, #pThreadParam, 0, {PDWORD(nil)^} Ret);
if hThread <> 0 then
try
case WaitForSingleObject(hThread, 100) of
WAIT_OBJECT_0: begin
GetExitCodeThread(hThread, lpExitCode);
if lpExitCode = STATUS_SUCCESS then
Result := pThreadParam.FileName;
end;
WAIT_TIMEOUT: TerminateThread(hThread, 0);
end;
finally
CloseHandle(hThread);
end;
end;
procedure DeleteUpToFull(var src: String; UpTo: String);
begin
Delete(src,1,Pos(Upto,src)+Length(UpTo)-1);
end;
procedure ConvertDevicePath(var dvc: string);
var i: integer;
root: string;
device: string;
buffer: string;
//drvs: string;
begin
// much faster without using GetReadyDiskDrives
setlength(buffer, 1000);
for i := Ord('a') to Ord('z') do begin
root := Chr(i) + ':';
if (QueryDosDevice(PChar(root), pchar(buffer), 1000) <> 0) then begin
device := pchar(buffer);
if finds(device+'\',dvc) then begin
DeleteUpToFull(dvc,device+'\');
dvc := root[1] + ':\' + dvc;
Exit;
end;
end;
end;
end;
//get the pid of the process which had open the specified file
function GetHandlesByProcessID(const ProcessID: Integer; Results: TStringList; TranslatePaths: Boolean): Boolean;
var hProcess : THandle;
hFile : THandle;
ReturnLength: DWORD;
SystemInformationLength : DWORD;
Index : Integer;
pHandleInfo : PSYSTEM_HANDLE_INFORMATION;
hQuery : THandle;
FileName : string;
r: byte;
begin
Result := False;
Results.Clear;
pHandleInfo := nil;
ReturnLength := 1024;
pHandleInfo := AllocMem(ReturnLength);
hQuery := NTQuerySystemInformation(DWORD(SystemHandleInformation), pHandleInfo, 1024, #ReturnLength);
r := 0; // loop safe-guard
While (hQuery = $C0000004) and (r < 10) do begin
Inc(r);
FreeMem(pHandleInfo);
SystemInformationLength := ReturnLength;
pHandleInfo := AllocMem(ReturnLength+1024);
hQuery := NTQuerySystemInformation(DWORD(SystemHandleInformation), pHandleInfo, SystemInformationLength, #ReturnLength);//Get the list of handles
end;
// if hQuery = 0 then
// RaiseLastOSError;
try
if (hQuery = STATUS_SUCCESS) then begin
for Index := 0 to pHandleInfo^.uCount-1 do begin
// filter to requested process
if pHandleInfo.Handles[Index].uIdProcess <> ProcessID then Continue;
// http://www.codeproject.com/Articles/18975/Listing-Used-Files
// For an object of type file, the value bObjectType in SYSTEM_HANDLE is 28 in Windows XP, Windows 2000, and Window 7; 25 in Windows Vista; and 26 in Windows 2000.
// XP = 28
// W7 = 28
// W8 = 31
if (pHandleInfo.Handles[Index].ObjectType < 25) or
(pHandleInfo.Handles[Index].ObjectType > 31) then Continue;
hProcess := OpenProcess(PROCESS_DUP_HANDLE, FALSE, pHandleInfo.Handles[Index].uIdProcess);
if(hProcess <> INVALID_HANDLE_VALUE) then begin
try
if not DuplicateHandle(hProcess, pHandleInfo.Handles[Index].Handle,
GetCurrentProcess(), #hFile, 0 ,FALSE,
DUPLICATE_SAME_ACCESS) then
hFile := INVALID_HANDLE_VALUE;
finally
CloseHandle(hProcess);
end;
if (hFile <> INVALID_HANDLE_VALUE) then begin
try
FileName := GetFileNameHandle(hFile);
finally
CloseHandle(hFile);
end;
end
else
FileName := '';
if FileName <> '' then begin
if TranslatePaths then begin
ConvertDevicePath(FileName);
if not FileExists(Filename) then FileName := '\##\'+Filename; //Continue;
end;
Results.Add(FileName);
end;
end;
end;
end;
finally
if pHandleInfo <> nil then FreeMem(pHandleInfo);
end;
end;
The next code (in C++) works 100% correct on all Windows versions (Win 10 1607 as well). Also, I use SystemExtendedHandleInformation in place of SystemHandleInformation, and advise you to do so, too. It is present from XP onwards. However, the code with SystemHandleInformation also works correctly, I just checked it.
NTSTATUS GetHandlesByProcessID()
{
union {
PVOID buf;
PSYSTEM_HANDLE_INFORMATION_EX pshti;
};
NTSTATUS status;
ULONG ReturnLength = 1024;//not reasonable value for start query,but let be
ULONG UniqueProcessId = GetCurrentProcessId();
do
{
status = STATUS_INSUFFICIENT_RESOURCES;
if (buf = new BYTE[ReturnLength])
{
if (0 <= (status = ZwQuerySystemInformation(SystemExtendedHandleInformation, buf, ReturnLength, &ReturnLength)))
{
if (ULONG_PTR NumberOfHandles = pshti->NumberOfHandles)
{
SYSTEM_HANDLE_TABLE_ENTRY_INFO_EX* Handles = pshti->Handles;
do
{
if (Handles->UniqueProcessId == UniqueProcessId)
{
DbgPrint("%u, %p\n", Handles->ObjectTypeIndex, Handles->HandleValue);
}
} while (Handles++, --NumberOfHandles);
}
}
delete buf;
}
} while (status == STATUS_INFO_LENGTH_MISMATCH);
return status;
}
I think this is like a repeat until in a Delphi loop :)
r := 0; // loop safe-guard - this is not needed.
About the hard-coded ObjectTypeIndex - beginning in Win 8.1, you can exactly get this info from the OS. You need to call ZwQueryObject() with ObjectTypesInformation (in some sources, this is named ObjectAllTypeInformation, see ntifs.h) to get an array of OBJECT_TYPE_INFORMATION structs. Look for the TypeIndex member - it exactly cooresponds to the ObjectTypeIndex from SYSTEM_HANDLE_TABLE_ENTRY_INFO_EX. Before Win 8.1, there also exists ways to get this 'on the fly' by using ObjectAllTypeInformation but it is more complex.
I just tested the code from my blog article "Running multiple instances of Microsoft Lync" on Windows 10 Anniversary Update on it appears to work without any issues.
Here's the code that I tested (takes process name eg foobar.exe as parameter):
program ListHandles;
{$APPTYPE CONSOLE}
uses
JwaWinBase,
JwaWinNT,
JwaWinType,
JwaNtStatus,
JwaNative,
JwaWinsta,
SysUtils,
StrUtils;
{$IFDEF RELEASE}
// Leave out Relocation Table in Release version
{$SetPEFlags IMAGE_FILE_RELOCS_STRIPPED}
{$ENDIF RELEASE}
{$SetPEOptFlags IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE}
// No need for RTTI
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
var
dwPid: DWORD;
hProcess: THandle;
{$ALIGN 8}
{$MINENUMSIZE 4}
type
_SYSTEM_HANDLE = record
ProcessId: ULONG;
ObjectTypeNumber: Byte;
Flags: Byte;
Handle: USHORT;
_Object: PVOID;
GrantedAccess: ACCESS_MASK;
end;
SYSTEM_HANDLE = _SYSTEM_HANDLE;
PSYSTEM_HANDLE = ^SYSTEM_HANDLE;
_SYSTEM_HANDLE_INFORMATION = record
HandleCount: ULONG;
Handles: array[0..0] of SYSTEM_HANDLE;
end;
SYSTEM_HANDLE_INFORMATION = _SYSTEM_HANDLE_INFORMATION;
PSYSTEM_HANDLE_INFORMATION = ^SYSTEM_HANDLE_INFORMATION;
_OBJECT_NAME_INFORMATION = record
Length: USHORT;
MaximumLength: USHORT;
Pad: DWORD;
Name: array[0..MAX_PATH-1] of Char;
end;
OBJECT_NAME_INFORMATION = _OBJECT_NAME_INFORMATION;
POBJECT_NAME_INFORMATION = ^OBJECT_NAME_INFORMATION;
function GetObjectName(const hObject: THandle): String;
var
oni: OBJECT_NAME_INFORMATION;
cbSize: DWORD;
nts: NTSTATUS;
begin
Result := '';
cbSize := SizeOf(oni) - (2 * SizeOf(USHORT));
oni.Length := 0;
oni.MaximumLength := cbSize;
nts := NtQueryObject(hObject, ObjectNameInformation, #oni, cbSize, #cbSize);
if (nts = STATUS_SUCCESS) and (oni.Length > 0) then
begin
Result := oni.Name;
end;
end;
function GetCurrentSessionId: DWORD;
asm
mov eax,fs:[$00000018]; // Get TEB
mov eax,[eax+$30]; // PPEB
mov eax,[eax+$1d4]; // PEB.SessionId
end;
function GetProcessByName(const ProcessName: string): DWORD;
var
ProcName: PChar;
Count: Integer;
tsapi: PTS_ALL_PROCESSES_INFO_ARRAY;
i: Integer;
dwSessionId: DWORD;
begin
Result := 0;
tsapi := nil;
if not WinStationGetAllProcesses(SERVERNAME_CURRENT, 0, Count, tsapi) then
Exit;
ProcName := PChar(ProcessName);
dwSessionId := GetCurrentSessionId;
WriteLn(Format('Looking for Process %s in Session %d',
[ProcessName, dwSessionId]));
for i := 0 to Count - 1 do
begin
with tsapi^[i], tsapi^[i].pTsProcessInfo^ do
begin
if (dwSessionId = SessionId) and (ImageName.Buffer <> nil) and
(StrIComp(ProcName, ImageName.Buffer) = 0) then
begin
Result := UniqueProcessId;
WriteLn(Format('%s has Pid %d', [ProcessName, Result]));
Break
end;
end;
end;
if tsapi <> nil then
WinStationFreeGAPMemory(0, tsapi, Count);
end;
procedure EnumHandles;
var
shi: PSYSTEM_HANDLE_INFORMATION;
cbSize: DWORD;
cbRet: DWORD;
nts: NTSTATUS;
i: Integer;
hDupHandle: THandle;
dwErr: DWORD;
ObjectName: string;
begin
WriteLn('Enumerating Handles');
cbSize := $5000;
GetMem(shi, cbSize);
repeat
cbSize := cbSize * 2;
ReallocMem(shi, cbSize);
nts := NtQuerySystemInformation(SystemHandleInformation, shi, cbSize, #cbRet);
until nts <> STATUS_INFO_LENGTH_MISMATCH;
if nts = STATUS_SUCCESS then
begin
for i := 0 to shi^.HandleCount - 1 do
begin
if shi^.Handles[i].GrantedAccess <> $0012019f then
begin
if shi^.Handles[i].ProcessId = dwPid then
begin
nts := NtDuplicateObject(hProcess, shi^.Handles[i].Handle,
GetCurrentProcess, #hDupHandle, 0, 0, 0);
if nts = STATUS_SUCCESS then
begin
ObjectName := GetObjectName(hDupHandle);
if (ObjectName <> '') then
begin
WriteLn(Format('Handle=%d Name=%s', [shi^.Handles[i].Handle, ObjectName]));
CloseHandle(hDupHandle);
end;
end;
end;
end;
end;
end
else begin
dwErr := RtlNtStatusToDosError(nts);
WriteLn(Format('Failed to read handles, NtQuerySystemInformation failed with %.8x => %d (%s)', [nts, SysErrorMessage(dwErr)]));
end;
FreeMem(shi);
end;
procedure AnyKey;
begin
WriteLn('Finished');
WriteLn('Press any key to continue');
ReadLn;
end;
begin
try
dwPid := GetProcessByName(ParamStr(1));
if dwPid = 0 then
begin
WriteLn('Process was not found, exiting.');
Exit;
end;
WriteLn(Format('Opening Process %d with PROCESS_DUP_HANDLE', [dwPid]));
hProcess := OpenProcess(PROCESS_DUP_HANDLE, False, dwPid);
if hProcess = 0 then
begin
WriteLn(Format('OpenProcess failed with %s', [SysErrorMessage(GetLastError)]));
Exit;
end
else begin
WriteLn(Format('Process Handle is %d', [hProcess]));
end;
EnumHandles;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
I know the only way to do that is to remap keys with regedit.
Have someone has done that with delphi ? (disable it and enable it again)
http://www.northcode.com/blog.php/2007/07/25/Securing-Windows-For-Use-As-A-Kiosk
The information in the article would translate to Delphi as follows:
uses
Registry;
const
DisableScancodes: packed array[0..11] of DWORD = (
$00000000, // version = 0
$00000000, // flags = 0
$00000009, // # of mappings = 9
$E05B0000, // disable Windows key
$E05C0000, // disable Windows key
$E05D0000, // disable Windows menu key
$00440000, // disable F10 key
$001D0000, // disable Left Ctrl key
$00380000, // disable Left Alt key
$E01D0000, // disable Right Ctrl key
$E0380000, // disable Right Alt key
$00000000 // end of list
);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create(KEY_WRITE);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\SYSTEM\CurrentControlSet\Control\Keyboard Layout', True) then
begin
try
// to enable the mapping
Reg.WriteBinaryData('Scancode Map', DisableScancodes, SizeOf(DisableScancodes));
// to disable the mapping
Reg.DeleteValue('Scancode Map');
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
If you need to be more dynamic about which scancodes you enable/disable, you will have to use TRegistry.ReadBinaryData() to read the current Scancode Map value (if it exists), modify it as needed, and then save the changes using TRegistry.WriteBinaryData(). Try something like this:
unit ScanCodeMap;
interface
type
TMappedScancode = record
Scancode: WORD;
MappedTo: WORD;
end;
procedure AddScancodeMappings(const Values: array of TMappedScancode);
procedure AddScancodeMapping(const Value: TMappedScancode);
procedure AddScancodeMapping(Scancode, MappedTo: WORD);
procedure RemoveScancodeMappings(const Scancodes: array of WORD);
procedure RemoveScancodeMapping(Scancode: WORD);
procedure DisableScancodes(Scancodes: array of WORD);
procedure DisableScancode(Scancode: WORD);
implementation
uses
Windows, Registry;
type
PScancodeMapHdr = ^TScancodeMapHdr;
TScancodeMapHdr = packed record
Version: DWORD;
Flags: DWORD;
NumMappings: DWORD;
end;
TScancodeMap = record
Version: DWORD;
Flags: DWORD;
Mappings: array of TMappedScancode;
end;
procedure AddScancodesToMap(var Map: TScancodeMap; const Values: array of TMappedScancode);
var
I, J, Idx: Integer;
begin
for I := 0 to High(Values) do
begin
Idx := -1;
for J := 0 to High(Map.Mappings) do
begin
if Map.Mappings[J].Scancode = Values[I].Scancode then
begin
Idx := J;
Break;
end;
end;
if Idx = -1 then
begin
SetLength(Map.Mappings, Length(Map.Mappings)+1);
Idx := High(Map.Mappings);
end;
Map.Mappings[Idx].MappedTo := Values[I].MappedTo;
end;
end;
procedure RemoveScancodesFromMap(var Map: TScancodeMap; const Scancodes: array of WORD);
var
I, J: Integer;
begin
for I := 0 to High(Scancodes) do
begin
for J := 0 to High(Map.Mappings) do
begin
if Map.Mappings[J].Scancode = Scancodes[I] then
begin
if J < High(Map.Mappings) then
Move(Map.Mappings[J+1], Map.Mappings[J], (High(Mappings)-J) * SizeOf(TMappedScancode));
SetLength(Map.Mappings, Length(Map.Mappings)-1);
Break;
end;
end;
end;
end;
procedure WriteScanCodeMap(const Map: TScancodeMap);
var
Reg: TRegistry;
Data: array of Byte;
Tmp: PByte;
Hdr: PScancodeMapHdr;
I: Integer;
begin
if Length(Map.Mappings) > 0 then
begin
SetLength(Data, sizeof(TScancodeMapHdr) + (Length(Map.Mappings) + 1) * SizeOf(DWORD));
Tmp := PByte(Data);
Hdr := PScancodeMapHdr(Tmp);
Hdr.Version := Map.Version;
Hdr.Flags := Map.Flags;
Hdr.NumMappings := Length(Map.Mappings) + 1;
Inc(Tmp, SizeOf(TScancodeMapHdr));
for I := 0 to High(Map.Mappings) do
begin
PDWORD(Tmp)^ := (DWORD(Map.Mappings[0].Scancode) shr 16) or DWORD(Map.Mappings[0].MappedTo);
Inc(Tmp, SizeOf(DWORD));
end;
PDWORD(Tmp)^ := 0;
end;
Reg := TRegistry.Create(KEY_WRITE);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\SYSTEM\CurrentControlSet\Control\Keyboard Layout', True) then
begin
try
if Length(Data) > 0 then
Reg.WriteBinaryData('Scancode Map', Data[0], Length(Data))
else
Reg.DeleteValue('Scancode Map');
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
procedure ReadScanCodeMap(var Map: TScancodeMap);
var
Reg: TRegistry;
Size: Integer;
Data: array of Byte;
Tmp: PByte;
Hdr: PScancodeMapHdr;
I: Integer;
begin
Map.Version := 0;
Map.Flags := 0;
SetLength(Map.Mappings, 0);
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Control\Keyboard Layout') then
begin
try
Size := Reg.GetDataSize('Scancode Map');
if Size > SizeOf(TScancodeMapHdr) then
begin
SetLength(Data, Size);
Reg.ReadBinaryData('Scancode Map', Data[0], Size);
Tmp := PByte(Data);
Hdr := PScancodeMapHdr(Tmp);
Map.Version := Hdr.Version;
Map.Flags := Hdr.Flags;
Inc(Tmp, SizeOf(TScancodeMapHdr));
if Hdr.NumMappings > 1 then
begin
SetLength(Map.Mappings, Hdr.NumMappings-1);
for I := 0 to High(Map.Mappings) do
begin
Map.Mappings[I].Scancode := HIWORD(PDWORD(Tmp)^);
Map.Mappings[I].MappedTo := LOWORD(PDWORD(Tmp)^);
end;
end;
end;
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
procedure AddScancodeMappings(const Values: array of TMappedScancode);
var
Map: TScancodeMap;
begin
ReadScanCodeMap(Map);
AddScancodesToMap(Map, Values);
WriteScanCodeMap(Map);
end;
procedure AddScancodeMapping(const Value: TMappedScancode);
begin
AddScancodeMappings([Value]);
end;
procedure AddScancodeMapping(Scancode, MappedTo: WORD);
var
Value: array[0..0] of TMappedScancode;
begin
Value[0].Scancode := Scancode;
Value[0].MappedTo := MappedTo;
AddScancodeMappings([Value]);
end;
procedure RemoveScancodeMappings(const Scancodes: array of WORD);
var
Map: TScancodeMap;
begin
ReadScanCodeMap(Map);
RemoveScancodesFromMap(Map, Scancodes);
WriteScanCodeMap(Map);
end;
procedure RemoveScancodeMapping(Scancode: WORD);
begin
RemoveScancodeMappings([Scancode]);
end;
procedure DisableScancodes(Scancodes: array of WORD);
var
Values: array of TMappedScancode;
I: Integer;
begin
SetLength(Values, Length(Scancodes));
for I := 0 to High(Mappings) do
begin
Values[I].Scancode := Scancodes[I];
Values[I].MappedTo := $0000;
end;
AddScancodeMappings(Values);
end;
procedure DisableScancode(Scancode: WORD);
begin
AddScancodeMapping(Scancode, $0000);
end;
end.
Then you can do this:
uses
ScanCodeMap;
const
Scancodes: packed array[0..7] of WORD = (
$E05B, // Windows key
$E05C, // Windows key
$E05D, // Windows menu key
$0044, // F10 key
$001D, // Left Ctrl key
$0038, // Left Alt key
$E01D, // Right Ctrl key
$E038 // Right Alt key
);
procedure DisableCtrlAltDel;
begin
DisableScancodes(Scancodes);
end;
procedure EnableCtrlAltDel;
begin
RemoveScancodeMappings(Scancodes);
end;
Have AppActivate and SendKeys functions.
When use: AppActivate('*WordPad'); SendKeys('Test");
this works fine - application activated and text pasted
but then use it from WM_HOTKEY handler from the same program,
this is not worked.
Any ideas?
procedure wm_hotkeyhandler(var Msg: TWMHotkey); message WM_HOTKEY;
...
procedure TFormMain.wm_hotkeyhandler(var Msg: TWMHotkey);
var
Pt: TPoint;
begin
inherited;
if (Msg.HotKey = HotKeyId_L) then SendKeys('Test'); // not pasted to active app
if (Msg.HotKey = HotKeyId_M) then begin
// invoke context menu and paste text after click to menu item, works fine
GetCursorPos(Pt);
popPaste.Popup(Pt.x, Pt.y);
end;
end;
Update 1:
// this code works fine
procedure TFormTest.btnAppActivateClick(Sender: TObject);
var
sTitle, sKeys: string;
begin
sTitle := '*WordPad';
sKeys := 'Hello{ENTER}World!';
AppActivate(sTitle);
SendKeys(PChar(sKeys), False);
end;
menu item handler (which invoked by hotkey HotKeyId_M):
procedure TFormMain.mnPasteLoginClick(Sender: TObject);
begin
SendKeys('Hello{ENTER}World!', False);
end;
hotkeys:
HotKeyId_L: Integer;
HotKeyId_M: Integer;
initialization of hotkeys:
HotKeyId_L := GlobalAddAtom('HotKeyL');
RegisterHotKey(Handle, HotKeyId_L, MOD_CONTROL + MOD_ALT, Byte('L'));
HotKeyId_M := GlobalAddAtom('HotKeyM');
RegisterHotKey(Handle, HotKeyId_L, MOD_CONTROL + MOD_ALT, Byte('M'));
Update 2: (full code for test)
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus;
type
TForm2 = class(TForm)
btnActivate: TButton;
popPopup: TPopupMenu;
Paste1: TMenuItem;
procedure btnActivateClick(Sender: TObject);
procedure Paste1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
HotKeyId_L: Integer;
HotKeyId_M: Integer;
procedure wm_hotkeyhandler(var Msg: TWMHotkey); message WM_HOTKEY;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.DFM}
type
TCompareDirection = (cdHead, cdTail, cdNone);
TWindowObj = class(TObject)
private
targetTitle : PChar;
compareLength: Integer;
FCompareDirection: TCompareDirection;
FWindowHandle: THandle;
public
constructor Create;
destructor Destroy; override;
function Equal(ATitle: PChar): Boolean;
function SetTitle(const Title: string ): Boolean;
property WindowHandle: THandle read FWindowHandle write FWindowHandle;
end;
function EnumWindowsProc(hWnd: HWND; lParam: LPARAM):Bool; export; stdcall;
var
WinObj: TWindowObj;
aWndName: array[0..MAX_PATH] of Char;
begin
Result := True;
WinObj := TWindowObj(lParam);
GetWindowText(hWnd, aWndName, MAX_PATH);
if WinObj.Equal(aWndName) then begin
WinObj.WindowHandle := hWnd;
Result := False; // Stop Enumerate
end;
end;
function GetWindowHandleByTitle(const Title: string): THandle;
var
WinObj: TWindowObj;
begin
Result := 0;
WinObj := TWindowObj.Create;
try
if WinObj.SetTitle(Title) then begin
EnumWindows(#EnumWindowsProc, Integer(WinObj));
Result := WinObj.WindowHandle;
end;
finally
WinObj.Free;
end;
end;
function AppActivate(const Title: string ): Boolean;
var
hWnd: THandle;
begin
hWnd := GetWindowHandleByTitle(Title);
Result := (hWnd > 0);
if Result then begin
SendMessage(hWnd, WM_SYSCOMMAND, SC_HOTKEY, hWnd);
SendMessage(hWnd, WM_SYSCOMMAND, SC_RESTORE, hWnd);
SetForegroundWindow(hWnd);
end;
end;
constructor TWindowObj.Create;
begin
TargetTitle := nil;
FWindowHandle := 0;
end;
destructor TWindowObj.Destroy;
begin
inherited Destroy;
if Assigned(TargetTitle) then
StrDispose(TargetTitle) ;
end;
function TWindowObj.Equal(ATitle: PChar): Boolean;
var
p : Pchar;
stringLength : integer;
begin
Result := False;
if (TargetTitle = nil) then
Exit;
case FCompareDirection of
cdHead: begin
if StrLIComp(ATitle, TargetTitle, compareLength) = 0 then
Result := True;
end;
cdTail: begin
stringLength := StrLen(ATitle);
p := #ATitle[stringLength - compareLength];
if (StrLIComp(p, Targettitle, compareLength) = 0) then
Result := True;
end;
cdNone: begin
Result := True;
end;
end;
end;
function TWindowObj.SetTitle(const Title: string ): Boolean;
var
pTitle, p: PChar;
begin
Result := False;
pTitle := StrAlloc(Length(Title) + 1);
StrPCopy(pTitle, Title);
p := StrScan(pTitle, '*');
if Assigned(p) then begin
if StrLen(pTitle) = 1 then begin {full matching }
FCompareDirection := cdNone;
compareLength := 0;
TargetTitle := nil;
StrDispose(pTitle);
end
else
if (p = pTitle) then begin {tail matching }
Inc(p);
if StrScan(p, '*') <> nil then begin
{MessageDlg( 'Please 1 wild char ', mtError, [mbOK],0 ); }
StrDispose( pTitle);
TargetTitle := nil;
FCompareDirection := cdNone;
Comparelength := 0;
exit;
end;
FCompareDirection := cdTail;
CompareLength := StrLen(PTitle) - 1;
TargetTitle := StrAlloc(StrLen(p) + 1 );
StrCopy(targetTitle, p);
StrDispose(PTitle);
end
else begin
p^ := #0;
FCompareDirection := cdHead;
CompareLength := Strlen( pTitle );
Targettitle := pTitle;
end;
end
else begin
FCompareDirection := cdHead;
compareLength := Strlen( pTitle );
TargetTitle := pTitle;
end;
Result := True;
end;
//========================================
// SendKeys
//
// Converts a string of characters and key names to keyboard events and passes them to Windows.
//
// Example syntax:
// SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);
function SendKeys(SendStr: PChar; Wait: Boolean): Boolean;
type
WBytes = array[0..pred(SizeOf(Word))] of Byte;
TSendKey = record
Name : ShortString;
VKey : Byte;
end;
const
// Array of keys that SendKeys recognizes.
// If you add to this list, you must be sure to keep it sorted alphabetically
// by Name because a binary search routine is used to scan it.}
MaxSendKeyRecs = 41;
SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey = (
(Name:'BACKSPACE'; VKey:VK_BACK),
(Name:'BKSP'; VKey:VK_BACK),
(Name:'BREAK'; VKey:VK_CANCEL),
(Name:'BS'; VKey:VK_BACK),
(Name:'CAPSLOCK'; VKey:VK_CAPITAL),
(Name:'CLEAR'; VKey:VK_CLEAR),
(Name:'DEL'; VKey:VK_DELETE),
(Name:'DELETE'; VKey:VK_DELETE),
(Name:'DOWN'; VKey:VK_DOWN),
(Name:'END'; VKey:VK_END),
(Name:'ENTER'; VKey:VK_RETURN),
(Name:'ESC'; VKey:VK_ESCAPE),
(Name:'ESCAPE'; VKey:VK_ESCAPE),
(Name:'F1'; VKey:VK_F1),
(Name:'F10'; VKey:VK_F10),
(Name:'F11'; VKey:VK_F11),
(Name:'F12'; VKey:VK_F12),
(Name:'F13'; VKey:VK_F13),
(Name:'F14'; VKey:VK_F14),
(Name:'F15'; VKey:VK_F15),
(Name:'F16'; VKey:VK_F16),
(Name:'F2'; VKey:VK_F2),
(Name:'F3'; VKey:VK_F3),
(Name:'F4'; VKey:VK_F4),
(Name:'F5'; VKey:VK_F5),
(Name:'F6'; VKey:VK_F6),
(Name:'F7'; VKey:VK_F7),
(Name:'F8'; VKey:VK_F8),
(Name:'F9'; VKey:VK_F9),
(Name:'HELP'; VKey:VK_HELP),
(Name:'HOME'; VKey:VK_HOME),
(Name:'INS'; VKey:VK_INSERT),
(Name:'LEFT'; VKey:VK_LEFT),
(Name:'NUMLOCK'; VKey:VK_NUMLOCK),
(Name:'PGDN'; VKey:VK_NEXT),
(Name:'PGUP'; VKey:VK_PRIOR),
(Name:'PRTSC'; VKey:VK_PRINT),
(Name:'RIGHT'; VKey:VK_RIGHT),
(Name:'SCROLLLOCK'; VKey:VK_SCROLL),
(Name:'TAB'; VKey:VK_TAB),
(Name:'UP'; VKey:VK_UP)
);
{Extra VK constants missing from Delphi's Windows API interface}
VK_NULL=0;
VK_SemiColon=186;
VK_Equal=187;
VK_Comma=188;
VK_Minus=189;
VK_Period=190;
VK_Slash=191;
VK_BackQuote=192;
VK_LeftBracket=219;
VK_BackSlash=220;
VK_RightBracket=221;
VK_Quote=222;
VK_Last=VK_Quote;
ExtendedVKeys : set of byte =
[VK_Up,
VK_Down,
VK_Left,
VK_Right,
VK_Home,
VK_End,
VK_Prior, {PgUp}
VK_Next, {PgDn}
VK_Insert,
VK_Delete];
const
INVALIDKEY = $FFFF {Unsigned -1};
VKKEYSCANSHIFTON = $01;
VKKEYSCANCTRLON = $02;
VKKEYSCANALTON = $04;
UNITNAME = 'SendKeys';
var
UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
PosSpace : Byte;
I, L : Integer;
NumTimes, MKey : Word;
KeyString : String[20];
procedure DisplayMessage(Msg: PChar);
begin
MessageBox(0, Msg, UNITNAME, 0);
end;
function BitSet(BitTable, BitMask: Byte): Boolean;
begin
Result := ByteBool(BitTable and BitMask);
end;
procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
BitTable:=BitTable or Bitmask;
end;
procedure KeyboardEvent(VKey, ScanCode: Byte; Flags: DWORD);
var
KeyboardMsg : TMsg;
begin
keybd_event(VKey, ScanCode, Flags, 0);
if Wait then
while PeekMessage(KeyboardMsg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) do begin
TranslateMessage(KeyboardMsg);
DispatchMessage(KeyboardMsg);
end;
end;
procedure SendKeyDown(VKey: Byte; NumTimes: Word; GenUpMsg: Boolean);
var
Cnt: Word;
ScanCode: Byte;
NumState: Boolean;
KeyBoardState: TKeyboardState;
begin
if (VKey = VK_NUMLOCK) then begin
NumState := ByteBool(GetKeyState(VK_NUMLOCK) and 1);
GetKeyBoardState(KeyBoardState);
if NumState then
KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] and not 1)
else
KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] or 1);
SetKeyBoardState(KeyBoardState);
Exit;
end;
ScanCode := Lo(MapVirtualKey(VKey, 0));
for Cnt := 1 to NumTimes do
if (VKey in ExtendedVKeys) then begin
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
if GenUpMsg then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
end
else begin
KeyboardEvent(VKey, ScanCode, 0);
if GenUpMsg then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
end;
procedure SendKeyUp(VKey: Byte);
var
ScanCode : Byte;
begin
ScanCode := Lo(MapVirtualKey(VKey, 0));
if (VKey in ExtendedVKeys)then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
else
KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
procedure SendKey(MKey: Word; NumTimes: Word; GenDownMsg: Boolean);
begin
if BitSet(Hi(MKey), VKKEYSCANSHIFTON) then SendKeyDown(VK_SHIFT, 1, False);
if BitSet(Hi(MKey), VKKEYSCANCTRLON) then SendKeyDown(VK_CONTROL, 1, False);
if BitSet(Hi(MKey), VKKEYSCANALTON) then SendKeyDown(VK_MENU, 1, False);
SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
if BitSet(Hi(MKey), VKKEYSCANSHIFTON) then SendKeyUp(VK_SHIFT);
if BitSet(Hi(MKey), VKKEYSCANCTRLON) then SendKeyUp(VK_CONTROL);
if BitSet(Hi(MKey), VKKEYSCANALTON) then SendKeyUp(VK_MENU);
end;
// Implements a simple binary search to locate special key name strings
function StringToVKey(KeyString: ShortString): Word;
var
Found, Collided : Boolean;
Bottom, Top, Middle : Byte;
begin
Result := INVALIDKEY;
Bottom := 1;
Top := MaxSendKeyRecs;
Found := False;
Middle := (Bottom + Top) div 2;
repeat
Collided:=((Bottom=Middle) or (Top=Middle));
if (KeyString=SendKeyRecs[Middle].Name) then begin
Found:=True;
Result:=SendKeyRecs[Middle].VKey;
end
else begin
if (KeyString>SendKeyRecs[Middle].Name) then
Bottom:=Middle
else
Top:=Middle;
Middle:=(Succ(Bottom+Top)) div 2;
end;
until (Found or Collided);
if (Result = INVALIDKEY) then
DisplayMessage('Invalid Key Name');
end;
procedure PopUpShiftKeys;
begin
if (not UsingParens) then begin
if ShiftDown then SendKeyUp(VK_SHIFT);
if ControlDown then SendKeyUp(VK_CONTROL);
if AltDown then SendKeyUp(VK_MENU);
ShiftDown := False;
ControlDown := False;
AltDown := False;
end;
end;
var
AllocationSize : integer;
begin
AllocationSize := MaxInt;
Result := False;
UsingParens := False;
ShiftDown := False;
ControlDown := False;
AltDown := False;
I := 0;
L := StrLen(SendStr);
if (L > AllocationSize) then
L := AllocationSize;
if (L = 0) then
Exit;
while (I < L) do begin
case SendStr[I] of
'(': begin
UsingParens := True;
Inc(I);
end;
')': begin
UsingParens := False;
PopUpShiftKeys;
Inc(I);
end;
'%': begin
AltDown := True;
SendKeyDown(VK_MENU, 1, False);
Inc(I);
end;
'+': begin
ShiftDown := True;
SendKeyDown(VK_SHIFT, 1, False);
Inc(I);
end;
'^': begin
ControlDown := True;
SendKeyDown(VK_CONTROL, 1, False);
Inc(I);
end;
'{': begin
NumTimes := 1;
if (SendStr[Succ(I)] = '{') then begin
MKey := VK_LEFTBRACKET;
SetBit(WBytes(MKey)[1], VKKEYSCANSHIFTON);
SendKey(MKey, 1, True);
PopUpShiftKeys;
Inc(I, 3);
Continue;
end;
KeyString := '';
FoundClose := False;
while (I <= L) do begin
Inc(I);
if (SendStr[I] = '}') then begin
FoundClose := True;
Inc(I);
Break;
end;
KeyString := KeyString + Upcase(SendStr[I]);
end;
if Not FoundClose then begin
DisplayMessage('No Close');
Exit;
end;
if (SendStr[I] = '}') then begin
MKey := VK_RIGHTBRACKET;
SetBit(Wbytes(MKey)[1], VKKEYSCANSHIFTON);
SendKey(MKey, 1, True);
PopUpShiftKeys;
Inc(I);
Continue;
end;
PosSpace:=Pos(' ', KeyString);
if (PosSpace <> 0) then begin
NumTimes := StrToInt(Copy(KeyString, Succ(PosSpace), Length(KeyString) - PosSpace));
KeyString := Copy(KeyString, 1, Pred(PosSpace));
end;
If (Length(KeyString)=1) then
MKey := vkKeyScan(KeyString[1])
else
MKey := StringToVKey(KeyString);
If (MKey <> INVALIDKEY) then begin
SendKey(MKey, NumTimes, True);
PopUpShiftKeys;
Continue;
end;
end;
'~': begin
SendKeyDown(VK_RETURN, 1, True);
PopUpShiftKeys;
Inc(I);
end;
else
MKey := vkKeyScan(SendStr[I]);
if (MKey <> INVALIDKEY) then begin
SendKey(MKey, 1, True);
PopUpShiftKeys;
end
else
DisplayMessage('Invalid KeyName');
Inc(I);
end;
end;
Result := True;
PopUpShiftKeys;
end;
procedure TForm2.btnActivateClick(Sender: TObject);
var
sTitle, sKeys: string;
begin
sTitle := '*WordPad';
sKeys := 'Hello{ENTER}World!';
AppActivate(sTitle);
SendKeys(PChar(sKeys), False);
end;
procedure TForm2.Paste1Click(Sender: TObject);
begin
SendKeys('Hello{ENTER}World!', False);
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
HotKeyId_L := GlobalAddAtom('HotKeyP');
RegisterHotKey(Handle, HotKeyId_L, MOD_CONTROL or MOD_ALT, Byte('L'));
HotKeyId_M := GlobalAddAtom('HotKeyM');
RegisterHotKey(Handle, HotKeyId_M, MOD_CONTROL or MOD_ALT, Byte('M'));
end;
procedure TForm2.FormDestroy(Sender: TObject);
begin
UnregisterHotKey(Handle, HotKeyId_L);
GlobalDeleteAtom(HotKeyId_L);
end;
procedure TForm2.wm_hotkeyhandler(var Msg: TWMHotkey);
var
Pt: TPoint;
begin
inherited;
if (Msg.HotKey = HotKeyId_L) then SendKeys('Hello{ENTER}World!', False);
if (Msg.HotKey = HotKeyId_M) then begin
GetCursorPos(Pt);
popPopup.Popup(Pt.x, Pt.y);
end;
end;
end.
I would like to perform a thorough LAN devices discovery, so that I can create a diagram similar to the one attached, but with additional information like IP and MAC addresses.
I've tried the code from Torry:
type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..100] of TNetResource;
function CreateNetResourceList(ResourceType: DWord;
NetResource: PNetResource;
out Entries: DWord;
out List: PNetResourceArray): Boolean;
var
EnumHandle: THandle;
BufSize: DWord;
Res: DWord;
begin
Result := False;
List := Nil;
Entries := 0;
if WNetOpenEnum(RESOURCE_GLOBALNET,
ResourceType,
0,
NetResource,
EnumHandle) = NO_ERROR then begin
try
BufSize := $4000; // 16 kByte
GetMem(List, BufSize);
try
repeat
Entries := DWord(-1);
FillChar(List^, BufSize, 0);
Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
if Res = ERROR_MORE_DATA then
begin
ReAllocMem(List, BufSize);
end;
until Res <> ERROR_MORE_DATA;
Result := Res = NO_ERROR;
if not Result then
begin
FreeMem(List);
List := Nil;
Entries := 0;
end;
except
FreeMem(List);
raise;
end;
finally
WNetCloseEnum(EnumHandle);
end;
end;
end;
procedure ScanNetworkResources(ResourceType, DisplayType: DWord; List: TStrings);
procedure ScanLevel(NetResource: PNetResource);
var
Entries: DWord;
NetResourceList: PNetResourceArray;
i: Integer;
begin
if CreateNetResourceList(ResourceType, NetResource, Entries, NetResourceList) then try
for i := 0 to Integer(Entries) - 1 do
begin
if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
(NetResourceList[i].dwDisplayType = DisplayType) then begin
List.AddObject(NetResourceList[i].lpRemoteName,
Pointer(NetResourceList[i].dwDisplayType));
end;
if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER) <> 0 then
ScanLevel(#NetResourceList[i]);
end;
finally
FreeMem(NetResourceList);
end;
end;
begin
ScanLevel(Nil);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ScanNetworkResources(RESOURCETYPE_DISK, RESOURCEDISPLAYTYPE_SERVER, ListBox1.Items);
end;
But it only returns the names of the computers in the network, without the router and their IP address. So that's not really a solution.
Could you please tell me what is a good way to enumerate all devices (routers, computers, printers) in a local network, along with their IP and MAC addresses?
Thank you.
I modified you code adding the function GetHostName and inet_ntoa to get the ip address and the SendARP function to get the MAC address of a network resource.
{$APPTYPE CONSOLE}
{$R *.res}
uses
StrUtils,
Windows,
WinSock,
SysUtils;
type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..1023] of TNetResource;
function SendArp(DestIP,SrcIP:ULONG;pMacAddr:pointer;PhyAddrLen:pointer) : DWord; StdCall; external 'iphlpapi.dll' name 'SendARP';
function GetIPAddress(const HostName: AnsiString): AnsiString;
var
HostEnt: PHostEnt;
Host: AnsiString;
SockAddr: TSockAddrIn;
begin
Result := '';
Host := HostName;
if Host = '' then
begin
SetLength(Host, MAX_PATH);
GetHostName(PAnsiChar(Host), MAX_PATH);
end;
HostEnt := GetHostByName(PAnsiChar(Host));
if HostEnt <> nil then
begin
SockAddr.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
Result := inet_ntoa(SockAddr.sin_addr);
end;
end;
function GetMacAddr(const IPAddress: AnsiString; var ErrCode : DWORD): AnsiString;
var
MacAddr : Array[0..5] of Byte;
DestIP : ULONG;
PhyAddrLen : ULONG;
begin
Result :='';
ZeroMemory(#MacAddr,SizeOf(MacAddr));
DestIP :=inet_addr(PAnsiChar(IPAddress));
PhyAddrLen:=SizeOf(MacAddr);
ErrCode :=SendArp(DestIP,0,#MacAddr,#PhyAddrLen);
if ErrCode = S_OK then
Result:=AnsiString(Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x',[MacAddr[0], MacAddr[1],MacAddr[2], MacAddr[3], MacAddr[4], MacAddr[5]]));
end;
function ParseRemoteName(Const lpRemoteName : string) : string;
begin
Result:=lpRemoteName;
if StartsStr('\\', lpRemoteName) and (Length(lpRemoteName)>2) and (LastDelimiter('\', lpRemoteName)>2) then
Result:=Copy(lpRemoteName, 3, PosEx('\', lpRemoteName,3)-3)
else
if StartsStr('\\', lpRemoteName) and (Length(lpRemoteName)>2) and (LastDelimiter('\', lpRemoteName)=2) then
Result:=Copy(lpRemoteName, 3, length(lpRemoteName));
end;
function CreateNetResourceList(ResourceType: DWord;
NetResource: PNetResource;
out Entries: DWord;
out List: PNetResourceArray): Boolean;
var
EnumHandle: THandle;
BufSize: DWord;
Res: DWord;
begin
Result := False;
List := Nil;
Entries := 0;
if WNetOpenEnum(RESOURCE_GLOBALNET, ResourceType, 0, NetResource, EnumHandle) = NO_ERROR then
begin
try
BufSize := $4000; // 16 kByte
GetMem(List, BufSize);
try
repeat
Entries := DWord(-1);
FillChar(List^, BufSize, 0);
Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
if Res = ERROR_MORE_DATA then
begin
ReAllocMem(List, BufSize);
end;
until Res <> ERROR_MORE_DATA;
Result := Res = NO_ERROR;
if not Result then
begin
FreeMem(List);
List := Nil;
Entries := 0;
end;
except
FreeMem(List);
raise;
end;
finally
WNetCloseEnum(EnumHandle);
end;
end;
end;
procedure ScanNetworkResources(ResourceType, DisplayType: DWord);
procedure ScanLevel(NetResource: PNetResource);
var
Entries: DWord;
NetResourceList: PNetResourceArray;
i: Integer;
IPAddress, MacAddress : AnsiString;
ErrCode : DWORD;
begin
if CreateNetResourceList(ResourceType, NetResource, Entries, NetResourceList) then try
for i := 0 to Integer(Entries) - 1 do
begin
if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
(NetResourceList[i].dwDisplayType = DisplayType) then
begin
IPAddress :=GetIPAddress(ParseRemoteName(AnsiString(NetResourceList[i].lpRemoteName)));
MacAddress :=GetMacAddr(IPAddress, ErrCode);
Writeln(Format('Remote Name %s Ip %s MAC %s',[NetResourceList[i].lpRemoteName, IPAddress, MacAddress]));
end;
if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER) <> 0 then
ScanLevel(#NetResourceList[i]);
end;
finally
FreeMem(NetResourceList);
end;
end;
begin
ScanLevel(Nil);
end;
var
WSAData: TWSAData;
begin
try
if WSAStartup($0101, WSAData)=0 then
try
ScanNetworkResources(RESOURCETYPE_ANY, RESOURCEDISPLAYTYPE_SERVER);
Writeln('Done');
finally
WSACleanup;
end;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
Readln;
end.
I'm having problem locating tray icon (in px) on traybar.
I can locate tray but not icon as well. This is the code I'm using:
unit uTrayIconPosition;
interface
uses
Types;
function GetTrayIconPosition(const AWnd: THandle; const AButtonID: Integer; var APosition: TRect): Boolean;
implementation
uses
Windows, CommCtrl, Classes, SysUtils;
function EnumWindowsFunc(AHandle: THandle; AList: TStringList): Boolean; stdcall;
var
P: array [0..256] of Char;
S: string;
begin
if GetClassName(AHandle, P, SizeOf(P) - 1) <> 0 then
begin
S := P;
if S = AList[0] then
begin
AList[0] := IntToStr(AHandle);
Result := False;
end
else
Result := True;
end
else
Result := True;
end;
function FindClass(AName: string; AHandle: THandle; var AChild: THandle): Boolean;
var
List: TStringList;
begin
Result := False;
try
List := TStringList.Create;
try
List.Add(AName);
EnumChildWindows(AHandle, #EnumWindowsFunc, LParam(List));
if List.Count > 0 then
begin
AChild := StrToInt(List[0]);
Result := True;
end;
finally
List.Free;
end;
except
end;
end;
// --- Handle of notify Wnd
function GetTrayNotifyWnd: THandle;
var
ShellTray: THandle;
TrayNotify: THandle;
ToolBar: THandle;
begin
Result := 0;
ShellTray := FindWindow('Shell_TrayWnd', nil);
if ShellTray <> 0 then
if FindClass('TrayNotifyWnd', ShellTray, TrayNotify) then
if IsWindow(TrayNotify) then
if FindClass('ToolbarWindow32', TrayNotify, ToolBar) then
Result := ToolBar;
end;
// --- Finding Tray rect
function GetTrayWndRect: TRect;
var
R: TRect;
Handle: THandle;
Width: Integer;
Height: Integer;
begin
Handle := GetTrayNotifyWnd;
if Handle > 0 then
begin
GetWindowRect(Handle, R);
Result := R;
end
else
begin
Width := GetSystemMetrics(SM_CXSCREEN);
Height := GetSystemMetrics(SM_CYSCREEN);
Result := Rect(Width - 40, Height - 20, Width, Height);
end;
end;
// --- Main function that should locate tray icon
function GetTrayIconPosition(const AWnd: THandle; const AButtonID: Integer; var APosition: TRect): Boolean;
var
hWndTray: HWND;
dwTrayProcessID: DWORD;
hTrayProc: THandle;
iButtonsCount: Integer;
lpData: Pointer;
bIconFound: Boolean;
iButton: Integer;
dwBytesRead: DWORD;
ButtonData: TTBBUTTON;
dwExtraData: array [0..1] of DWORD;
hWndOfIconOwner: THandle;
iIconId: Integer;
// rcPosition: TPoint;
rcPosition: TRect;
begin
Result := False;
hWndTray := GetTrayNotifyWnd;
if hWndTray = 0 then
Exit;
dwTrayProcessID := 0;
GetWindowThreadProcessId(hWndTray, dwTrayProcessID);
if dwTrayProcessID <= 0 then
Exit;
hTrayProc := OpenProcess(PROCESS_ALL_ACCESS, False, dwTrayProcessID);
if hTrayProc = 0 then
Exit;
iButtonsCount := SendMessage(hWndTray, TB_BUTTONCOUNT, 0, 0);
lpData := VirtualAllocEx(hTrayProc, nil, SizeOf(TTBBUTTON), MEM_COMMIT, PAGE_READWRITE);
if (lpData = nil) or (iButtonsCount < 1) then
begin
CloseHandle(hTrayProc);
Exit;
end;
bIconFound := False;
for iButton :=0 to iButtonsCount - 1 do
begin
dwBytesRead := 0;
SendMessage(hWndTray, TB_GETBUTTON, iButton, LPARAM(lpData));
ReadProcessMemory(hTrayProc, lpData, #ButtonData, SizeOf(TTBBUTTON), dwBytesRead);
if dwBytesRead < SizeOf(TTBBUTTON) then
Break;
dwExtraData[0] := 0;
dwExtraData[1] := 0;
ReadProcessMemory(hTrayProc, Pointer(ButtonData.dwData), #dwExtraData, SizeOf(dwExtraData), dwBytesRead);
if dwBytesRead < SizeOf(dwExtraData) then
Break;
hWndOfIconOwner := THandle(dwExtraData[0]);
iIconId := Integer(dwExtraData[1]);
if hWndOfIconOwner = AWnd then
if iIconId = AButtonID then
begin
if (ButtonData.fsState or TBSTATE_HIDDEN) = 1 then
Break;
SendMessage(hWndTray, TB_GETITEMRECT, iButton, LPARAM(lpData));
ReadProcessMemory(hTrayProc, lpData, #rcPosition, SizeOf(TREct), dwBytesRead);
if dwBytesRead < SizeOf(TRect) then
Break;
MapWindowPoints(hWndTray, 0, rcPosition, 2);
APosition := rcPosition;
bIconFound := True;
Break;
end;
end;
if not bIconFound then
APosition := GetTrayWndRect;
VirtualFreeEx(hTrayProc, lpData, 0, MEM_RELEASE);
CloseHandle(hTrayProc);
Result := True;
end;
end.
Algo detect # of Tray icons, but doesn't map each of them.
This is added:
Cause this solution works only under XP and 32bit systems I've tried following:
{$EXTERNALSYM Shell_NotifyIconGetRect}
function Shell_NotifyIconGetRect(const _in: NOTIFYICONIDENTIFIER; var _out: TRECT): HRESULT; stdcall;
implementation
function Shell_NotifyIconGetRect; external 'Shell32.dll' name 'Shell_NotifyIconGetRect';
Delphi 2007 doesn't have this function mapped and also this structure:
type
NOTIFYICONIDENTIFIER = record
cbSize : DWORD;
hWnd : HWND;
uID : UINT;
guidItem: TGUID;
end;
PNOTIFYICONIDENTIFIER = ^NOTIFYICONIDENTIFIER;
After I've created my tray icon with Shell_NotifyIcon I've tried to pass that _NOTIFYICONDATA structure hWND to this new NOTIFYICONIDENTIFIER structure >
var
R: TRect;
S: NOTIFYICONIDENTIFIER;
FillChar(S, SizeOf(S), #0);
S.cbSize := SizeOf(NOTIFYICONIDENTIFIER);
S.hWnd := ATrayIcon.Data.Wnd;
S.uID := ATrayIcon.Data.uID;
Result := Shell_NotifyIconGetRect(S, R) = S_OK;
This is working correctly and I receive in Rect structure upper left corner of my Tray Icon.
On Windows 7 and upwards you should use the API function that MS introduced for this very purpose: Shell_NotifyIconGetRect.
Your current code is failing for one or more of the following reasons:
You are trying to read 32 bit versions of the structures from a 64 bit process. In this case TTBBUTTON has a different layout and size under 64 bits and the process you are attacking is 64 bit explorer.
The implementation (details of which you are relying on) of the notification area has changed between XP and 7. I do not know whether or not this is true, but it could be!