I am developing using Delphi 6 on a WinXP system.
I have been using the following function to run a program with elevated rights.
function LB_RunAsAdminWait(hWnd: HWND;
filename: string;
Parameters: string): Boolean;
var sei: TShellExecuteInfo; // shell execute info
begin
Result := False; // default to failure
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.Wnd := hWnd;
sei.fMask := SEE_MASK_FLAG_NO_UI or SEE_MASK_NOCLOSEPROCESS;
sei.lpVerb := 'runas';
sei.lpFile := PChar(filename);
sei.lpParameters := PChar(Parameters);
sei.nShow := SW_SHOWNORMAL;
if ShellExecuteEx(#sei) then // if success
Result := True; // return sucess
if sei.hProcess <> 0 then begin // wait for process to finish
while WaitForSingleObject(sei.hProcess, 50) = WAIT_TIMEOUT do
Application.ProcessMessages;
CloseHandle(sei.hProcess);
end;
end; // of function LB_RunAsAdminWait
How I call it:
if (LB_RunAsAdminWait(FPGM.Handle,'RegSvr32',FName+' /s') = False) then
begin
ShowMessage('WARNING: unable to register OCX');
exit;
end;
where FPGM.handle is the handle to my application
and Fname is the OCX i want to register.
When I run it on a WIN7 machine it returns true(successful) but the OCX is not registered.
Any help would be appreciated.
Most likely explanation is that this is a 32 bit vs 64 bit issue. The DLL is 64 bit, and you are running the 32 bit regsvr32. Or vice versa. Or the file system redirector is confounding you. You put the DLL in system32, but the redirector turns that into SysWow64.
The obvious way to debug it is to remove the silent switch and let regsvr32 tell you what went wrong.
As an aside, as you have discovered, you cannot use the return value of ShellExecuteEx to determine whether or not the server registration succeeded. The return value of ShellExecuteEx merely tells you whether or not the process started.
Related
Using Delphi 10.2.3, I'm implementing a service that, among other things, will need to shut down a user app before a database restore and then restart the app after. Shutting down the app is no problem, but starting the app back up is, for the obvious session-0 reason. I found the following code online to do this, and it works fine, with one exception.
function CreateEnvironmentBlock(var lpEnvironment: Pointer; hToken: THandle; bInherit: BOOL): BOOL; stdcall; external 'userenv.dll';
function DestroyEnvironmentBlock(lpEnvironment: Pointer): BOOL; stdcall; external 'userenv.dll';
function SvcLaunchAppInCurrUserSession(const AppToLaunch: String;
const Params: String = '';
WaitForIt: Boolean = False;
HideIt: Boolean = False): Cardinal;
var
PI: PROCESS_INFORMATION;
SI: STARTUPINFO;
bResult: Boolean;
dwSessionId: DWORD;
hUserTokenDup, hPToken: THANDLE;
dwCreationFlags: DWORD;
CommandLine: string;
Directory: string;
tp: TOKEN_PRIVILEGES;
pEnv: Pointer;
begin
Result := S_OK;
try
try
pEnv := nil;
dwCreationFlags := NORMAL_PRIORITY_CLASS or CREATE_NEW_CONSOLE;
CommandLine := Trim('"'+Trim(AppToLaunch)+'" '+Params);
Directory := ExtractFileDir(AppToLaunch);
// get the current active session and the token
dwSessionId := WtsGetActiveConsoleSessionID;
// initialize startup info
ZeroMemory(#SI, SizeOf(SI));
SI.cb := SizeOf(STARTUPINFO);
SI.lpDesktop := nil; //PChar('winsta0\Default');
SI.dwFlags := STARTF_USESHOWWINDOW;
if HideIt then
SI.wShowWindow := SW_HIDE
else
SI.wShowWindow := SW_SHOWNORMAL;
if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or
TOKEN_QUERY or
TOKEN_DUPLICATE or
TOKEN_ASSIGN_PRIMARY or
TOKEN_ADJUST_SESSIONID or
TOKEN_READ or
TOKEN_WRITE,
hPToken) then begin
tp.PrivilegeCount := 1;
tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
if LookupPrivilegeValue(nil, 'SeDebugPrivilege', tp.Privileges[0].Luid) then begin
DuplicateTokenEx(hPToken, MAXIMUM_ALLOWED, nil, SecurityIdentification, TokenPrimary, hUserTokenDup);
SetTokenInformation(hUserTokenDup, TokenSessionId, #dwSessionId, SizeOf(DWORD));
if CreateEnvironmentBlock(pEnv, hUserTokenDup, True) then
dwCreationFlags := dwCreationFlags or CREATE_UNICODE_ENVIRONMENT
else
pEnv := nil;
// Launch the process in the client's logon session.
bResult := CreateProcessAsUser(hUserTokenDup, // client's access token
nil, // file to execute
PChar(CommandLine), // command line
nil, // pointer to process SECURITY_ATTRIBUTES
nil, // pointer to thread SECURITY_ATTRIBUTES
False, // handles are not inheritable
dwCreationFlags, // creation flags
pEnv, // pointer to new environment block
PChar(Directory), // name of current directory
si, // pointer to STARTUPINFO structure
pi); // receives information about new process
if not bResult then begin
Result := GetLastError;
Exit;
end;
end
else begin
Result := GetLastError;
Exit;
end;
end
else begin
Result := GetLastError;
Exit;
end;
if WaitForIt then begin
WaitForSingleObject(PI.hProcess, INFINITE);
GetExitCodeProcess(PI.hProcess, Result);
end;
finally
// close all handles
if Assigned(pEnv) then
DestroyEnvironmentBlock(pEnv);
CloseHandle(hUserTokenDup);
CloseHandle(PI.hProcess);
CloseHandle(PI.hThread);
CloseHandle(hPToken);
end;
except
on E:Exception do begin
DbgLogFmt('SvcLaunchApp %s: %s', [E.ClassName, E.Message]);
raise;
end;
end;
end;
The problem with this is that it launches the app with the service's permissions (SYSTEM), which is a huge security hole. I want it to launch the app with the current user's permissions, either user or admin, but not system. I know zilch about the ins and outs of Windows security, but I'm sure there's a way to do this - I just don't know what parts of the above need to be tweaked so the right permissions are used. Or if there's a better way to do this, I'm open to it. Suggestions?
Thanks.
You are using the user token that your service is running as (SYSTEM). Use WTSQueryUserToken() to get the user token of the target session instead.
You must first impersonate the user and then run the application.
I wrote a blog article using impersonation that will probably help you. You need user credentials for that purpose.
Impersonation will make your program (Here a service) act as another user. The blog article use that feature to hide data from current user. In your case, your service will first impersonate as the target user and then launch the application which in turn will run in the context of the impersonated user.
I published the source code on github. This code is the result of a StackOverflow discussion.
In Delphi XE8 under Windows, I am trying to call an external console application and capture its output. I use the following code, as described in Capture the output from a DOS (command/console) Window and also Getting output from a shell/dos app into a Delphi app:
procedure TForm1.Button1Click(Sender: TObject) ;
procedure RunDosInMemo(DosApp:String;AMemo:TMemo) ;
const
ReadBuffer = 2400;
var
Security : TSecurityAttributes;
ReadPipe,WritePipe : THandle;
start : TStartUpInfo;
ProcessInfo : TProcessInformation;
Buffer : Pchar;
BytesRead : DWord;
Apprunning : DWord;
S: String;
begin
With Security do begin
nlength := SizeOf(TSecurityAttributes) ;
binherithandle := true;
lpsecuritydescriptor := nil;
end;
if Createpipe (ReadPipe, WritePipe,
#Security, 0) then
begin
Buffer := AllocMem(ReadBuffer + 1) ;
FillChar(Start,Sizeof(Start),#0) ;
start.cb := SizeOf(start) ;
start.hStdOutput := WritePipe;
start.hStdInput := ReadPipe;
start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
start.wShowWindow := SW_HIDE;
S:=UniqueString(DosApp);
if CreateProcess(nil,
PChar(S),
#Security,
#Security,
true,
NORMAL_PRIORITY_CLASS,
nil,
nil,
start,
ProcessInfo) then
begin
repeat
Apprunning := WaitForSingleObject
(ProcessInfo.hProcess,100) ;
Application.ProcessMessages;
until (Apprunning <> WAIT_TIMEOUT) ;
Repeat
BytesRead := 0;
ReadFile(ReadPipe,Buffer[0], ReadBuffer,BytesRead,nil) ;
Buffer[BytesRead]:= #0;
OemToAnsi(Buffer,Buffer) ;
AMemo.Text := AMemo.text + String(Buffer) ;
until (BytesRead < ReadBuffer) ;
end;
FreeMem(Buffer) ;
CloseHandle(ProcessInfo.hProcess) ;
CloseHandle(ProcessInfo.hThread) ;
CloseHandle(ReadPipe) ;
CloseHandle(WritePipe) ;
end;
end;
begin {button 1 code}
RunDosInMemo('cmd.exe /c dir',Memo1) ; //<-- this works
RunDosInMemo('"c:\consoleapp.exe" "/parameter"',Memo1) //<-- this hangs in the repeat until (Apprunning <> WAIT_TIMEOUT) ;
end;
It works for DOS commands, but it does not work for a console application. The console application starts and executes correctly but it hangs in the repeat until (Apprunning <> WAIT_TIMEOUT) loop. What could I try to solve the problem?
Thank you very much!
The program you're running is either expecting input (like from the keyboard) or producing more output than will fit in the pipe's buffer. In either case, that program hangs waiting for further I/O operations, but your parent program is waiting for that child to terminate before processing any output, and never provides any input.
You need to process the output pipe while the program is still running. Otherwise, you risk the buffer filling up, and the child will block until more space becomes available. Likewise, if you don't plan to provide any input to the other process, you probably shouldn't give it a valid input handle. That way, if it tries to read input, it will fail, rather than block.
Furthermore, the input handle you've given to that program is attached to the output handle. If the program attempts to read, it will be reading its own output, like an I/O ouroboros. To handle input and output, you need two pipes.
(Note that this deadlock is exactly the problem I called out in the comments of the answer you used. The second code block in the same answer addresses the problem, as well as the ouroboros problem.)
To summarize: #David Heffernan's code in Execute DOS program and get output dynamically works. The problem is that the console application emits UTF-16.
I have VCL application written in Delphi XE2 that needs to execute a command-line program (also written in Delphi XE2) and obtain the text output by it. I am currently using the following code, which is based on that found here: Getting output from a shell/dos app into a Delphi app
function GetDosOutput(ACommandLine : string; AWorkingDirectory : string): string;
var
SecurityAttributes : TSecurityAttributes;
StartupInfo : TStartupInfo;
ProcessInformation: TProcessInformation;
StdOutPipeRead, StdOutPipeWrite: THandle;
WasOK: Boolean;
Buffer: array[0..255] of AnsiChar;
BytesRead: Cardinal;
Handle: Boolean;
begin
Result := '';
SecurityAttributes.nLength := SizeOf(TSecurityAttributes);
SecurityAttributes.bInheritHandle := True;
SecurityAttributes.lpSecurityDescriptor := nil;
CreatePipe(StdOutPipeRead, StdOutPipeWrite, #SecurityAttributes, 0);
try
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
StartupInfo.cb := SizeOf(TStartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdInput := StdOutPipeRead;
StartupInfo.hStdOutput := StdOutPipeWrite;
StartupInfo.hStdError := StdOutPipeWrite;
FillChar(ProcessInformation, SizeOf(ProcessInformation), 0);
Handle := CreateProcess(
nil,
PChar(ACommandLine),
nil,
nil,
True,
0,
nil,
PChar(AWorkingDirectory),
StartupInfo,
ProcessInformation
);
CloseHandle(StdOutPipeWrite);
if Handle then
try
repeat
WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
if BytesRead > 0 then
begin
Buffer[BytesRead] := #0;
Result := Result + Buffer;
end;
until not WasOK or (BytesRead = 0);
WaitForSingleObject(ProcessInformation.hProcess, INFINITE);
finally
CloseHandle(ProcessInformation.hThread);
CloseHandle(ProcessInformation.hProcess);
end;
finally
CloseHandle(StdOutPipeRead);
end;
end;
This works fine on most versions of Windows. Unfortunately it has recently come to our attention that it does not work on Windows XP. The call to WaitForSingleObject simply never returns. I tried replacing the second parameter INFINITE with a smaller value (e.g. 15000) but that doesnt't seem to make any difference. In Task Manager I can see that, after calling GetDosOutput, the command-line program is actually running. If I end the VCL application, the command-line program then seems to complete its work successfully (as evidenced by the fact that it outputs the files I was expecting it to). I've also noticed that if I remove STARTF_USESTDHANDLES from StartupInfo.dwFlags, the command-line program runs normally and WaitForSingleObject returns promptly; however I am then obviously unable to obtain the text returned by the program.
Does anybody have a suggestion as to how I can get this working on Windows XP?
There is a really useful unit in freepascal called "process", which does just that, and, work has been done to port it to Delphi so you can capture the output of a command in Delphi using a simple one liner:
RunCommand()
Or you can capture the output of the command with more advanced features by creating a TProcess object yourself (which RunCommand just wraps).
The project is here:
https://github.com/z505/TProcess-Delphi
A simple demo: https://github.com/z505/TProcess-Delphi/tree/master/demo-simple
How to capture the output of a command, i.e. "dir" (list directory contents, famous MS DOS command) into a string then add it to a memo:
uses
dprocess;
// ...
var
output: ansistring;
begin
RunCommand('cmd', ['/c', 'dir'], output, [poNoConsole]);
memo1.Lines.Add(output);
end;
I am using this non visual open source component called TProcessInfo to get a list of processes, the ProcessID and the full path which I put into a ListView.
The code I am using to do this:
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
Process: TProcessItem;
begin
for i := 0 to ProcessInfo1.RunningProcesses.Count -1 do
begin
Process := ProcessInfo1.RunningProcesses[i];
with lv.Items.Add do
begin
Caption := Process.ExeFile;
SubItems.Add(IntToStr(Process.ProcessID));
SubItems.Add(Process.FullPath);
end;
end;
end;
The code will always break on the last line: SubItems.Add(Process.FullPath); and I receive an Error Message:
System Error. Code: 87The Parameter is incorrect.
The code that gets the FullPath in the Component is:
function TProcessItem.GetFullPath: TFileName;
var
hProcess: THandle;
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,False,FProcessID);
if hProcess <> 0 then
begin
try
SetLength(Result,MAX_PATH);
FillChar(Result[1],Length(Result) * SizeOf(Char), 0);
if GetModuleFileNameEx(hProcess,0,PChar(Result),Length(Result)) > 0 then
Result := Trim(Result)
else
RaiseLastOSError;
finally
CloseHandle(hProcess)
end;
end
else
RaiseLastOSError;
end;
If like the Error states - the parameter is incorrect, then how can I change this?
** The component uses PsAPI and I am using Delphi XE2 on Windows 7 Ultimate x64 also happens on Windows XP Pro x86
This happens because "System Idle Process" has PID = 0 and OpenProcess fails with such a ProcessID value. Patch the library to avoid using it or uset try/except in your loop.
I'm trying to pass information between two of my applications in Delphi 2010.
I'm using a simplified version of code that I've used successfully in the past (simplified because I don't need the sender to know that the send has been successful) I've boiled down the send received to a pair of example applications, which in essence are as follows
Send
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
s := ebFirm.Text;
copyDataStruct.cbData := 1 + length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: THandle;
res: integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application
ShellExecute(Handle, 'open', GetPhone, nil, nil, SW_SHOWNORMAL);
// Give time for the application to launch
Sleep(3000);
SendData(copyDataStruct); // RECURSION!
end;
SendMessage(rh, WM_COPYDATA, Integer(Handle), Integer(#copyDataStruct));
end;
Receive Application
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
s := PAnsiChar(Msg.CopyDataStruct.lpData) ;
jobstatus.Panels[1].Text := s;
end;
The major difference between the working test applications and the application I am adding the code to is that there is a lot of extra activity going on in target application. Especially on startup.
Any suggestions on why the WMCopyData procedure seems not to be firing at all?
CHeers
Dan
There are a few problems with your code.
One, you are not assigning a unique ID to the message. The VCL, and various third-party components, also use WM_COPYDATA, so you have to make sure you are actually processing YOUR message and not SOMEONE ELSE'S message.
Two, you may not be waiting long enough for the second app to start. Instead of Sleep(), use ShellExecuteEx() with the SEE_MASK_WAITFORINPUTIDLE flag (or use CreateProcess() and WaitForInputIdle()).
Third, when starting the second app, your recursive logic is attempting to send the message a second time. If that happened to fail, you would launch a third app, and so on. You should take out the recursion altogether, you don't need it.
Try this:
var
GetPhoneMsg: DWORD = 0;
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
if GetPhoneMsg = 0 then Exit;
s := ebFirm.Text;
copyDataStruct.dwData := GetPhoneMsg;
copyDataStruct.cbData := Length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: HWND;
si: TShellExecuteInfo;
res: Integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application and give time to start
ZeroMemory(#si, SizeOf(si));
si.cbSize := SizeOf(si);
si.fMask := SEE_MASK_WAITFORINPUTIDLE;
si.hwnd := Handle;
si.lpVerb := 'open';
si.lpFile := GetPhone;
si.nShow := SW_SHOWNORMAL;
if not ShellExecuteEx(#si) then Exit;
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then Exit;
end;
SendMessage(rh, WM_COPYDATA, WParam(Handle), LParam(#copyDataStruct));
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
Receive Application
var
GetPhoneMsg: DWORD = 0;
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
if (GetPhoneMsg <> 0) and (Msg.CopyDataStruct.dwData = GetPhoneMsg) then
begin
SetString(s, PAnsiChar(Msg.CopyDataStruct.lpData), Msg.CopyDataStruct.cbData);
jobstatus.Panels[1].Text := s;
end else
inherited;
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
I think it is a good habit to add
copyDataStruct.dwData := Handle;
in procedure TMF.SendString; - if you don't have a custom identifier, putting the source HWND value will help debugging on the destination (you can check for this value in the other side, and therefore avoid misunderstand of broadcasted WMCOPY_DATA e.g. - yes, there should not be, but I've seen some!).
And
procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;
in TMF client class definition, right?
There should be a missing exit or else after the nested SendData call:
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
(...)
Sleep(3000);
SendData(copyDataStruct);
end else
SendMessage(rh, WM_COPYDATA, NativeInt(Handle), NativeInt(#copyDataStruct));
end;
But this won't change much.
Check the rh := FindWindow() returned handle: is it the Handle of the TMF client form, or the Application.Handle?
It doesn't work anymore if you are using Windows 7.
If you are using it, check this page to see how to add an exception: http://msdn.microsoft.com/en-us/library/ms649011%28v=vs.85%29.aspx
I thought there was a problem with the (rh) handle being 0 when you call it, if the app needed to be started. But now I see that SendData calls itself recursively. I added a comment in the code for that, as it was non-obvious. But now there's another problem. The 2nd instance of SendData will have the right handle. But then you're going to pop out of that, back into the first instance where the handle is still 0, and then you WILL call SendMessage again, this time with a 0 handle. This probably is not the cause of your trouble, but it's unintended, unnecessary, and altogether bad. IMO, this is a case complicating things by trying to be too clever.