Delphi 6 Prof, Win7 OS.
I have this code to get the file size by URL:
function TDDWIToolObject.GetFileSize(out Size: Int64): boolean;
var
hInet: HINTERNET;
hRequest : HINTERNET;
lpdwBufferLength: DWORD;
lpdwReserved : DWORD;
ServerName: string;
Resource: string;
FileSizeBuffer : array[0..32] of char;
//SizeCard : Cardinal;
begin
ParseURL(Url, ServerName, Resource);
Result := False;
Size := 0;
hInet := InternetOpen(PChar(_UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hInet=nil then begin
FErrorCode := GetLastError;
Exit;
end;
try
hRequest := InternetOpenUrl(hInet, PChar(URL), PCHar(Headers), Length(HEaders), 0, 0);
try
FillChar(FileSizeBuffer, SizeOf(FileSizeBuffer), #0);
lpdwBufferLength := SizeOf(FileSizeBuffer);
lpdwReserved :=0;
if not HttpQueryInfo(
hRequest,
HTTP_QUERY_CONTENT_LENGTH,
#FileSizeBuffer, lpdwBufferLength, lpdwReserved) then begin
FErrorCode:=GetLastError;
Exit;
end;
Size := StrToInt64(StrPas(FileSizeBuffer));
Result := True;
finally
InternetCloseHandle(hRequest);
end;
finally
InternetCloseHandle(hInet);
end;
end;
It is working good with my machine + DSL connection.
But when I check this code in other place which is fully protected (proxy + many policies) then I get error code 12150... :-(
What is interesting, that I can download this file, when I use this code:
function TDDWIToolObject.DownloadFile;
var
hInet: HINTERNET;
hFile: HINTERNET;
pbuffer: Pointer;
bytesRead: DWORD;
Stm : TFileStream;
TotalBytes : Int64;
AbortIt : boolean;
begin
Result := False;
FErrorCode := -1;
FAborted := False;
hInet := InternetOpen(PChar(_UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hInet = nil
then begin
FErrorCode := GetLastError;
Exit;
end;
try
hFile := InternetOpenURL(hInet, PChar(URL), PChar(FHeaders), Length(FHeaders), 0, 0);
if hFile = nil
then begin
FErrorCode := GetLastError;
Exit;
end;
try
Stm := TFileStream.Create(FN, fmCreate);
try
GetMem(pbuffer, FBufferSize);
try
TotalBytes := 0; AbortIt := False;
while (not FAborted) do begin
if not InternetReadFile(hFile, pbuffer, FBufferSize, bytesRead) then begin
FErrorCode := GetLastError;
Exit;
end;
if bytesRead > 0 then begin
Stm.WriteBuffer(pbuffer^, bytesRead);
if Assigned(FOnBytesArrived)
then begin
inc(TotalBytes, bytesRead);
FOnBytesArrived(Self, TotalBytes, AbortIt);
if AbortIt
then Abort;
end;
end else begin
break;
end;
end;
finally
FreeMem(pbuffer);
end;
if not FAborted
then Result := True;
finally
Stm.Free;
end;
finally
InternetCloseHandle(hFile);
end;
finally
InternetCloseHandle(hInet);
end;
end;
It is interesting because sysadmin allowed the requests to this URL in proxy, and the downloads work for me - only the content length requests fail.
I want to ask one question, but it is hard to do, because many of them is in my mind...
Do you have some idea what we can do to allow the requests?
Maybe HttpRequest uses another port, or some "illegal" what isn't proxiable?
Or my code is seems to be wrong? Why it is working in nonprotected area? What are the differents between download and get content length requests?
So the question is as in summarized format: do you have some idea what can I do to I get the file size before downloading?
Thanks for it.
This error can be caused by many factors (ERROR_HTTP_HEADER_NOT_FOUND), in your code you are not checking the result of the InternetOpenUrl function before to call the HttpQueryInfo method, and I don't see the content of the _UserAgent and Headers variables to give you a more exact answer. Anyway try using the HttpOpenRequest and HttpSendRequest functions instead of InternetOpenURL.
Try this sample
uses
Windows,
SysUtils,
WinInet;
const
sUserAgent = 'Mozilla/5.001 (windows; U; NT4.0; en-US; rv:1.0) Gecko/25250101';
function GetWinInetError(ErrorCode:Cardinal): string;
const
winetdll = 'wininet.dll';
var
Len: Integer;
Buffer: PChar;
begin
Len := FormatMessage(
FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY,
Pointer(GetModuleHandle(winetdll)), ErrorCode, 0, #Buffer, SizeOf(Buffer), nil);
try
while (Len > 0) and {$IFDEF UNICODE}(CharInSet(Buffer[Len - 1], [#0..#32, '.'])) {$ELSE}(Buffer[Len - 1] in [#0..#32, '.']) {$ENDIF} do Dec(Len);
SetString(Result, Buffer, Len);
finally
LocalFree(HLOCAL(Buffer));
end;
end;
procedure ParseURL(const lpszUrl: string; var Host, Resource: string);
var
lpszScheme : array[0..INTERNET_MAX_SCHEME_LENGTH - 1] of Char;
lpszHostName : array[0..INTERNET_MAX_HOST_NAME_LENGTH - 1] of Char;
lpszUserName : array[0..INTERNET_MAX_USER_NAME_LENGTH - 1] of Char;
lpszPassword : array[0..INTERNET_MAX_PASSWORD_LENGTH - 1] of Char;
lpszUrlPath : array[0..INTERNET_MAX_PATH_LENGTH - 1] of Char;
lpszExtraInfo : array[0..1024 - 1] of Char;
lpUrlComponents : TURLComponents;
begin
ZeroMemory(#lpszScheme, SizeOf(lpszScheme));
ZeroMemory(#lpszHostName, SizeOf(lpszHostName));
ZeroMemory(#lpszUserName, SizeOf(lpszUserName));
ZeroMemory(#lpszPassword, SizeOf(lpszPassword));
ZeroMemory(#lpszUrlPath, SizeOf(lpszUrlPath));
ZeroMemory(#lpszExtraInfo, SizeOf(lpszExtraInfo));
ZeroMemory(#lpUrlComponents, SizeOf(TURLComponents));
lpUrlComponents.dwStructSize := SizeOf(TURLComponents);
lpUrlComponents.lpszScheme := lpszScheme;
lpUrlComponents.dwSchemeLength := SizeOf(lpszScheme);
lpUrlComponents.lpszHostName := lpszHostName;
lpUrlComponents.dwHostNameLength := SizeOf(lpszHostName);
lpUrlComponents.lpszUserName := lpszUserName;
lpUrlComponents.dwUserNameLength := SizeOf(lpszUserName);
lpUrlComponents.lpszPassword := lpszPassword;
lpUrlComponents.dwPasswordLength := SizeOf(lpszPassword);
lpUrlComponents.lpszUrlPath := lpszUrlPath;
lpUrlComponents.dwUrlPathLength := SizeOf(lpszUrlPath);
lpUrlComponents.lpszExtraInfo := lpszExtraInfo;
lpUrlComponents.dwExtraInfoLength := SizeOf(lpszExtraInfo);
InternetCrackUrl(PChar(lpszUrl), Length(lpszUrl), ICU_DECODE or ICU_ESCAPE, lpUrlComponents);
Host := lpszHostName;
Resource := lpszUrlPath;
end;
function GetRemoteFileSize(const Url : string): Integer;
var
hInet : HINTERNET;
hConnect : HINTERNET;
hRequest : HINTERNET;
lpdwBufferLength: DWORD;
lpdwReserved : DWORD;
ServerName: string;
Resource: string;
ErrorCode : Cardinal;
begin
ParseURL(Url,ServerName,Resource);
Result:=0;
hInet := InternetOpen(PChar(sUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hInet=nil then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
try
hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
if hConnect=nil then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
try
hRequest := HttpOpenRequest(hConnect, PChar('HEAD'), PChar(Resource), nil, nil, nil, 0, 0);
if hRequest<>nil then
begin
try
lpdwBufferLength:=SizeOf(Result);
lpdwReserved :=0;
if not HttpSendRequest(hRequest, nil, 0, nil, 0) then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
if not HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, #Result, lpdwBufferLength, lpdwReserved) then
begin
Result:=0;
ErrorCode:=GetLastError;
raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
finally
InternetCloseHandle(hRequest);
end;
end
else
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
finally
InternetCloseHandle(hConnect);
end;
finally
InternetCloseHandle(hInet);
end;
end;
Related
I am a Delphi developer in our company. We need a function which launches a command-line executable and get its return value.
The code I wrote, and all the examples I found on the Internet, do this via CreateProcess(), but my boss rejected this and told me that there MUST be a solution doing this via ShellExecute(). I can't find any example on the Internet doing this with ShellExecute(). All of them use CreateProcess().
Below are 3 methods I delivered to my boss. He did not like ShellExecute_AndGetReturnValue(). It's named "ShellExecute", but it does not use ShellExecute().
All of these 3 methods are working fine. But the first one is not using ShellExecute(). Instead it is using CreateProcess().
So, is it possible to solve/change the ShellExecute_AndGetReturnValue() method so that it will use ShellExecute() instead of CreateProcess()? All examples I found, all of them, use CreateProcess().
function ShellExecute_AndGetReturnValue(FileName : string; Params : string = ''; Show : Integer = SW_HIDE; WorkingDir : string = '') : string;
const
READ_BUFFER_SIZE = 2048;
var
Security: TSecurityAttributes;
readableEndOfPipe, writeableEndOfPipe, readableErrorEndOfPipe, writeableErrorEndOfPipe: THandle;
start: TStartUpInfo;
ProcessInfo: TProcessInformation;
Buffer: PAnsiChar;
BytesRead: DWORD;
AppRunning: DWORD;
ResultStdOutput : string;
ResultErrOutput : string;
lpDirectory : PAnsiChar;
CmdLine : string;
begin
Result := '';
Security.nLength := SizeOf(TSecurityAttributes);
Security.bInheritHandle := True;
Security.lpSecurityDescriptor := nil;
if CreatePipe(readableEndOfPipe, writeableEndOfPipe, #Security, 0) then
begin
Buffer := AllocMem(READ_BUFFER_SIZE + 1);
FillChar(Start, Sizeof(Start), #0);
FillChar(ProcessInfo, SizeOf(ProcessInfo), #0);
start.cb := SizeOf(start);
start.dwFlags := start.dwFlags or STARTF_USESTDHANDLES;
start.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
start.hStdOutput := writeableEndOfPipe;
CreatePipe(readableErrorEndOfPipe, writeableErrorEndOfPipe, #Security, 0);
start.hStdError := writeableErrorEndOfPipe;
start.hStdError := writeableEndOfPipe;
start.dwFlags := start.dwFlags + STARTF_USESHOWWINDOW;
start.wShowWindow := Show;
UniqueString(FileName);
CmdLine := '"' + FileName + '" ' + Params;
if WorkingDir <> '' then
begin
lpDirectory := PAnsiChar(WorkingDir);
end else
begin
lpDirectory := PAnsiChar(ExtractFilePath(FileName));
end;
if CreateProcess(nil, PChar(CmdLine), nil, nil, True, NORMAL_PRIORITY_CLASS, nil, lpDirectory, start, ProcessInfo) then
begin
repeat
Apprunning := WaitForSingleObject(ProcessInfo.hProcess, 100);
Application.ProcessMessages;
until (Apprunning <> WAIT_TIMEOUT);
ResultStdOutput := '';
ResultErrOutput := '';
//Must Close write Handles before reading (if the console application does not output anything)
CloseHandle(writeableEndOfPipe);
CloseHandle(writeableErrorEndOfPipe);
repeat
BytesRead := 0;
ReadFile(readableEndOfPipe, Buffer[0], READ_BUFFER_SIZE, BytesRead, nil);
Buffer[BytesRead]:= #0;
OemToAnsi(Buffer,Buffer);
ResultStdOutput := ResultStdOutput + String(Buffer);
until (BytesRead < READ_BUFFER_SIZE);
if start.hStdOutput <> start.hStdError then
begin
BytesRead := 0;
ReadFile(readableErrorEndOfPipe, Buffer[0], READ_BUFFER_SIZE, BytesRead, nil);
Buffer[BytesRead]:= #0;
OemToAnsi(Buffer,Buffer);
ResultErrOutput := ResultErrOutput + String(Buffer);
end;
end;
Result := ResultStdOutput;
FreeMem(Buffer);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(readableEndOfPipe);
CloseHandle(readableErrorEndOfPipe);
end;
end;
procedure ShellExecute_NoWait(FileName : string; Params : string = ''; Action : string = 'open'; Show : Integer = SW_SHOWNORMAL; WorkingDir : string = '');
var
exInfo: TShellExecuteInfo;
Ph: DWORD;
begin
FillChar(exInfo, SizeOf(exInfo), 0);
with exInfo do
begin
cbSize := SizeOf(exInfo);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := GetActiveWindow();
lpVerb := PAnsiChar(Action);
lpParameters := PChar(Params);
lpFile := PChar(FileName);
nShow := Show;
if WorkingDir <> '' then
begin
lpDirectory := PAnsiChar(WorkingDir);
end else
begin
lpDirectory := PAnsiChar(ExtractFilePath(FileName));
end;
end;
if ShellExecuteEx(#exInfo) then
begin
Ph := exInfo.HProcess;
CloseHandle(Ph);
end;
end;
procedure ShellExecute_AndWait(FileName : string; Params : string = ''; Action : string = 'open'; Show : Integer = SW_SHOWNORMAL; WorkingDir : string = '');
var
exInfo: TShellExecuteInfo;
Ph: DWORD;
begin
FillChar(exInfo, SizeOf(exInfo), 0);
with exInfo do
begin
cbSize := SizeOf(exInfo);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := GetActiveWindow();
lpVerb := PAnsiChar(Action);
lpParameters := PChar(Params);
lpFile := PChar(FileName);
nShow := Show;
if WorkingDir <> '' then
begin
lpDirectory := PAnsiChar(WorkingDir);
end else
begin
lpDirectory := PAnsiChar(ExtractFilePath(FileName));
end;
end;
if ShellExecuteEx(#exInfo) then
begin
Ph := exInfo.HProcess;
while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
begin
Application.ProcessMessages;
end;
CloseHandle(Ph);
end;
end;
Task from your boss is not fully correct. Problem is that the generic solution of ShellExecute – is not start cmd.exe, this command starts an application that is linked to this type of file and starts it. So, to make it work like you want – it needs a lot of work.
One more thing – do you need to get the result of work of your program or console output of your program?
Here is modified part of sources from jcl library to return return code:
function PCharOrNil(const S: string): PChar;
begin
Result := Pointer(S);
end;
// memory initialization
procedure ResetMemory(out P; Size: Longint);
begin
if Size > 0 then
begin
Byte(P) := 0;
FillChar(P, Size, 0);
end;
end;
function ShellExecAndWait(const FileName: string; const Parameters: string;
const Verb: string; CmdShow: Integer; const Directory: string): cardinal;
var
Sei: TShellExecuteInfo;
Res: LongBool;
Msg: tagMSG;
ShellResult : boolean;
begin
ResetMemory(Sei, SizeOf(Sei));
Sei.cbSize := SizeOf(Sei);
Sei.fMask := SEE_MASK_DOENVSUBST or SEE_MASK_FLAG_NO_UI or SEE_MASK_NOCLOSEPROCESS or
SEE_MASK_FLAG_DDEWAIT or SEE_MASK_NOASYNC;
Sei.lpFile := PChar(FileName);
Sei.lpParameters := PCharOrNil(Parameters);
Sei.lpVerb := PCharOrNil(Verb);
Sei.nShow := CmdShow;
Sei.lpDirectory := PCharOrNil(Directory);
{$TYPEDADDRESS ON}
ShellResult := ShellExecuteEx(#Sei);
{$IFNDEF TYPEDADDRESS_ON}
{$TYPEDADDRESS OFF}
{$ENDIF ~TYPEDADDRESS_ON}
if ShellResult then begin
WaitForInputIdle(Sei.hProcess, INFINITE);
while WaitForSingleObject(Sei.hProcess, 10) = WAIT_TIMEOUT do
repeat
Msg.hwnd := 0;
Res := PeekMessage(Msg, Sei.Wnd, 0, 0, PM_REMOVE);
if Res then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
until not Res;
if not GetExitCodeProcess(Sei.hProcess, Result) then
raise Exception.Create('GetExitCodeProcess fail');
CloseHandle(Sei.hProcess);
end else begin
raise Exception.Create('ShellExecuteEx fail');
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
xResult : cardinal;
begin
xResult := ShellExecAndWait('ping.exe', '', '', 1, ''); //xResult = 1
xResult := ShellExecAndWait('ping.exe', '8.8.8.8', '', 1, ''); //xResult = 0
end;
If you need to specify input/output pipes (to control stdin and stdout of the called process) then ShellExecute cannot be used. It simply does not support specifying these. Neither does ShellExecuteEx.
So the only option you have if you must use ShellExecute is to ShellExecute the command processor (CMD.EXE) and ask it to perform the redirection of input and output. This will limit your redirection source and target to physical files on the disk, as that's the way CMD.EXE allows redirection (>StdOut <StdIn).
Othwewise, your approach with CreateProcess is the way forward. What does your boss give as reason that you must use ShellExecute?
If you don't need redirection support, you can use ShellExecuteEx and then after a successful execution, you can obtain the Handle to the running process in Info.hProcess (Info is the TShellExecuteInfo structure passed to ShellExecuteEx).
This value can then be used in GetExitCodeProcess to determine if the process is still running, or if it has terminated (and you have thus retrieved the "Return Value", if I have correctly understood your use of this expression - it's actually called an "ExitCode", or - in batch files - an "ERRORLEVEL").
Incomplete code:
FUNCTION ShellExecuteAndWait(....) : DWORD;
.
.
VAR Info : TShellExecuteInfo;
.
.
Info.fMask:=Info.fMask OR SEE_MASK_NOCLOSEPROCESS;
IF NOT ShellExecuteEx(Info) THEN EXIT($FFFF8000);
IF Info.hProcess=0 THEN EXIT($FFFF0000);
REPEAT
IF NOT GetExitCodeProcess(Info.hProcess,Result) THEN EXIT($FFFFFFFF)
UNTIL Result<>STILL_ACTIVE
.
.
The above code should demonstrate how to do this...
Hi I have the following code:
procedure TformInvoiceDetails.ReadWebImage(imgAddress: string);
var
memStream: TMemoryStream;
begin
memStream := TMemoryStream.Create;
try
IdHTTP1.Get (imgAddress,memStream);
//sleep(5000);
except
imageContProduct.Visible := false;
ShowMessage('Image not found at:'+imgAddress);
memStream.Free;
exit;
end;
try
memStream.Position := 0;
imageContProduct.Visible := true;
imageContProduct.Bitmap.LoadFromStream(memStream);
finally
memStream.Free;
end;
end;
Most of the time it works okay but I keep getting an exeption error and sometimes a 'Image not found at' ( although the image does exist).
If I put the sleep(5000) everything works okay.
So I am presuming the image has not been recived before I try and add to the TImage.
Is there a better method to use ?
You can use another components to load pictures:
uses WinInet, JPEG;
...
function DownloadToStream(Url: string; Stream: TStream): Boolean;
var
hNet: HINTERNET;
hUrl: HINTERNET;
Buffer: array[0..10240] of Char;
BytesRead: DWORD;
begin
Result := FALSE;
hNet := InternetOpen('agent', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if (hNet <> nil) then
begin
hUrl := InternetOpenUrl(hNet, PChar(Url), nil, 0,
INTERNET_FLAG_RELOAD, 0);
if (hUrl <> nil) then
begin
while (InternetReadFile(hUrl, #Buffer, sizeof(Buffer), BytesRead)) do
begin
if (BytesRead = 0) then
begin
Result := TRUE;
break;
end;
Stream.WriteBuffer(Buffer,BytesRead);
end;
InternetCloseHandle(hUrl);
end;
InternetCloseHandle(hNet);
end;
end;
procedure TformInvoiceDetails.ReadWebImage(imgAddress: string);
var
memStream: TMemoryStream;
Jpg:= TJPEGImage;
begin
memStream:= TMemoryStream.Create;
try
if DownloadToStream(imgAddress, memStream) then
begin
memStream.Seek(0, soFromBeginning);
if (LowerCase(RightStr(imgAddress, 4))='.jpg') or (LowerCase(RightStr(imgAddress, 5))='.jpeg')
try //do the same operation for *.png
Jpg:= TJPEGImage.Create;
Jpg.LoadFromStream(memStream);
imageContProduct.Picture.Bitmap.Assign(Jpg);
imageContProduct.Visible := true;
finally
Jpg.Free;
end
else
try
imageContProduct.Picture.Bitmap.LoadFromStream(memStream);
imageContProduct.Visible := true;
finally
end;
end;
finally
memStream.Free;
end;
end;
I'm trying to get PIDs of processes which belongs to the current user but I don't know how to check the process owner.
This is my code (the user's checking condition is missing):
uses
TlHelp32, ...;
type
TCardinalArray = array of Cardinal;
function GetCurrentUserPIDs(const AProcessName : string) : TCardinalArray;
var
ContinueLoop: boolean;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
SetLength(Result, 0);
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while(ContinueLoop) do
begin
if(SameText(FProcessEntry32.szExeFile, AProcessName)) then
begin
if((* is this my process? *)) then
begin
SetLength(Result, Length(Result) + 1);
Result[Length(Result) - 1] := FProcessEntry32.th32ProcessID;
end;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
I found a GetUserAndDomainFromPID function which allows to easily accomplish the task.
As Sertac Akyuz suggested, the function uses OpenProcessToken and GetTokenInformation. It also uses LookupAccountSid:
uses
TlHelp32;
type
PTOKEN_USER = ^TOKEN_USER;
_TOKEN_USER = record
User: TSidAndAttributes;
end;
TOKEN_USER = _TOKEN_USER;
function GetUserAndDomainFromPID(ProcessId: DWORD;
var User, Domain: string): Boolean;
var
hToken: THandle;
cbBuf: Cardinal;
ptiUser: PTOKEN_USER;
snu: SID_NAME_USE;
ProcessHandle: THandle;
UserSize, DomainSize: DWORD;
bSuccess: Boolean;
begin
Result := False;
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
if ProcessHandle <> 0 then
begin
// EnableProcessPrivilege(ProcessHandle, 'SeSecurityPrivilege', True);
if OpenProcessToken(ProcessHandle, TOKEN_QUERY, hToken) then
begin
bSuccess := GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf);
ptiUser := nil;
while (not bSuccess) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) do
begin
ReallocMem(ptiUser, cbBuf);
bSuccess := GetTokenInformation(hToken, TokenUser, ptiUser, cbBuf, cbBuf);
end;
CloseHandle(hToken);
if not bSuccess then
begin
Exit;
end;
UserSize := 0;
DomainSize := 0;
LookupAccountSid(nil, ptiUser.User.Sid, nil, UserSize, nil, DomainSize, snu);
if (UserSize <> 0) and (DomainSize <> 0) then
begin
SetLength(User, UserSize);
SetLength(Domain, DomainSize);
if LookupAccountSid(nil, ptiUser.User.Sid, PChar(User), UserSize,
PChar(Domain), DomainSize, snu) then
begin
Result := True;
User := StrPas(PChar(User));
Domain := StrPas(PChar(Domain));
end;
end;
if bSuccess then
begin
FreeMem(ptiUser);
end;
end;
CloseHandle(ProcessHandle);
end;
end;
Then I've written a function for getting the current windows username (It uses GetUserName):
const
UNLEN = 256; // Maximum user name length
function GetWindowsUsername: string;
var
UserName : string;
UserNameLen : Dword;
begin
UserNameLen := UNLEN;
SetLength(UserName, UserNameLen) ;
if GetUserName(PChar(UserName), UserNameLen)
then Result := Copy(UserName, 1, UserNameLen - 1)
else Result := '';
end;
The following function returns an array composed by all ids of processes who belongs to the current user (Note that processes are filtered by process name):
uses
TlHelp32;
type
TCardinalArray = array of Cardinal;
function GetCurrentUserPIDs(const AProcessName : string) : TCardinalArray;
var
ContinueLoop: boolean;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
UserName : string;
DomainName : string;
CurrentUser : string;
begin
CurrentUser := GetWindowsUsername();
SetLength(Result, 0);
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while(ContinueLoop) do
begin
if(SameText(FProcessEntry32.szExeFile, AProcessName)) then
begin
if(GetUserAndDomainFromPID(FProcessEntry32.th32ProcessID, UserName, DomainName)) then
begin
if(UserName = CurrentUser) then
begin
SetLength(Result, Length(Result) + 1);
Result[Length(Result) - 1] := FProcessEntry32.th32ProcessID;
end;
end;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
I don't care whether it is a string, stringlist, memo, etc ... but not a disk file
How do I download a compete web page into a variable? Thanks
Using Indy:
uses IdHTTP;
const
HTTP_RESPONSE_OK = 200;
function GetPage(aURL: string): string;
var
Response: TStringStream;
HTTP: TIdHTTP;
begin
Result := '';
Response := TStringStream.Create('');
try
HTTP := TIdHTTP.Create(nil);
try
HTTP.Get(aURL, Response);
if HTTP.ResponseCode = HTTP_RESPONSE_OK then begin
Result := Response.DataString;
end else begin
// TODO -cLogging: add some logging
end;
finally
HTTP.Free;
end;
finally
Response.Free;
end;
end;
Using the native Microsoft Windows WinInet API:
function WebGetData(const UserAgent: string; const URL: string): string;
var
hInet: HINTERNET;
hURL: HINTERNET;
Buffer: array[0..1023] of AnsiChar;
BufferLen: cardinal;
begin
result := '';
hInet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hInet = nil then RaiseLastOSError;
try
hURL := InternetOpenUrl(hInet, PChar(URL), nil, 0, 0, 0);
if hURL = nil then RaiseLastOSError;
try
repeat
if not InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen) then
RaiseLastOSError;
result := result + UTF8Decode(Copy(Buffer, 1, BufferLen))
until BufferLen = 0;
finally
InternetCloseHandle(hURL);
end;
finally
InternetCloseHandle(hInet);
end;
end;
Try it:
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Text := WebGetData('My Own Client', 'http://www.bbc.co.uk')
end;
But this only works if the encoding is UTF-8. So, to make it work in other cases, you either have to handle these separately, or you can use the Indy high-level wrappers, as suggested by Marjan. I admit they are superior in this case, but I still want to promote the underlying API, if for no other reason than educational...
I have the follow function that creates a process:
function .CreateProcess(aAppletPath: string; var aError : string; aProcessInfo: TProcessInformation): Boolean;
var
StartInfo: TStartupInfo;
begin
FillChar(StartInfo, SizeOf(TStartupInfo),#0);
FillChar(aProcessInfo, SizeOf(TProcessInformation),#0);
StartInfo.cb := SizeOf(TStartupInfo);
if False then begin
StartInfo.dwFlags := STARTF_USESHOWWINDOW;
StartInfo.wShowWindow := SW_HIDE;
end;
if Windows.CreateProcess(nil, PChar(aAppletPath), nil, nil, False, CREATE_NEW_PROCESS_GROUP + NORMAL_PRIORITY_CLASS, nil, nil, StartInfo, aProcessInfo) then begin
Result := True;
WaitForInputIdle(aProcessInfo.hProcess, oTimeOutSecs * 1000);
end
else begin
Result := False;
end;
end;
And I have this method that waits the app terminates:
function WaitForProcessTerminate(aHandle: THandle) : Boolean;
var
vResult : LongWord;
Msg: TMsg;
PHandles: Pointer;
begin
vResult := 0;
PHandles := #aHandle;
PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE);
while True do begin
vResult := Windows.MsgWaitForMultipleObjects(1, PHandles^, False, oTimeOutSecs * 1000, QS_ALLINPUT);
if vResult = WAIT_OBJECT_0 + 1 then begin
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end
else begin
Break;
end;
end;
case vResult of
WAIT_ABANDONED: Result := False;
WAIT_OBJECT_0: Result := True;
WAIT_TIMEOUT: Result := False;
else begin
Result := False;
end;
end;
if not Result then begin
ShowMessage(SystemErrorMessage);
end;
end;
The problem is that the wait function is always returning WAIT_FAILED with the Access denied message. What am I doing wrong? This code is Delphi 2010 and the app i am calling is a java app.
Nevermind guys. It was my mistake. The function:
function .CreateProcess(aAppletPath: string; var aError : string; aProcessInfo: TProcessInformation): Boolean;
should be:
function .CreateProcess(aAppletPath: string; var aError : string; var {should be var!!} aProcessInfo: TProcessInformation): Boolean;
My apologies.