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.
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;
I want to do someting like that:
var
ip,ip2: string;
begin
ip:= '127.0.0.1';
ip2:= ip+1;
end;
after this code executed ip2 should be 127.0.0.2
Question is: How can I increase an IP address like that?
Using the api, as an alternative:
uses
winsock;
procedure TForm1.Button1Click(Sender: TObject);
var
addr: in_addr;
begin
addr.S_addr := htonl(ntohl(inet_addr('127.0.0.1')) + 1);
ShowMessage(inet_ntoa(addr));
end;
You might try the following:
type
TIPAddress = array[0..3] of Byte;
function IncIPAddress(const IPAddress: TIPAddress;
Value: Integer = 1): TIPAddress;
begin
PInteger(#Result)^ := PInteger(#IPAddress)^ + Value;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
S: string;
IPAddress: TIPAddress;
IPAddress2: TIPAddress;
begin
IPAddress[3] := 127;
IPAddress[2] := 0;
IPAddress[1] := 0;
IPAddress[0] := 1;
S := Format('%d.%d.%d.%d', [IPAddress[3], IPAddress[2],
IPAddress[1], IPAddress[0]]);
ShowMessage(S);
IPAddress2 := IncIPAddress(IPAddress);
S := Format('%d.%d.%d.%d', [IPAddress2[3], IPAddress2[2],
IPAddress2[1], IPAddress2[0]]);
ShowMessage(S);
end;
I would like to know how I can find out which ports a program / process uses. I want to know the used ports from one process and write then in a label.
Is there a unit or function that is available?
You can use the GetExtendedTcpTable function passing the TCP_TABLE_OWNER_PID_ALL TableClass value , this will return a MIB_TCPTABLE_OWNER_PID structure which is an array to the MIB_TCPROW_OWNER_PID record , this structure contains the port number (dwLocalPort) and the PID (dwOwningPid) of the process, you can resolve the name of the PID using the CreateToolhelp32Snapshot function.
Sample
{$APPTYPE CONSOLE}
uses
WinSock,
TlHelp32,
Classes,
Windows,
SysUtils;
const
ANY_SIZE = 1;
iphlpapi = 'iphlpapi.dll';
TCP_TABLE_OWNER_PID_ALL = 5;
type
TCP_TABLE_CLASS = Integer;
PMibTcpRowOwnerPid = ^TMibTcpRowOwnerPid;
TMibTcpRowOwnerPid = packed record
dwState : DWORD;
dwLocalAddr : DWORD;
dwLocalPort : DWORD;
dwRemoteAddr: DWORD;
dwRemotePort: DWORD;
dwOwningPid : DWORD;
end;
PMIB_TCPTABLE_OWNER_PID = ^MIB_TCPTABLE_OWNER_PID;
MIB_TCPTABLE_OWNER_PID = packed record
dwNumEntries: DWORD;
table: Array [0..ANY_SIZE - 1] of TMibTcpRowOwnerPid;
end;
var
GetExtendedTcpTable:function (pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWord; stdcall;
function GetPIDName(hSnapShot: THandle; PID: DWORD): string;
var
ProcInfo: TProcessEntry32;
begin
ProcInfo.dwSize := SizeOf(ProcInfo);
if not Process32First(hSnapShot, ProcInfo) then
Result := 'Unknow'
else
repeat
if ProcInfo.th32ProcessID = PID then
Result := ProcInfo.szExeFile;
until not Process32Next(hSnapShot, ProcInfo);
end;
procedure ShowTCPPortsUsed(const AppName : string);
var
Error : DWORD;
TableSize : DWORD;
i : integer;
pTcpTable : PMIB_TCPTABLE_OWNER_PID;
SnapShot : THandle;
LAppName : string;
LPorts : TStrings;
begin
LPorts:=TStringList.Create;
try
TableSize := 0;
//Get the size o the tcp table
Error := GetExtendedTcpTable(nil, #TableSize, False, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0);
if Error <> ERROR_INSUFFICIENT_BUFFER then exit;
GetMem(pTcpTable, TableSize);
try
SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
try
//get the tcp table data
if GetExtendedTcpTable(pTcpTable, #TableSize, TRUE, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0) = NO_ERROR then
for i := 0 to pTcpTable.dwNumEntries - 1 do
begin
LAppName:=GetPIDName(SnapShot, pTcpTable.Table[i].dwOwningPid);
if SameText(LAppName, AppName) and (LPorts.IndexOf(IntToStr(pTcpTable.Table[i].dwLocalPort))=-1) then
LPorts.Add(IntToStr(pTcpTable.Table[i].dwLocalPort));
end;
finally
CloseHandle(SnapShot);
end;
finally
FreeMem(pTcpTable);
end;
Writeln(LPorts.Text);
finally
LPorts.Free;
end;
end;
var
hModule : THandle;
begin
try
hModule := LoadLibrary(iphlpapi);
try
GetExtendedTcpTable := GetProcAddress(hModule, 'GetExtendedTcpTable');
ShowTCPPortsUsed('Skype.exe');
finally
FreeLibrary(hModule);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
In order to get the correct Port number you have to use ntohs()
if SameText(LAppName, AppName) and
(LPorts.IndexOf(IntToStr(pTcpTable.Table[i].dwLocalPort))=-1) then
LPorts.Add(IntToStr(ntohs(pTcpTable.Table[i].dwLocalPort)));
more info here
I have this code that gets called from an injected DLL from a foreign process. It sould read some memory ranges but I sometimes get a segmentation fault at this line DataBuffer := TCharPointer(Address + CharOffset)^;. So is there any way to check if the memory is readable?
function GetCurrentData(Address: Pointer): PChar;
var
DataBuffer: Char;
CharArray: Array of Char;
CharOffset: Integer;
ReadBytes: longword;
begin
CharOffset := 0;
SetLength(CharArray, 0);
repeat
DataBuffer := TCharPointer(Address + CharOffset)^;
CharOffset := CharOffset + 1;
SetLength(CharArray, CharOffset);
CharArray[CharOffset - 1] := DataBuffer;
until (Ord(DataBuffer) = 0);
Result := PChar(#CharArray[0]);
end;
i also tryed to catch the exception but for some reason this is not working. The host programm still crashes.
unit UnitEventBridgeExports;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Windows, ShellAPI, JwaTlHelp32, SimpleIPC;
type
TCharPointer = ^Char;
const
WOWEXE = 'TestProgramm.exe';
var
IPCClient: TSimpleIPCClient;
PID: DWord;
Process: THandle;
procedure EventCalled;
procedure InitializeWoWEventBridge; stdcall;
implementation
function GetProcessIDByName(Exename: String): DWord;
var
hProcSnap: THandle;
pe32: TProcessEntry32;
begin
Result := 0;
hProcSnap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
if hProcSnap <> INVALID_HANDLE_VALUE then
begin
pe32.dwSize := SizeOf(ProcessEntry32);
if Process32First(hProcSnap, pe32) = True then
begin
while Process32Next(hProcSnap, pe32) = True do
begin
if pos(Exename, pe32.szExeFile) <> 0 then
Result := pe32.th32ProcessID;
end;
end;
CloseHandle(hProcSnap);
end;
end;
procedure InitializeEventBridge; stdcall;
begin
IPCClient := TSimpleIPCClient.Create(nil);
IPCClient.ServerID := 'EventBridgeServer';
IPCClient.Active := True;
IPCClient.SendStringMessage('init');
PID := GetProcessIDByName(EXE);
Process := OpenProcess(PROCESS_ALL_ACCESS, False, PID);
end;
function GetCurrentData(Address: Pointer): PChar;
var
DataBuffer: Char;
CharArray: Array of Char;
CharOffset: Integer;
ReadBytes: longword;
CharPointer: TCharPointer;
BreakLoop: Boolean;
begin
CharOffset := 0;
SetLength(CharArray, 0);
BreakLoop := False;
repeat
try
CharPointer := TCharPointer(Address + CharOffset);
DataBuffer := CharPointer^;
CharOffset := CharOffset + 1;
SetLength(CharArray, CharOffset);
CharArray[CharOffset - 1] := DataBuffer;
except
BreakLoop := True;
end;
until (Ord(DataBuffer) = 0) or BreakLoop;
Result := PChar(#CharArray[0]);
end;
procedure EventCalled;
var
TmpAddress: Pointer;
StringData: PChar;
begin
{$ASMMODE intel}
asm
mov [TmpAddress], edi
end;
StringData := GetCurrentData(TmpAddress);
IPCClient.SendStringMessage('update:' + StringData);
//IPCClient.SendStringMessage('update');
end;
end.
Your GetCurrentData() implementation is returning a pointer to a local array that goees out of scope when the function exits, then EventCalled() tries to use that poiner after it is no longer valid. Try this instead:
function GetCurrentData(Address: Pointer): AnsiString;
var
Offset: Integer;
begin
Result := '';
Offset := 0;
repeat
try
if PByte(Longint(Address) + Offset)^ = #0 then Break;
Inc(Offset);
except
Break;
end;
until False;
SetString(Result, PAnsiChar(Address), Offset);
end;
procedure EventCalled;
var
TmpAddress: Pointer;
StringData: AnsiString;
begin
{$ASMMODE intel}
asm
mov [TmpAddress], edi
end;
StringData := GetCurrentData(TmpAddress);
IPCClient.SendStringMessage('update:' + StringData);
//IPCClient.SendStringMessage('update');
end;
IsBadReadPtr API is here to help. You give address and size, and you get the readability back. Raymond Chen suggests to never use it though.
Other than that, VirtualQuery should give you information about the address in question to tell its readability.
Since Ken in comments below re-warned about danger of IsBadReadPtr, I bring it up to the answer to not pass by. Be sure to read the comments and links to Raymdond's blog. Be sure to see also:
Most efficient replacement for IsBadReadPtr?
How to check if a pointer is valid?