Getting Manufacturer, Serial Number, Model from Drive Letter - delphi

I'm trying to have some effective code to get vendor, serial number, and model of a USB drive, using its drive letter. I've searched a lot and found several solutions. But I can not determine which one is the best one.
First one is here. Uses hid.pas from JEDI, but I don't know how to use it with a single drive. Specially, function GetHidDeviceInfo is very interesting but requires symbolic link rather that a drive letter. I tried to invite a symbolic link for the drive letter at no avail.
Second one is here. Uses WMI which doesn't seem very clean. My experience tells me that WMI doesn't work on all PCs. The code doesn't work on my own laptop, saying 'The RPC server is unavailable'.
Please advice me on the best way to achieve my goal. Are other ways around?
Update: I'm posting some sample code, combining the results of comments below.
{$APPTYPE CONSOLE}
uses
Windows, Messages, SysUtils, Variants;
type
PHIDDAttributes = ^THIDDAttributes;
HIDD_ATTRIBUTES = record
Size: ULONG; // size of structure (set before call)
VendorID: Word;
ProductID: Word;
VersionNumber: Word;
//
// Additional fields will be added to the end of this structure.
//
end;
THIDDAttributes = HIDD_ATTRIBUTES;
THIDUSBDeviceInfo = Record { contains interface level information of each device}
SymLink : String;
BufferSize : Word;
Handle : THandle;
VID : DWord;
PID : DWord;
VersionNumber : Word;
ManufacturerString : String;
ProductString : String;
SerialNumberString : String;
end;
function GetVolumeNameForVolumeMountPointW(const lpszVolumeMountPoint: LPCWSTR;
lpszVolumeName: LPWSTR; cchBufferLength: DWORD): BOOL; stdcall;
external kernel32;
function HidD_GetAttributes(HidDeviceObject: THandle;
var HidAttrs: THIDDAttributes): LongBool; stdcall;external 'hid.dll' name 'HidD_GetAttributes';
function HidD_GetManufacturerString(HidDeviceObject: THandle;
Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;external 'hid.dll' name 'HidD_GetManufacturerString';
function HidD_GetProductString(HidDeviceObject: THandle;
Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;external 'hid.dll' name 'HidD_GetProductString';
function HidD_GetSerialNumberString(HidDeviceObject: THandle;
Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;external 'hid.dll' name 'HidD_GetSerialNumberString';
function GetVolumeName(Name: string): string;
var
Volume: array [0..MAX_PATH] of Char;
begin
FillChar(Volume[0], SizeOf(Volume), 0);
GetVolumeNameForVolumeMountPointW(PChar(Name), #Volume[0], SizeOf(Volume));
Result := Volume;
end;
Function GetHidDeviceInfo( Symlink : PChar) : THIDUSBDeviceInfo;
Var
pstr : pWideChar;
DevHandle : THandle;
HidAttrs : THIDDAttributes;
Begin
FillChar(Result, SizeOf( Result), 0);
Result.SymLink := SymLink+ #0;
GetMem( pstr, 512);
DevHandle := CreateFile( Symlink,
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil,
OPEN_EXISTING,
0,
0);
If DevHandle <> INVALID_HANDLE_VALUE then
begin
If HidD_GetAttributes( DevHandle,HidAttrs) then
begin
result.VID := HidAttrs.VendorID;
result.PID := HidAttrs.ProductID;
result.VersionNumber := HidAttrs.VersionNumber;
end;
If HidD_GetManufacturerString( DevHandle, pstr, 512) then
Result.ManufacturerString := pStr;
If HidD_GetProductString( DevHandle, pstr, 512) then
Result.ProductString := pStr;
If HidD_GetSerialNumberString( DevHandle, pstr, 512) then
Result.SerialNumberString := pStr;
closeHandle( DevHandle);
end;
FreeMem( pStr);
End;
procedure Main;
var
VolumeName: string;
info: THIDUSBDeviceInfo;
begin
VolumeName:=GetVolumeName('i:\'); //assuming that I: is a USB drive
info:=GetHidDeviceInfo(pchar(VolumeName));
Writeln(info.SerialNumberString);
end;
begin
Main;
Readln;
end.

You can try to obtain SerialNumber of disk (and more information) using WMI.
Usin WMI and the Win32_DiskDrive class, you can get the Serial Number. The documentation say: "Windows Server 2003 and Windows XP: This property is not available."
In Windows Vista,7/8 works fine.
To try if this method is good for you, try this simple demo on clubdelphi ftp(source included and binary included). In Windows 7 you get information like this:
If you can obtain a correct serial, you can use WMI.
Good library for work with WMI is GLibWMI on Sourceforge. Include a specific component (DiskDriveInfo) that you can use with 0 code lines.
See demo.
Regards

Related

How to pass a pointer to a list of handles to the UpdateProcThreadAttribute function

I have an application that spawns multiple CreateProcess threads and I'm successfully redirecting the stdout and stderr output to text files for each one.
However, I've discovered the feature whereby the stdout/strderr handles are inherited by all such threads and not just the ones I want them to be inherited by. So I've embarked on a journey to use the InitializeProcThreadAttributeList, UpdateProcThreadAttribute functions and EXTENDED_STARTUPINFO_PRESENT and a STARTUPINFOEX structure in the CreateProcess function to get around this but I'm stuck.
If I use PROC_THREAD_ATTRIBUTE_HANDLE_LIST as the Attribute argument in UpdateProcThreadAttribute procedure it expects the lpValue parameter to be a pointer to a list of handles to be inherited by the child process.
For the List I've tried using a
TList<Cardinal>
and also creating an array of Cardinals but couldn't get either approaches to compile!
Question: How do I create and populate such a list?
Secondly, in this example it is using the functions and procedures from kernel32.dll but they also exist in the Windows unit too (I'm using Delphi 10.3) although the definitions differ:
For example, InitializeProcThreadAttributeList( nil, 1, 0, vAListSize ); won't compile using the Windows unit due to the nil argument because Types of actual and formal var parameters must be identical but I have no such issue using the one in kernel32
Question: Which version of these functions/procedures should I be using?
Thanks.
In case it is useful, here's my code to implement all of this:
type
TStartupInfoEx = record
StartupInfo: TStartupInfo;
lpAttributeList: Pointer;
end;
const
PROC_THREAD_ATTRIBUTE_HANDLE_LIST = $00020002;
function InitializeProcThreadAttributeList(
lpAttributeList: Pointer;
dwAttributeCount: DWORD;
dwFlags: DWORD;
var lpSize: SIZE_T
): BOOL; stdcall; external kernel32;
function UpdateProcThreadAttribute(
lpAttributeList: Pointer;
dwFlags: DWORD;
Attribute: DWORD_PTR;
lpValue: Pointer;
cbSize: SIZE_T;
lpPreviousValue: PPointer;
lpReturnSize: PSIZE_T
): BOOL; stdcall; external kernel32;
function DeleteProcThreadAttributeList(
lpAttributeList: Pointer
): BOOL; stdcall; external kernel32;
function CreateProcessWithInheritedHandles(
lpApplicationName: LPCWSTR;
lpCommandLine: LPWSTR;
lpProcessAttributes,
lpThreadAttributes: PSecurityAttributes;
const Handles: array of THandle;
dwCreationFlags: DWORD;
lpEnvironment: Pointer;
lpCurrentDirectory: LPCWSTR;
const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation
): Boolean;
var
i: Integer;
StartupInfoEx: TStartupInfoEx;
size: SIZE_T;
begin
Assert(Length(Handles)>0);
StartupInfoEx.StartupInfo := lpStartupInfo;
StartupInfoEx.StartupInfo.cb := SizeOf(StartupInfoEx);
StartupInfoEx.lpAttributeList := nil;
Win32Check(not InitializeProcThreadAttributeList(nil, 1, 0, size) and (GetLastError=ERROR_INSUFFICIENT_BUFFER));
GetMem(StartupInfoEx.lpAttributeList, size);
try
Win32Check(InitializeProcThreadAttributeList(StartupInfoEx.lpAttributeList, 1, 0, size));
try
Win32Check(UpdateProcThreadAttribute(
StartupInfoEx.lpAttributeList,
0,
PROC_THREAD_ATTRIBUTE_HANDLE_LIST,
#Handles[0],
Length(Handles) * SizeOf(Handles[0]),
nil,
nil
));
for i := 0 to High(Handles) do begin
Win32Check(SetHandleInformation(Handles[i], HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT));
end;
Result := CreateProcess(
lpApplicationName,
lpCommandLine,
lpProcessAttributes,
lpThreadAttributes,
True,
dwCreationFlags,
lpEnvironment,
lpCurrentDirectory,
StartupInfoEx.StartupInfo,
lpProcessInformation
);
finally
DeleteProcThreadAttributeList(StartupInfoEx.lpAttributeList);
end;
finally
FreeMem(StartupInfoEx.lpAttributeList);
end;
end;
From your post it would seem that there are some declarations of InitializeProcThreadAttributeList, UpdateProcThreadAttribute and DeleteProcThreadAttributeList in the Windows unit in the latest versions of Delphi, but your post implies that they are incorrectly declared. The above code is known to work correctly.

Delphi code to get Owner of a Netware file not working

I'm a Delphi developer and have never programmed for netware. But I need to find the owner of a file on a netware share. After some research, I got this code snippet from a newsgroup (original author: Chris Morgan). It's basically a way to dynamically load netware dll and get the "owner" information of a file. Please look at the function GetNetwareFileOwner.
The problem is, I don't have direct access to a netware share for testing. I'm sending a small test program every time to a user who tests it by selecting a file on the netware share and then reports the results. I'm getting the error code by a small code insert after the call NWIntScanExtenedInfo where it fails with the error codes given below. Any ideas what can be wrong?
Error codes:
1) At first, the following code gave error 899E (INVALID_FILENAME) on the above call. The file name was in English--no special characters there. And the file was selected on the share with a regular File Open dialog.
2) After that, suspecting a case problem, I commented the two AnsiUpperCase lines to keep the name in original case exactly as the File Open Dialog received it. This gives the error 89FF now (NO_FILES_FOUND_ERROR).
P.S. I compiled the test with Delphi 2007. May be there is a structure problem of the top structure. I haven't checked the byte length and alignment. Will do so.
// netware records and function definitions
type
// sizeof(NW_EXT_FILE_INFO) should be 140 bytes - check byte alignment
NW_EXT_FILE_INFO = record
sequence: integer;
parent: integer;
attributes: integer;
uniqueID: shortint;
flags: shortint;
nameSpace: shortint;
nameLength: shortint;
name: array[0..11] of shortint;
creationDateAndTime: integer;
ownerID: integer;
lastArchiveDateAndTime: integer;
lastArchiverID: integer;
updateDateAndTime: integer;
lastUpdatorID: integer;
dataForkSize: integer;
dataForkFirstFAT: integer;
nextTrusteeEntry: integer;
reserved: array[0..35] of shortint;
inheritedRightsMask: word;
lastAccessDate: word;
deletedFileTime: integer;
deletedDateAndTime: integer;
deletorID: integer;
reserved2: array[0..15] of shortint;
otherForkSize: array[0..1] of integer;
end;
// functions defined in CALWIN32.DLL
TNWCallsInit = function(reserved1: pointer;
reserved2: pointer): integer; stdcall;
TNWCallsTerm = function(reserved: pointer): integer; stdcall;
TNWParseNetWarePath = function(const path: pchar; var conn: cardinal;
var dirhandle: cardinal; newpath: pchar): integer; stdcall;
TNWAllocTemporaryDirectoryHandle = function(conn: cardinal;
dirhandle: cardinal; const path: pchar; var newdirhandle: cardinal;
rightsmask: pshortint): integer; stdcall;
TNWDeallocateDirectoryHandle = function(conn: cardinal;
dirhandle: cardinal): integer; stdcall;
TNWIntScanExtendedInfo = function(conn: cardinal; dirhandle: cardinal;
attrs: shortint; iterhandle: Pinteger; const searchPattern: pchar;
var entryinfo: NW_EXT_FILE_INFO; augmentflag: shortint): integer;
stdcall;
TNWGetObjectName = function(conn: cardinal; objID: integer;
objname: pchar; objtype: pword): integer; stdcall;
const
FA_NORMAL = $00;
FA_HIDDEN = $02;
FA_SYSTEM = $04;
// return codes
SUCCESSFUL = $00;
NOT_MY_RESOURCE = $883C;
// get file owner for Netware server file
function GetNetwareFileOwner(const FilePath: string): string;
var
hcalwin: HINST;
NWCallsInit: TNWCallsInit;
NWParseNetWarePath: TNWParseNetWarePath;
NWAllocTemporaryDirectoryHandle: TNWAllocTemporaryDirectoryHandle;
NWIntScanExtendedInfo: TNWIntScanExtendedInfo;
NWGetObjectName: TNWGetObjectName;
NWDeallocateDirectoryHandle: TNWDeallocateDirectoryHandle;
NWCallsTerm: TNWCallsTerm;
hconn,
hdir,
retcode: cardinal;
filedir: string; { DOS path of parent folder
(upper case) }
nwfilename: string; { DOS filename (upper case) }
nwfiledir: array[0..255] of char; { Netware path of
parent folder }
rights: shortint;
i: integer;
entryinfo: NW_EXT_FILE_INFO;
objtype: word;
begin
Result := '';
// load netware client library and required functions
hcalwin := LoadLibrary('calwin32.dll');
if hcalwin<=0 then exit; // netware client not present on PC
#NWCallsInit := GetProcAddress(hcalwin,'NWCallsInit');
#NWParseNetWarePath := GetProcAddress(hcalwin,'NWParseNetWarePath');
#NWAllocTemporaryDirectoryHandle := GetProcAddress(hcalwin,
'NWAllocTemporaryDirectoryHandle');
#NWIntScanExtendedInfo :=
GetProcAddress(hcalwin,'NWIntScanExtendedInfo');
#NWGetObjectName := GetProcAddress(hcalwin,'NWGetObjectName');
#NWDeallocateDirectoryHandle := GetProcAddress(hcalwin,
'NWDeallocateDirectoryHandle');
#NWCallsTerm := GetProcAddress(hcalwin,'NWCallsTerm');
// initialise netware libs
if NWCallsInit(nil,nil)<>SUCCESSFUL then exit;
try
filedir := AnsiUpperCase(ExtractFileDir(FilePath));
retcode := NWParseNetWarePath(pchar(filedir),hconn,hdir,nwfiledir);
if retcode=NOT_MY_RESOURCE then exit; // local or non-netware disk
// get a dir handle
NWAllocTemporaryDirectoryHandle(hconn,0,nwfiledir,hdir,#rights);
// get the file info
i := -1;
nwfilename := AnsiUpperCase(ExtractFileName(FilePath));
retcode := NWIntScanExtendedInfo(hconn,hdir,
FA_NORMAL+FA_SYSTEM+FA_HIDDEN,
#i,pchar(nwfilename),entryinfo,0);
if retcode=SUCCESSFUL then begin
// get file owner name from ID
SetLength(Result,MAX_PATH);
retcode := NWGetObjectName(hconn,entryinfo.ownerID,
pchar(Result),#objtype);
if retcode=SUCCESSFUL then
SetLength(Result,Length(Result)) // got owner
else SetLength(Result,0); // failed to get owner
end;
// deallocate dir handle
NWDeallocateDirectoryHandle(hconn,hdir);
finally
// clean up
NWCallsTerm(nil);
FreeLibrary(hcalwin);
end;
end;
Are you sure about stdcall? Tru cdecl and so on.
Also, You done give information about delphi's version.
If you use a version BEFORE delphi2009 pchar is a one-byte char.
But if you use delphi2009 or next, pchar is 2 byte char.
So, if you need one byte char you must use PAnsiChar insthead.
I don't know if netware dll parameters are unicode or ansi...
Cher.
A.

How to get Netstat info through the Use of API's in delphi 7

I have been given a task of finding the info abt n/w or, the info which is given by the netstat command in Windows. Now, I have been told to use some API for extracting that information. Any API which is available for delphi 7 for this task will be helpful.
I have come across this API, the IP helper API , but i cannot find that in my PC. i could only find the DLL 'iphlpapi.dll' in C:\Windows\System32. Also, there seems to be very less information on how to use this particular API. Please help.
Thanks IN advance
P.S. Earlier i was doing the same by executing the Netstat command, writing the output to a text file, and then parsing the same for display, which for me, is a Perfectly fine approach. My sir however is not fine with it. What is the cause, i could not fathom.
Check these windows functions GetTcpTable, GetUdpTable, GetExtendedTcpTable, GetExtendedUdpTable.
UPDATE
{$APPTYPE CONSOLE}
uses
WinSock,
Windows,
SysUtils;
const
ANY_SIZE = 1;
iphlpapi = 'iphlpapi.dll';
TCP_TABLE_OWNER_PID_ALL = 5;
MIB_TCP_STATE:
array[1..12] of string = ('CLOSED', 'LISTEN', 'SYN-SENT ','SYN-RECEIVED', 'ESTABLISHED', 'FIN-WAIT-1',
'FIN-WAIT-2', 'CLOSE-WAIT', 'CLOSING','LAST-ACK', 'TIME-WAIT', 'delete TCB');
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;
procedure ShowCurrentTCPConnections;
var
Error : DWORD;
TableSize : DWORD;
i : integer;
IpAddress : in_addr;
RemoteIp : string;
LocalIp : string;
pTcpTable : PMIB_TCPTABLE_OWNER_PID;
begin
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;
//alocate the buffer
GetMem(pTcpTable, TableSize);
try
Writeln(Format('%-16s %-6s %-16s %-6s %s',['Local IP','Port','Remote IP','Port','Status']));
//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
IpAddress.s_addr := pTcpTable.Table[i].dwRemoteAddr;
RemoteIp := string(inet_ntoa(IpAddress));
IpAddress.s_addr := pTcpTable.Table[i].dwLocalAddr;
LocalIp := string(inet_ntoa(IpAddress));
Writeln(Format('%-16s %-6d %-16s %-6d %s',[LocalIp,pTcpTable.Table[i].dwLocalPort,RemoteIp,pTcpTable.Table[i].dwRemotePort,MIB_TCP_STATE[pTcpTable.Table[i].dwState]]));
end;
finally
FreeMem(pTcpTable);
end;
end;
var
hModule : THandle;
begin
try
hModule := LoadLibrary(iphlpapi);
GetExtendedTcpTable := GetProcAddress(hModule, 'GetExtendedTcpTable');
ShowCurrentTCPConnections;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.

Delphi: Get MAC of Router

I am using Delphi and I want to determinate the physical MAC address of a network device in my network, in this case the Router itself.
My code:
var
idsnmp: tidsnmp;
val:string;
begin
idsnmp := tidsnmp.create;
try
idsnmp.QuickSend('.1.3.6.1.2.1.4.22.1.2', 'public', '10.0.0.1', val);
showmessage(val);
finally
idsnmp.free;
end;
end;
where 10.0.0.1 is my router.
Alas, QuickSend does always send "Connection reset by peer #10054". I tried to modify the MIB-OID and I also tried the IP 127.0.0.1 which connection should never fail. I did not find any useable Tutorials about TIdSNMP at Google. :-(
Regards
Daniel Marschall
You can use the SendARP function to get the Mac Address.
check this sample
uses
Windows,
WinSock,
SysUtils;
function SendArp(DestIP,SrcIP:ULONG;pMacAddr:pointer;PhyAddrLen:pointer) : DWord; StdCall; external 'iphlpapi.dll' name 'SendARP';
function GetMacAddr(const IPAddress: string; var ErrCode : DWORD): string;
var
MacAddr : Array[0..5] of Byte;
DestIP : ULONG;
PhyAddrLen : ULONG;
WSAData : TWSAData;
begin
Result :='';
WSAStartup($0101, WSAData);
try
ZeroMemory(#MacAddr,SizeOf(MacAddr));
DestIP :=inet_addr(PAnsiChar(AnsiString(IPAddress)));
PhyAddrLen:=SizeOf(MacAddr);
ErrCode :=SendArp(DestIP,0,#MacAddr,#PhyAddrLen);
if ErrCode = S_OK then
Result:=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]])
finally
WSACleanup;
end;
end;
Not wishing to steal the thunder of RRUZ, I offer the following variant, taken from my codebase, with some observations. I've done this as an answer rather than a comment in order to include code.
type
TMacAddress = array [0..5] of Byte;
function inet_addr(const IPAddress: string): ULONG;
begin
Result := ULONG(WinSock.inet_addr(PAnsiChar(AnsiString(IPAddress))));
end;
function SendARP(DestIP, SrcIP: ULONG; pMacAddr: Pointer; var PhyAddrLen: ULONG): DWORD; stdcall; external 'Iphlpapi.dll';
function GetMacAddress(const IPAddress: string): TMacAddress;
var
MaxMacAddrLen: ULONG;
begin
MaxMacAddrLen := SizeOf(Result);
if SendARP(inet_addr(IPAddress), 0, #Result, MaxMacAddrLen)<>NO_ERROR then begin
raise EMacAddressError.CreateFmt('Unable to do SendARP on address: ''%s''', [IPAddress]);
end;
end;
There are a couple of points to make.
There is no need to call WSAStartup/WSACleanup.
EDIT As RRUZ points out in a comment, the winsock documentation does not explictly exempt inet_addr from WSAStartup/WSACleanup so I retract this point. On Vista it is simpler just to call RtlIpv4StringToAddress. Having said all that, inet_addr is so easy to implement it may just be easier to roll your own.
Secondly the declaration of inet_addr in WinSock.pas is incorrect. It declares the return value to be of a type u_long which is defined in WinSock.pas as Longint. This is a signed 4 byte integer but it should be an unsigned 4 byte integer, ULONG. Without the explicit cast you can get range errors.

How can I find the process id from the service name/handle in Delphi?

I have the service name for a windows service in delphi, and I know how to get the handle from that as well. What I need to do is stop a service, and if the stop fails for some reason I need to kill the process associated with the service. The problem is that I have multiple services running from the same executable, so I can't use the executable name to kill the process. This means I need the process id to kill the proper associated process. How can I get this id or some way to kill the proper process from the service name or handle?
QueryServiceStatusEx?
Please note I have only accepted this solution so that a full delphi code solution is accepted, all due thanks to Jk though for pointing me on the correct path.
--
Ok, I've been able to figure out how to use the answer by Jk and have come up with this solution in delphi.
For reference, this is the link provided by Jk:
QueryServiceStatusEx
My Solution:
unit Demo;
interface
uses
Windows, Forms, SysUtils,
StdCtrls, WinSvc, Controls, Classes;
type
//Form for basic demo usage
TForm6 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
end;
//Record defined for use as return buffer
_SERVICE_STATUS_PROCESS = record
dwServiceType: DWORD;
dwCurrentState: DWORD;
dwControlsAccepted: DWORD;
dwWin32ExitCode: DWORD;
dwServiceSpecificExitCode: DWORD;
dwCheckPoint: DWORD;
dwWaitHint: DWORD;
dwProcessId: DWORD;
dwServiceFlags: DWORD;
end;
//Function Prototype
function QueryServiceStatusEx(
SC_HANDLE: SC_Handle;
SC_STATUS_TYPE: Cardinal;
out lpBuffer: _SERVICE_STATUS_PROCESS;
cbBufSize: DWORD;
out pcbBytesNeeded: LPDWORD
): BOOL; stdcall;
//internal setup function
function GetPid(sService: String; sMachine: String = '') : Cardinal;
var
Form6: TForm6;
implementation
{$R *.dfm}
const
// windows api library
advapi32 = 'advapi32.dll';
//define the api call
function QueryServiceStatusEx; external advapi32 name 'QueryServiceStatusEx';
//for demo usage
procedure TForm6.Button1Click(Sender: TObject);
begin
Memo1.Lines.Add(IntToStr(Integer(GetPid('Service'))))
end;
function GetPid(sService: String; sMachine: String = '') : Cardinal;
var
schm,
schs: SC_Handle;
SC_STATUS_TYPE: Cardinal;
lpBuffer: _SERVICE_STATUS_PROCESS;
cbBufSize: DWORD;
pcbBytesNeeded: LPDWORD;
begin
//open the service manager (defined in WinSvc)
schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
//set the status type to SC_STATUS_PROCESS_INFO
//this is currently the only value supported
SC_STATUS_TYPE := $00000000;
//set the buffer size to the size of the record
cbBufSize := sizeof(_SERVICE_STATUS_PROCESS);
if (schm>0) then
begin
//grab the service handle
schs := OpenService(schm, PChar(sService), SERVICE_QUERY_STATUS);
if (schs>0) then
begin
//call the function
QueryServiceStatusEx(
schs,
SC_STATUS_TYPE,
lpBuffer,
cbBufSize,
pcbBytesNeeded);
CloseServiceHandle(schs);
end;
CloseServiceHandle(schm);
end;
Result := lpBuffer.dwProcessId;
end;
end.
Please note that not all external naming and other necessities are included.
Or use DSiWin32 for many useful functions, including DSiGetProcessID. This code was written by StackOverflow user (and programmer) Gabr.
Here's the function, for your own reference. It will give you what you are looking for:
//Retrieves ID of the specified process. Requires Toolhelp API.
// #returns False if ID cannot be retrieved. Check GetLastError - if it is 0, process
// doesn't exist; otherwise it contains the Win32 error code.
// #author gabr
// #since 2004-02-12
//
function DSiGetProcessID(const processName: string; var processID: DWORD): boolean;
var
hSnapshot: THandle;
procEntry: TProcessEntry32;
begin
Result := false;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot = 0 then
Exit;
try
procEntry.dwSize := Sizeof(procEntry);
if not Process32First(hSnapshot, procEntry) then
Exit;
repeat
if AnsiSameText(procEntry.szExeFile, processName) then begin
processID := procEntry.th32ProcessID;
Result := true;
break; // repeat
end;
until not Process32Next(hSnapshot, procEntry);
finally DSiCloseHandleAndNull(hSnapshot); end;
end; { DSiGetProcessID }

Resources