How to check a DLL if a function exists? - delphi

I'm working on something which dynamically loads specially formulated DLL's. I need to be able to check the DLL and make sure all the expected functions exist before I consider using this DLL. If it's missing some certain functions, I should not try to load it. I know I could attempt to call one of the functions and see if there's an exception, but I would see errors in debug mode.
How should I go about checking a DLL if a function exists? I'd like to check it before I load it (using LoadLibrary) but I guess it's OK if I have to load it to perform this check too.
UPDATE
I've accepted David's answer below, and thought I'd post my final code to show the whole process. I turned it into a function returning a Bool, whether it succeeded or not, cleaned the code a bit, and added another function at the bottom which uses this one to check each name one by one.
I decided to use this method instead of reading GetProcAddress because it will help me in the future with other things.
type
  PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS;
  PIMAGE_EXPORT_DIRECTORY = ^IMAGE_EXPORT_DIRECTORY;
function ImageNtHeader(Base: Pointer): PIMAGE_NT_HEADERS; stdcall;
external 'dbghelp.dll';
function ImageRvaToVa(NtHeaders: Pointer; Base: Pointer; Rva: ULONG;
LastRvaSection: Pointer): Pointer; stdcall; external 'dbghelp.dll';
function ExportedFunctionNames(const ImageName: string; NamesList: TStrings): Bool;
var
i: Integer;
FileHandle: THandle;
ImageHandle: THandle;
ImagePointer: Pointer;
Header: PIMAGE_NT_HEADERS;
ExportTable: PIMAGE_EXPORT_DIRECTORY;
NamesPointer: Pointer;
Names: PAnsiChar;
NamesDataLeft: Integer;
begin
Result:= False;
NamesList.Clear;
FileHandle:= CreateFile(PChar(ImageName), GENERIC_READ, FILE_SHARE_READ,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if FileHandle = INVALID_HANDLE_VALUE then Exit;
try
ImageHandle:= CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil);
if ImageHandle = 0 then Exit;
try
ImagePointer:= MapViewOfFile(ImageHandle, FILE_MAP_READ, 0, 0, 0);
if not Assigned(ImagePointer) then Exit;
try
Header:= ImageNtHeader(ImagePointer);
if not Assigned(Header) then Exit;
if Header.Signature <> $00004550 then Exit; // "PE\0\0" as a DWORD.
ExportTable:= ImageRvaToVa(Header, ImagePointer,
Header.OptionalHeader.DataDirectory[0].VirtualAddress, nil);
if not Assigned(ExportTable) then Exit;
NamesPointer:= ImageRvaToVa(Header, ImagePointer,
Cardinal(ExportTable.AddressOfNames), nil);
if not Assigned(NamesPointer) then Exit;
Names:= ImageRvaToVa(Header, ImagePointer, Cardinal(NamesPointer^), nil);
if not Assigned(Names) then Exit;
NamesDataLeft:= Header.OptionalHeader.DataDirectory[0].Size;
for i:= 0 to ExportTable.NumberOfNames - 1 do begin
NamesList.Add(Names);
while (Names^ <> chr(0)) and (NamesDataLeft > 0) do begin
Inc(Names);
Dec(NamesDataLeft);
end;
Inc(Names);
end;
Result:= True;
finally
UnmapViewOfFile(ImagePointer);
end;
finally
CloseHandle(ImageHandle);
end;
finally
CloseHandle(FileHandle);
end;
end;
function IsMyDLL(const Filename: String): Bool;
var
H: THandle;
L: TStringList;
function InList(const Func: String): Bool;
begin
Result:= L.IndexOf(Func) >= 0;
end;
begin
Result:= False;
L:= TStringList.Create;
try
if ExportedFunctionNames(Filename, L) then begin
Result:=//Names of functions which need to exist
InList('GetName') and
InList('GetDescription') and
InList('GetVersion') and
InList('Start') and
InList('Stop');
end;
finally
L.Free;
end;
end;

You have to use LoadLibrary, and then use GetProcAddress for each function you want to check existence for. There's really no other reasonable choice (unless there are specific reasons you need to avoid`LoadLibrary). Since your intent seems to be just to check to see if the functions are present and nothing more, LoadLibrary and GetProcAddress are the simplest means to do so; you can do all of the work in very few lines of code, and error checking is extremely simple and straightforward.

If you are in control of the DLLs and you don't want to load them in order to check capability, then you could use the version resource to indicate capability. This would require the host app to have knowledge of what was the minimum supported version for each optional DLL feature. You can read the version resource cheaply without loading the DLL.
It is perfectly possible, and rather simple, to obtain the list of functions exported by a DLL with loading it into your process with LoadLibrary. The dbghelp.dll system library provides services to do that. However, I suspect that is overkill for your situation.
If it is not a problem to load and unload the DLL then GetProcAddress is probably the preferred solution. If there is some reason why you need to avoid loading the DLL in order to check capability, use the version resource to infer capability. If you need to do this with legacy DLLs that do not have a meaningful version resource then use dbghelp.dll to find the exported functions.
For the sake of completeness, here is some code to read all the exported symbols from a DLL, without loading it with LoadLibrary.
type
PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS;
PIMAGE_EXPORT_DIRECTORY = ^IMAGE_EXPORT_DIRECTORY;
function ImageNtHeader(Base: Pointer): PIMAGE_NT_HEADERS; stdcall; external 'dbghelp.dll';
function ImageRvaToVa(NtHeaders: Pointer; Base: Pointer; Rva: ULONG; LastRvaSection: Pointer): Pointer; stdcall; external 'dbghelp.dll';
procedure ImageExportedFunctionNames(const ImageName: string; NamesList: TStrings);
var
i: Integer;
FileHandle: THandle;
ImageHandle: THandle;
ImagePointer: Pointer;
Header: PIMAGE_NT_HEADERS;
ExportTable: PIMAGE_EXPORT_DIRECTORY;
NamesPointer: Pointer;
Names: PAnsiChar;
NamesDataLeft: Integer;
begin
//NOTE: our policy in this procedure is to exit upon any failure and return an empty list
NamesList.Clear;
FileHandle := CreateFile(
PChar(ImageName),
GENERIC_READ,
FILE_SHARE_READ,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0
);
if FileHandle=INVALID_HANDLE_VALUE then begin
exit;
end;
Try
ImageHandle := CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil);
if ImageHandle=0 then begin
exit;
end;
Try
ImagePointer := MapViewOfFile(ImageHandle, FILE_MAP_READ, 0, 0, 0);
if not Assigned(ImagePointer) then begin
exit;
end;
Try
Header := ImageNtHeader(ImagePointer);
if not Assigned(Header) then begin
exit;
end;
if Header.Signature<>$00004550 then begin // "PE\0\0" as a DWORD.
exit;
end;
ExportTable := ImageRvaToVa(Header, ImagePointer, Header.OptionalHeader.DataDirectory[0].VirtualAddress, nil);
if not Assigned(ExportTable) then begin
exit;
end;
NamesPointer := ImageRvaToVa(Header, ImagePointer, Cardinal(ExportTable.AddressOfNames), nil);
if not Assigned(NamesPointer) then begin
exit;
end;
Names := ImageRvaToVa(Header, ImagePointer, Cardinal(NamesPointer^), nil);
if not Assigned(Names) then begin
exit;
end;
NamesDataLeft := Header.OptionalHeader.DataDirectory[0].Size;
for i := 0 to ExportTable.NumberOfNames-1 do begin
NamesList.Add(Names);
// Locate the next name
while (Names^<>chr(0)) and (NamesDataLeft>0) do begin
inc(Names);
dec(NamesDataLeft);
end;
inc(Names);
end;
Finally
UnmapViewOfFile(ImagePointer); // Ignore error as there is not much we could do.
End;
Finally
CloseHandle(ImageHandle);
End;
Finally
CloseHandle(FileHandle);
End;
end;

Related

Check if resource exists in another application in Delphi

I'm trying to verify whether a resource exists in another Delphi application, the problem is that only know how to do it locally, I mean in the application itself.
Source:
function exists_resource(name: string): boolean;
begin
if (FindResource(HInstance, PChar(name), RT_RCDATA) <> 0) then
begin
Result := True;
end
else
begin
Result := False;
end;
end;
As I can verify this in a different application?
Use LoadLibraryEx to load the external file.
function exists_resource(const name, filename: string): boolean;
var
HInst: THandle;
begin
HInst:= LoadLibraryEx(PChar(Filename), 0, LOAD_LIBRARY_AS_DATAFILE or LOAD_LIBRARY_AS_IMAGE_RESOURCE);
//Win32Check(HInst); //Uncomment if you want to generate errors.
if HInst = 0 then exit(false);
try
Exit((FindResource(HInst, PChar(name), RT_RCDATA) <> 0));
finally
FreeLibrary(Hinst);
end; {try}
end;
Note that using LoadLibraryEx in this way will work for loading both dll's and exe's.

Copying files to clipboard and then pasting them into their original folder does not work

I've got a puzzling situation. I am using the following code in Delphi to copy a list of files to the clipboard;
procedure TfMain.CopyFilesToClipboard(FileList: string);
const
C_UNABLE_TO_ALLOCATE_MEMORY = 'Unable to allocate memory.';
C_UNABLE_TO_ACCESS_MEMORY = 'Unable to access allocated memory.';
var
DropFiles: PDropFiles;
hGlobal: THandle;
iLen: Integer;
begin
iLen := Length(FileList);
hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or
GMEM_ZEROINIT, SizeOf(TDropFiles) + ((iLen + 2) * SizeOf(Char)));
if (hGlobal = 0) then
raise Exception.Create(C_UNABLE_TO_ALLOCATE_MEMORY);
try DropFiles := GlobalLock(hGlobal);
if (DropFiles = nil) then raise Exception.Create(C_UNABLE_TO_ACCESS_MEMORY);
try
DropFiles^.pFiles := SizeOf(TDropFiles);
DropFiles^.fWide := True;
if FileList <> '' then
Move(FileList[1], (PByte(DropFiles) + SizeOf(TDropFiles))^,
iLen * SizeOf(Char));
finally
GlobalUnlock(hGlobal);
end;
Clipboard.SetAsHandle(CF_HDROP, hGlobal);
except
GlobalFree(hGlobal);
end;
end;
(This seems to be a popular piece of code on the internet)
Using my application, once the files are copied to the clipboard, I can use Windows Explorer to paste them into every other folder, EXCEPT the folder where the file originally came from! I was expecting it to behave just like a normal Windows copy (i.e. on paste it should create a file with postfix of '-Copy') but this doesn't seem to work. Any clues?
I am not able to get Windows Explorer to paste into the source folder when the only clipboard format available is CF_HDROP. However, if the filenames are provided in an IDataObject instead, it works fine.
If all of the files are from the same source folder, you can retrieve the IShellFolder of the source folder and query it for child PIDLs for the individual files, then use IShellFolder.GetUIObjectOf() to get an IDataObject that represents the files. Then use OleSetClipboard() to put that object on the clipboard. For example:
uses
System.Classes, Winapi.Windows, Winapi.ActiveX, Winapi.Shlobj, Winapi.ShellAPI, System.Win.ComObj;
procedure CopyFilesToClipboard(const Folder: string; FileNames: TStrings);
var
SF: IShellFolder;
PidlFolder: PItemIDList;
PidlChildren: array of PItemIDList;
Eaten: UINT;
Attrs: DWORD;
Obj: IDataObject;
I: Integer;
begin
if (Folder = '') or (FileNames = nil) or (FileNames.Count = 0) then Exit;
OleCheck(SHParseDisplayName(PChar(Folder), nil, PidlFolder, 0, Attrs));
try
OleCheck(SHBindToObject(nil, PidlFolder, nil, IShellFolder, Pointer(SF)));
finally
CoTaskMemFree(PidlFolder);
end;
SetLength(PidlChildren, FileNames.Count);
for I := Low(PidlChildren) to High(PidlChildren) do
PidlChildren[i] := nil;
try
for I := 0 to FileNames.Count-1 do
OleCheck(SF.ParseDisplayName(0, nil, PChar(FileNames[i]), Eaten, PidlChildren[i], Attrs));
OleCheck(SF.GetUIObjectOf(0, FileNames.Count, PIdlChildren[0], IDataObject, nil, obj));
finally
for I := Low(PidlChildren) to High(PidlChildren) do
begin
if PidlChildren[i] <> nil then
CoTaskMemFree(PidlChildren[i]);
end;
end;
OleCheck(OleSetClipboard(obj));
OleCheck(OleFlushClipboard);
end;
Update: If the files are in different source folders, you can use the CFSTR_SHELLIDLIST format:
uses
System.Classes, System.SysUtils, Winapi.Windows, Winapi.ActiveX, Winapi.Shlobj, Winapi.ShellAPI, System.Win.ComObj, Vcl.Clipbrd;
{$POINTERMATH ON}
function HIDA_GetPIDLFolder(pida: PIDA): LPITEMIDLIST;
begin
Result := LPITEMIDLIST(LPBYTE(pida) + pida.aoffset[0]);
end;
function HIDA_GetPIDLItem(pida: PIDA; idx: Integer): LPITEMIDLIST;
begin
Result := LPITEMIDLIST(LPBYTE(pida) + (PUINT(#pida.aoffset[0])+(1+idx))^);
end;
var
CF_SHELLIDLIST: UINT = 0;
type
CidaPidlInfo = record
Pidl: PItemIDList;
PidlOffset: UINT;
PidlSize: UINT;
end;
procedure CopyFilesToClipboard(FileNames: TStrings);
var
PidlInfo: array of CidaPidlInfo;
Attrs, AllocSize: DWORD;
gmem: THandle;
ida: PIDA;
I: Integer;
begin
if (FileNames = nil) or (FileNames.Count = 0) or (CF_SHELLIDLIST = 0) then Exit;
SetLength(PidlInfo, FileNames.Count);
for I := Low(PidlInfo) to High(PidlInfo) do
PidlInfo[I].Pidl := nil;
try
AllocSize := SizeOf(CIDA)+(SizeOf(UINT)*FileNames.Count)+SizeOf(Word);
for I := 0 to FileNames.Count-1 do
begin
OleCheck(SHParseDisplayName(PChar(FileNames[I]), nil, PidlInfo[I].Pidl, 0, Attrs));
PidlInfo[I].PidlOffset := AllocSize;
PidlInfo[I].PidlSize := ILGetSize(PidlInfo[I].Pidl);
Inc(AllocSize, PidlInfo[I].PidlSize);
end;
gmem := GlobalAlloc(GMEM_MOVEABLE, AllocSize);
if gmem = 0 then RaiseLastOSError;
try
ida := PIDA(GlobalLock(gmem));
if ida = nil then RaiseLastOSError;
try
ida.cidl := FileNames.Count;
ida.aoffset[0] := SizeOf(CIDA)+(SizeOf(UINT)*FileNames.Count);
HIDA_GetPIDLFolder(ida).mkid.cb := 0;
for I := 0 to FileNames.Count-1 do
begin
ida.aoffset[1+I] := PidlInfo[I].PidlOffset;
Move(PidlInfo[I].Pidl^, HIDA_GetPIDLItem(ida, I)^, PidlInfo[I].PidlSize);
end;
finally
GlobalUnlock(gmem);
end;
Clipboard.SetAsHandle(CF_SHELLIDLIST, gmem);
except
GlobalFree(gmem);
raise;
end;
finally
for I := Low(PidlInfo) to High(PidlInfo) do
CoTaskMemFree(PidlInfo[I].Pidl);
end;
end;
initialization
CF_SHELLIDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST);
Alternatively:
procedure CopyFilesToClipboard(FileNames: TStrings);
var
Pidls: array of PItemIdList;
Attrs: DWORD;
I: Integer;
obj: IDataObject;
begin
if (FileNames = nil) or (FileNames.Count = 0) then Exit;
SetLength(Pidls, FileNames.Count);
for I := Low(Pidls) to High(Pidls) do
Pidls[I] := nil;
try
for I := 0 to FileNames.Count-1 do
OleCheck(SHParseDisplayName(PChar(FileNames[I]), nil, Pidls[I], 0, Attrs));
OleCheck(CIDLData_CreateFromIDArray(nil, FileNames.Count, PItemIDList(Pidls), obj));
finally
for I := Low(Pidls) to High(Pidls) do
CoTaskMemFree(Pidls[I]);
end;
OleCheck(OleSetClipboard(obj));
OleCheck(OleFlushClipboard);
end;
However, I found that Windows Explorer will sometimes but not always allow CFSTR_SHELLIDLIST to be pasted into the source folder of a referenced file. I don't know what criteria is preventing Windows Explorer from pasting. Maybe some kind of permissions issue?
You should take Microsoft's advice:
Handling Shell Data Transfer Scenarios
Include as many formats as you can support. You generally do not know where the data object will be dropped. This practice improves the odds that the data object will contain a format that the drop target can accept.

Read text files in Delphi

Hi I am having a problem running a function to read a text file the problem seems to be that my antivirus blocks my delphi console program because when I do for a visual form there is no problem .
Tengos two codes one is this :
function LeerArchivox(const filename: TFileName): String;
var
List: TStringList;
begin
if (FileExists(filename)) then
begin
List := TStringList.Create;
List.Loadfromfile(filename);
Result := List.text;
List.Free;
end;
end;
This goes to perfection but do not want to use the component Classes for the program does not weigh much .
Also I have this :
function leerarchivo(filealeer: string): string;
var
abriendo: TextFile;
lineasleyendo: string;
finaldearchivo: string;
begin
finaldearchivo := '';
AssignFile(abriendo, filealeer);
Reset(abriendo);
while not Eof(abriendo) do
begin
ReadLn(abriendo, lineasleyendo);
finaldearchivo := finaldearchivo + lineasleyendo;
end;
CloseFile(abriendo);
Result := finaldearchivo;
end;
Other code.
function leerarchivo3(archivoaleer: string): string;
const
BUFF_SIZE = $8000;
var
dwread: LongWord;
hFile: THandle;
datafile: array [0 .. BUFF_SIZE - 1] of ansichar;
codigofinal: string;
begin
codigofinal := '';
hFile := CreateFile(PChar(archivoaleer), GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_READONLY, 0);
SetFilePointer(hFile, 0, nil, FILE_BEGIN);
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
while (dwread > 0) do
begin
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
codigofinal := codigofinal + datafile;
end;
Result := codigofinal;
end;
This is the problem because when I use my antivirus deletes it at the time , my question to other alternatives I have to read a text file without using Classes.
Someone can help me?
This code works fine for me as a console application, Delphi 2007, running on Win7 64:
Contents of 'E:\TempFiles\Test.txt':
One
Two
Three
Four
Source:
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
var
Txt: TextFile;
s: string;
AllText: string;
begin
AllText := '';
AssignFile(Txt, 'E:\TempFiles\test.txt');
Reset(Txt);
while not Eof(Txt) do
begin
Readln(Txt, s);
AllText := AllText + s;
// Write out each line; comment out to stop.
Writeln(s);
end;
CloseFile(Txt);
// Write out all content as a single string.
WriteLn(AllText);
ReadLn;
end.
Produces output:
One
Two
Three
Four
OneTwoThreeFour
You can use win32 api.
In one of my apps I do things like that, extend/modify to match your needs. This only use Win32 API and does not lock the file. It's like notepad. When you open a file with notepad it is not locked and can still be written or read by other software.
const
BUFF_SIZE = $8000;
var
dwread:LongWord;
hFile: THandle;
datafile : array [0..BUFF_SIZE-1] of ansichar;
//create file handler
hFile := createfile(PChar(TFilePanel(FilePanelList.Items[i-1]).LongFileName), GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_READONLY, 0);
//set file pointer to beginning of file
SetFilePointer(hFile, 0, nil, FILE_BEGIN);
//read the file
try
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
while (dwread > 0) do
begin
//read/use datafile
Here_do_something_with_datafile;
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
end;
finally
closehandle(hFile);
end;
var txt : TextFile;
begin
AssignFile(txt,'filetxt.txt');
ReWrite(filetxt);
Writeln(filetxt,memo1.Lines.Text);
CloseFile(filetxt);
Reset(filetxt);
while not Eof(filetxt) do
begin
Readln(filetxt);
end;
CloseFile(filetxt);
If you don't want to use the Classes unit, only need to operate on this file, and are making a Windows executable, you could use the Windows unit instead and call the Win32 API functions: CreateFile, ReadFile, CloseHandle and related functions.

I open a shortcut when shortcut don't exist , why not show this dialog?

I use ShellExecute to open a shortcut
Code :
ShellExecute(Handle, 'open', 'C:\Users\hi2012\AppData\Roaming\Microsoft\Windows\Recent\xxx.gif.lnk', nil, nil, SW_SHOWNORMAL)
if xxx.gif exist that code can open it , if not it don't give anything.
but , when I open it with windows explorer it will show this:
I want when I use code to open a not nonexistent shortcut it also can show that , what can I do ?
is this a wrong way to use ShellExecute to open a shortcut ?
ShellExecute doesn't show dialogs when it fails. And it will not offer to delete files on your behalf. That dialog is shown by the Explorer app.
In order to handle errors you need to check the return value of the call to ShellExecute. If that return value is greater than 32 then the call succeeded. Otherwise there was an error. The possible reported errors are listed in the documentation.
For better error handling, use ShellExecuteEx. If a call to ShellExecuteEx fails then you can obtain an error code by calling GetLastError.
You should use IShellLink::Resolve to resolve the shortcut yourself. IShellLink::Resolve offers flags to control whether to show search UI.
You can invoke "open" from context popup menu on .lnk file. This will give you the same behaviour as double-clicking .lnk file in Explorer:
function SHBindToParent(pidl: PItemIDList; const riid: TIID; out ppv; out ppidlLast: PItemIDList): HResult; stdcall; external 'shell32.dll' name 'SHBindToParent';
procedure ExecuteFile(const AWnd: HWND; const AFileName: String);
function GetUIObjectOfFile(wnd: HWND; const pszPath: WideString; const riid: TGUID; out ppv): HRESULT;
var
pidl: PItemIDList;
sfgao: DWord;
psf: IShellFolder;
pidlChild: PItemIDList;
begin
DWord(ppv) := 0;
Result := SHParseDisplayName(PWideChar(pszPath), nil, pidl, 0, sfgao);
if SUCCEEDED(Result) then
try
Result := SHBindToParent(pidl, IID_IShellFolder, psf, pidlChild);
if SUCCEEDED(Result) then
try
Result := psf.GetUIObjectOf(wnd, 1, pidlChild, riid, nil, ppv);
finally
psf := nil;
end;
finally
CoTaskMemFree(pidl);
end;
end;
const
SCRATCH_QCM_FIRST = 1;
SCRATCH_QCM_LAST = $7FFF;
var
pcm: IContextMenu;
Menu: HMENU;
Info: TCMInvokeCommandInfo;
Id: UINT;
begin
if SUCCEEDED(GetUIObjectOfFile(AWnd, PChar(AFileName), IID_IContextMenu, pcm)) then
try
Menu := CreatePopupMenu;
if Menu <> 0 then
try
if SUCCEEDED(pcm.QueryContextMenu(Menu, 0, SCRATCH_QCM_FIRST, SCRATCH_QCM_LAST, CMF_DEFAULTONLY)) then
begin
Id := GetMenuDefaultItem(Menu, 0, 0);
if Id <> UINT(-1) then
begin
FillChar(Info, SizeOf(Info), 0);
Info.cbSize := SizeOf(info);
Info.hwnd := Handle;
Info.lpVerb := MAKEINTRESOURCEA(Id - SCRATCH_QCM_FIRST);
SetLastError(pcm.InvokeCommand(Info));
if GetLastError <> 0 then
RaiseLastOSError;
end;
end;
finally
DestroyMenu(Menu);
end;
finally
pcm := nil;
end;
end;
The same should be archieved by calling ShellExecuteEx with SEE_MASK_INVOKEIDLIST flag.

How to find the name of the parent program that started us?

We want a program of ours in D7 to know if it was run via a ShellExecute command from one of our apps, or directly started by the user.
Is there a reliable way for a Delphi 7 program to determine the name of the program that ran it?
We of course could have our parent program use a command line argument or other flag, but we'd prefer the above approach.
TIA
There's no way to do what you want, I'm afraid. The application isn't told whether it's being run pro grammatically via ShellExecute (or CreateProcess), via a command line, a shortcut, or a double-click in Explorer.
Raymond Chen did an article a while back on this very topic, if I remember correctly; I'll see if I can find it and update my answer here.
Based on another answer and some code on Torry.net, I came to this function to get the parent process id. It seems to return a relevant number on Windows 7, and the windows functions it uses should be available at least since Win 2000.
uses Tlhelp32;
function GetProcessInfo(ProcessId: Cardinal; out ParentProcessId: Cardinal; out ExeFileName: string): Boolean;
var
hSnapShot: THandle;
ProcInfo: TProcessEntry32;
begin
hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (hSnapShot <> THandle(-1)) then
try
ProcInfo.dwSize := SizeOf(ProcInfo);
if (Process32First(hSnapshot, ProcInfo)) then
repeat
if ProcInfo.th32ProcessID = ProcessId then
begin
ExeFileName := string(ProcInfo.szExeFile);
ParentProcessId := ProcInfo.th32ParentProcessID;
Result := True;
Exit;
end;
until not Process32Next(hSnapShot, ProcInfo);
finally
CloseHandle(hSnapShot);
end;
Result := False;
end;
procedure Test;
var
ProcessId, ParentProcessId, Dummy: Cardinal;
FileName: string;
begin
ProcessId := GetCurrentProcessId();
// Get info for current process
if GetProcessInfo(ProcessId, ParentProcessId, FileName) then
// Get info for parent process
if GetProcessInfo(ParentProcessId, Dummy, FileName) then
// Show it.
ShowMessage(IntToStr(ParentProcessId) + FileName);
end;
A word of caution! The parent process may no longer exist. Even worse, it's ID may have been recycled, causing this function to give you a different process than you asked for.
The simple answer is "No".
A more complex answer is "Not as easily as simply passing a command line param would be".
:)
What you need to do is identify the parent process of your process. Obtaining this is possible but not straightforward. Details of how to go about it can be obtained in this CodeProject article.
The biggest problem is that there is not strict hierarchical relationship between processes in Windows and PID (Process ID's) may be re-used. The PID you identify as your "parent" may not be your parent at all. If the parent process has subsequently terminated then it's PID may be re-used which could lead to some seemingly perplexing results ("My process was started by calc.exe? How is that possible?").
Trying to find bullet, water and idiot proof mechanisms to protect against the possible ways such a process might fail will be significantly more effort than simply devising and implementing a command line based convention between your launcher applications and the launchee by which the latter may identify the former.
A command line parameter is one such option but could be "spoofed" (if someone figures out what you are passing on the command line and for some reason could derive some value or benefit from mimicking this themselves).
Depending on how reliable and tamper proof you need the mechanism to be, this could still be enough however.
I've found getpids which does it using NtQueryInformationProcess to not only to obtain the parent process ID but also compare the process creation times - if the reported parent process was created after the child it means the reported parent ID has already been recycled.
Here is my Delphi unit I wrote to test it:
unit ProcInfo;
interface
uses
Windows, SysUtils;
function GetParentProcessId(ProcessID: DWORD; out ProcessImageFileName: string): DWORD; overload;
implementation
uses
PsApi;
var
hNtDll: THandle;
NtQueryInformationProcess: function(ProcessHandle: THandle; ProcessInformationClass: DWORD;
ProcessInformation: Pointer; ProcessInformationLength: ULONG; ReturnLength: PULONG): DWORD; stdcall;
const
UnicodeStringBufferLength = 1025;
type
PPEB = Pointer; // PEB from winternl.h not needed here
PPROCESS_BASIC_INFORMATION = ^PROCESS_BASIC_INFORMATION;
PROCESS_BASIC_INFORMATION = record
Reserved1: Pointer; // exit status
PebBaseAddress: PPEB;
Reserved2: array[0..1] of Pointer; // affinity mask, base priority
UniqueProcessId: ULONG_PTR;
Reserved3: Pointer; // parent process ID
end;
PProcessBasicInformation = ^TProcessBasicInformation;
TProcessBasicInformation = PROCESS_BASIC_INFORMATION;
PKernelUserTimes = ^TKernelUserTimes;
TKernelUserTimes = record
CreateTime: LONGLONG;
ExitTime: LONGLONG;
KernelTime: LONGLONG;
UserTime: LONGLONG;
end;
PUNICODE_STRING = ^UNICODE_STRING;
UNICODE_STRING = record
Length: USHORT;
MaximumLength: USHORT;
PBuffer: PChar;
Buffer: array[0..UnicodeStringBufferLength - 1] of Char;
end;
PUnicodeString = ^TUnicodeString;
TUnicodeString = UNICODE_STRING;
function GetProcessCreateTime(hProcess: THandle): LONGLONG;
var
ProcessTimes: TKernelUserTimes;
begin
Result := 0;
FillChar(ProcessTimes, SizeOf(ProcessTimes), 0);
if NtQueryInformationProcess(hProcess, 4, #ProcessTimes, SizeOf(ProcessTimes), nil) <> 0 then
Exit;
Result := ProcessTimes.CreateTime;
end;
function GetProcessParentId(hProcess: THandle): DWORD;
var
ProcessInfo: TProcessBasicInformation;
begin
Result := 0;
FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);
if NtQueryInformationProcess(hProcess, 0, #ProcessInfo, SizeOf(ProcessInfo), nil) <> 0 then
Exit;
Result := DWORD(ProcessInfo.Reserved3);
end;
function GetProcessImageFileName(hProcess: THandle): string;
var
ImageFileName: TUnicodeString;
begin
Result := '';
FillChar(ImageFileName, SizeOf(ImageFileName), 0);
ImageFileName.Length := 0;
ImageFileName.MaximumLength := UnicodeStringBufferLength * SizeOf(Char);
ImageFileName.PBuffer := #ImageFileName.Buffer[0];
if NtQueryInformationProcess(hProcess, 27, #ImageFileName, SizeOf(ImageFileName), nil) <> 0 then
Exit;
SetString(Result, ImageFileName.PBuffer, ImageFileName.Length);
end;
function GetParentProcessId(ProcessId: DWORD; out ProcessImageFileName: string): DWORD;
var
hProcess, hParentProcess: THandle;
ProcessCreated, ParentCreated: LONGLONG;
begin
Result := 0;
ProcessImageFileName := '';
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
if hProcess = 0 then
RaiseLastOSError;
try
Result := GetProcessParentId(hProcess);
if Result = 0 then
Exit;
ProcessCreated := GetProcessCreateTime(hProcess);
finally
CloseHandle(hProcess);
end;
hParentProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, Result);
if hParentProcess = 0 then
RaiseLastOSError;
try
ParentCreated := GetProcessCreateTime(hParentProcess);
if ParentCreated > ProcessCreated then
begin
Result := 0;
Exit;
end;
ProcessImageFileName := GetProcessImageFileName(hParentProcess);
finally
CloseHandle(hParentProcess);
end;
end;
initialization
hNtDll := GetModuleHandle('ntdll.dll');
if hNtDll <> 0 then
NTQueryInformationProcess := GetProcAddress(hNtDll, 'NtQueryInformationProcess');
end.
When I run the code from the IDE, I get the following results:
parent ID: 5140, parent image file name:
"\Device\HarddiskVolume1\Program Files\Embarcadero\RAD
Studio\8.0\bin\bds.exe"
so you may need to find a way to translate that into a "normal" path, e.g. "C:\Program Files\Embarcadero\RAD Studio\8.0\bin\bds.exe".

Resources