Process run using CreateProcess failed due to "Access denied" - delphi

I'm new to Delphi, and have developed a small GUI application that runs innounp (which disassembles Inno setup installers) with selected parameters and captures the output into Memo.
I used this procedure (from here)
procedure RunProcessAndCaptureOutput(const CmdLine: string; Memo: TMemo; HideLinesCount: Integer = 0);
var
SecAttr: TSecurityAttributes;
PipeR, PipeW: THandle;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
Buffer: packed array[0..4096-1] of AnsiChar;
Count: Cardinal;
S, Leftover: AnsiString;
i, P: Cardinal;
C: AnsiChar;
begin
SecAttr.nLength:=SizeOf(SecAttr);
SecAttr.lpSecurityDescriptor:=nil;
SecAttr.bInheritHandle:=True;
if not CreatePipe(PipeR, PipeW, #SecAttr, 0) then
raise Exception.Create('CreatePipe: '+SysErrorMessage(GetLastError));
SetHandleInformation(PipeR, HANDLE_FLAG_INHERIT, 0);
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb:=SizeOf(StartupInfo);
StartupInfo.dwFlags:=STARTF_USESTDHANDLES;
StartupInfo.hStdOutput:=PipeW;
StartupInfo.hStdError:=PipeW;
FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);
if not CreateProcess(nil, PChar(CmdLine), nil, nil, True, CREATE_NO_WINDOW, nil, nil, StartupInfo, ProcessInfo) then
raise Exception.Create('CreateProcess: '+SysErrorMessage(GetLastError));
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(PipeW);
Leftover:='';
while ReadFile(PipeR, Buffer[0], SizeOf(Buffer)-1, Count, nil) and (Count > 0) do
begin
Buffer[Count]:=#0;
i:=0;
P:=0;
while i < Count do
begin
C:=Buffer[i];
if C in [#10, #13] then
begin
if HideLinesCount > 0 then
Dec(HideLinesCount)
else
begin
Buffer[i]:=#0;
S:=Leftover+AnsiString(PAnsiChar(#Buffer[P]));
OemToCharBuffA(#S[1], #S[1], Length(S));
Memo.Lines.Add(string(S));
end;
Leftover:='';
case C of
#10: if Buffer[i+1] = #13 then Inc(i);
#13: if Buffer[i+1] = #10 then Inc(i);
end;
P:=i+1;
end;
Inc(i);
end;
Leftover:=AnsiString(PAnsiChar(#Buffer[P]));
Application.ProcessMessages;
end;
if (Leftover <> '') and (HideLinesCount <= 0) then
begin
OemToCharBuffA(#Leftover[1], #Leftover[1], Length(Leftover));
Memo.Lines.Add(string(Leftover));
end;
CloseHandle(PipeR);
end;
It seems to be working (the innounp program is running, and the output appears inside the Memo) but after extracting one file the program displays an error "access denied" and does not continue to extract.
Can anyone help me understand why?

Related

Win7 IE11 IShellWindows returns 'Unknown Error' only on some machines

I use the following code to check, if there already exists an Internet Explorer 11 Tab with a given Url Location.
I started with code from here: http://francois-piette.blogspot.de/2013/01/internet-explorer-automation-part-1.html
function GetIERunningInstanceByUrl(FLogWriter: ILogWriter; const Url : String): IWebBrowser2;
function GetClassName(aHWND : HWND) : String;
var
L : Integer;
begin
SetLength(Result, MAX_PATH * SizeOf(Char));
L := WinApi.Windows.GetClassName(aHWND, PChar(Result), Length(Result));
SetLength(Result, L);
end;
var
aShWindows : IShellWindows;
aIdx : Integer;
aDisp: IDispatch;
aClassName: string;
begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Url: ''' + Url + '''.');
aShWindows := CoShellWindows.Create;
if not Assigned(aShWindows) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / After CoShellWindows.Create, not Assigned(aShWindows) = TRUE.');
end;
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / aShWindows.Count: ' + IntToStr(aShWindows.Count) + '.');
for aIdx := 0 to aShWindows.Count - 1 do begin
aDisp := aShWindows.Item(aIdx);
if not Assigned(aDisp) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / After aDisp := aShWindows.Item(aIdx=' + IntToStr(aIdx) + '), not Assigned(aDisp) = TRUE.');
end
else begin
if not Supports(aDisp, IID_IWebBrowser2) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Supports(aDisp, IID_IWebBrowser2) = FALSE.');
end
else begin
Result := aDisp as IWebBrowser2;
if not Assigned(Result) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / After Result := aDisp as IWebBrowser2, not Assigned(Result) = TRUE.');
end
else begin
aClassName := GetClassName(Result.HWND);
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / GetClassName(aShWindows.Item(aIdx=' + IntToStr(aIdx) + ').Result): ''' + aClassName + '''.');
end;
end;
end;
if Supports(aDisp, IID_IWebBrowser2) then begin
if Assigned(Result) then begin
if SameText(GetClassName(Result.HWND), 'IEFrame') then begin
//if SameText(Url, Result.LocationURL) then begin
if ContainsText(Result.LocationURL, Url) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Found, Result.HWND: ' + IntToStr(Result.HWND) + ', Result.LocationURL: ''' + Result.LocationURL + '''.');
Exit;
end
else begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Not found, ContainsText(Result.LocationURL, Url) = FALSE, Result.LocationURL: ''' + Result.LocationURL + ''' .');
end;
end
else begin
aClassName := GetClassName(Result.HWND);
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Not found, SameText(GetClassName(Result.HWND), ''IEFrame'') = FALSE, aClassName: ''' + aClassName + ''' .');
end;
end;
end;
end;
// Not found
Result := nil;
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Not found, After Result = nil, Url: ''' + Url + '''.');
end;
The application is installed on machines, that all have Windows 7 Professional Service Pack 1, 64Bit and Internet Explorer 11 (Version 11.0.9600.18762).
The code works fine on most machines, but there are some machines, where I get an 'Unknown error' in this method, after it was running correctly for several times.
When having the error once, the only way to get the application running again, is to logoff from windows and login again.
Unfortunatelly, I may not debug on those (production) machines, so I got to use poor man's debugging, logging every line... (that is also the reason, why my above code became a little bit ugly to read on some lines, sorry.)
Doing that, I found, that it must be something related to the IShellWindows interface.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / Url: 'https://example.com/'.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / aShWindows.Count: 3.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / GetClassName(aShWindows.Item(aIdx=0).Result): 'CabinetWClass'.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / Not found, SameText(GetClassName(Result.HWND), 'IEFrame') = FALSE, aClassName: 'CabinetWClass' .
10.08.2017 10:33:05 ThreadID: 0x00001A08 - Meldung - Exception: Unbekannter Fehler Retry: 1
(translation: 'Unbekannter Fehler' means 'Unknown error')
In the above log sample, it seems that only the first item from the List of 3 items can be iterated using IShellWindows. Then an exception is raised.
Any help would be appreciated...
I had a similar problem - or still have with a program that uses the IShellWindows interface. My experience is that it does not depend on the machine, but can happen on any machine, but I did not found out what to do to prevent it.
What helps for me is to stop all explorer processes (not the Internet Explorer process!). I do this from within my program, but you can also do this via the Task Manager for testing. If the Task Bar runs in a seperate Explorer process, you will have to stop that too.
After you have restarted the Explorer, the interface works again. This is slightly better than to have to log off, since you do not need to restart all your applications and you can do this from within your code, but this is of course still no good solution, since the Task Bar will be rebuild during this process.
The code I use to Close all Explorer processes and restart is the following:
function isexplorerwindow(exwnd: hwnd): boolean;
var
p: array[0..max_path] of Char;
begin
GetClassName(exwnd, p, SizeOf(p));
result := ((strcomp(p, 'CabinetWClass') = 0) or (strcomp(p, 'ExploreWClass') = 0));
end;
procedure restartshell;
var
wnd: hwnd;
pid: dword;
processhandle: thandle;
SL: tstringlist;
z: integer;
StartUpInfo: TStartUpInfo;
ProcessInfo: TProcessInformation;
begin
if messagebox(0, pchar(_('Restarting the shell will close all explorer windows and the task bar.') + #13#10 +
_('Do you really want to continue?')), __('Warning'), mb_yesno or mb_defbutton2 or mb_iconquestion) = idno then
Exit;
SL := tstringlist.Create;
wnd := getwindow(getdesktopwindow, gw_child);
while (wnd <> 0) do
begin
if isexplorerwindow(wnd) then
SL.Add(inttostr(wnd));
wnd := getwindow(wnd, gw_hwndnext);
end;
for z := 0 to SL.count - 1 do
postMessage(strtoint(SL[z]), $10, 0, 0);
SL.Free;
application.ProcessMessages;
sleep(1000);
application.ProcessMessages;
wnd := findwindow('Progman', nil);
if wnd > 0 then
begin
GetWindowThreadProcessId(wnd, pid);
if (pid > 0) then
begin
processhandle := OpenProcess(1, false, pid);
if (processhandle > 0) then
begin
TerminateProcess(processhandle, 0);
CloseHandle(processhandle);
end;
end;
end;
application.ProcessMessages;
sleep(1000);
application.ProcessMessages;
FillChar(StartUpInfo, SizeOf(StartUpInfo), #0);
StartUpInfo.cb := SizeOf(StartUpInfo);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
if not CreateProcess(nil, 'explorer.exe', nil, nil, false, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil,
StartUpInfo, ProcessInfo) then
messagebeep(mb_iconstop);
You can try this. It should return the topmost IE window that is navigated to the given URL:
function TryGetWebBrowser(const URL: WideString; out Browser: IWebBrowser2): Boolean;
var
Handle: HWND;
Unused: OleVariant;
Location: OleVariant;
WndIface: IDispatch;
ShellWindows: IShellWindows;
begin
Result := False;
if Succeeded(CoCreateInstance(CLASS_ShellWindows, nil, CLSCTX_LOCAL_SERVER, IID_IShellWindows, ShellWindows)) then
begin
Unused := Unassigned;
Location := URL;
WndIface := ShellWindows.FindWindowSW(Location, Unused, SWC_BROWSER, Integer(Handle), SWFO_NEEDDISPATCH);
Result := Assigned(WndIface) and Succeeded(WndIface.QueryInterface(IWebBrowser2, Browser));
end;
end;

Pipes in Delphi for Command Prompt

How can I get Delphi to pass a string to the input pipe to a CMD process. I am able to get an error pipe and output pipe functioning properly, unfortunately not the input pipe. The code I am using is taken from an online tutorial for piping. There were several errors in the original code causing problems when it was compiled. They have been fixed but I am left with problems when trying to pass input still.
Here is the code in the Form.Create event. I also have included the WritePipe and ReadPipe methods. WritePipe does not work, ReadPipe does work. Both WriteFile and ReadFile in the Pipe methods return a successful message, only the ReadPipe actually works however.
var
DosApp: String;
DosSize: Integer;
Security : TSecurityAttributes;
start : TStartUpInfo;
byteswritten: DWord;
WriteString : ansistring;
begin
CommandText.Clear;
// get COMSPEC variable, this is the path of the command-interpreter
SetLength(Dosapp, 255);
DosSize := GetEnvironmentVariable('COMSPEC', #DosApp[1], 255);
SetLength(Dosapp, DosSize);
// create pipes
With Security do
begin
nlength := SizeOf(TSecurityAttributes) ;
binherithandle := true;
lpsecuritydescriptor := nil;
end;
CreatePipe(InputPipeRead, InputPipeWrite, #Security, 0);
CreatePipe(OutputPipeRead, OutputPipeWrite, #Security, 0);
CreatePipe(ErrorPipeRead, ErrorPipeWrite, #Security, 0);
// start command-interpreter
FillChar(Start,Sizeof(Start),#0) ;
//start.hStdInput := InputPipeRead;
start.hStdOutput := OutputPipeWrite;
start.hStdError := ErrorPipeWrite;
start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
start.wShowWindow := SW_Show;//SW_HIDE;
start.cb := SizeOf(start) ;
if CreateProcess('', PChar(DosApp), #Security, #Security, true,
CREATE_NEW_CONSOLE or SYNCHRONIZE, // CREATE_NO_WINDOW,
nil, nil, start, ProcessInfo) then
begin
MyThread := MainUnit.monitor.Create; // start monitor thread
MyThread.Priority := tpHigher;
end;
Button1.Enabled := true;
cmdcount := 1;
end;
Write Pipe:
procedure WritePipeOut(OutputPipe: THandle; InString: PWideChar);
// writes Instring to the pipe handle described by OutputPipe
var
count : integer;
byteswritten: DWord;
outputstring : PAnsiChar;
TextBuffer: array[1..32767] of AnsiChar;// char;
TextString: String;
begin
// most console programs require CR/LF after their input.
InString := PWideChar(InString + #13#10);
WriteFile(InputPipeWrite, InString[1], Length(InString), byteswritten, nil);
end;
Read Pipe:
function ReadPipeInput(InputPipe: THandle; var BytesRem: Integer): String;
{
reads console output from InputPipe. Returns the input in function
result. Returns bytes of remaining information to BytesRem
}
var
TextBuffer: array[1..32767] of AnsiChar;// char;
TextString: String;
BytesRead: Cardinal;
PipeSize: Integer;
begin
Result := '';
PipeSize := length(TextBuffer);
// check if there is something to read in pipe
PeekNamedPipe(InputPipe, nil, PipeSize, #BytesRead, #PipeSize, #BytesRem);
if bytesread > 0 then
begin
ReadFile(InputPipe, TextBuffer, pipesize, bytesread, nil);
// a requirement for Windows OS system components
OemToChar(#TextBuffer, #TextBuffer);
TextString := String(TextBuffer);
SetLength(TextString, BytesRead);
Result := TextString;
end;
end;
Further note; this is for use with the Java Debugger, which requires input in stages and so I do not believe there is any alternative method other than manipulating input directly to the JDB.
Any help is much appreciated!
1) You should pass InputPipeRead as hStdInput into CreateProcess: uncomment your line start.hStdInput := InputPipeRead;
2) The WritePipeOut function has two errors: it writes a Unicode (UTF-16LE) string into a pipe, and it skips the first character (since it writes a memory area beginning at InString[1]). Instead of WriteFile(InputPipeWrite, InString[1], Length(InString),... you should write something like:
var AnsiBuf: AnsiString;
...
AnsiBuf := String(InString) + #13#10;
Write(InputPipeWrite, AnsiBuf[1], Length(AnsiBuf), byteswritten, nil);

RunPE dump process

Is it possible to dump its own process when it got started from runpe?
Where would be the startaddress of the process, etc.?
EDIT:
I have this unit to run an executable from memory:
unit uExecFromMem;
interface
uses Windows;
function ExecuteFromMem(szFilePath:string; pFile:Pointer):DWORD;
type
PImageBaseRelocation = ^TImageBaseRelocation;
TImageBaseRelocation = packed record
VirtualAddress: DWORD;
SizeOfBlock: DWORD;
end;
function NtUnmapViewOfSection(ProcessHandle:DWORD; BaseAddress:Pointer):DWORD; stdcall; external 'ntdll';
implementation
procedure PerformBaseRelocation(f_module: Pointer; INH:PImageNtHeaders; f_delta: Cardinal); stdcall;
var
l_i: Cardinal;
l_codebase: Pointer;
l_relocation: PImageBaseRelocation;
l_dest: Pointer;
l_relInfo: ^Word;
l_patchAddrHL: ^DWord;
l_type, l_offset: integer;
begin
l_codebase := f_module;
if INH^.OptionalHeader.DataDirectory[5].Size > 0 then
begin
l_relocation := PImageBaseRelocation(Cardinal(l_codebase) + INH^.OptionalHeader.DataDirectory[5].VirtualAddress);
while l_relocation.VirtualAddress > 0 do
begin
l_dest := Pointer((Cardinal(l_codebase) + l_relocation.VirtualAddress));
l_relInfo := Pointer(Cardinal(l_relocation) + 8);
for l_i := 0 to (trunc(((l_relocation.SizeOfBlock - 8) / 2)) - 1) do
begin
l_type := (l_relInfo^ shr 12);
l_offset := l_relInfo^ and $FFF;
if l_type = 3 then
begin
l_patchAddrHL := Pointer(Cardinal(l_dest) + Cardinal(l_offset));
l_patchAddrHL^ := l_patchAddrHL^ + f_delta;
end;
inc(l_relInfo);
end;
l_relocation := Pointer(cardinal(l_relocation) + l_relocation.SizeOfBlock);
end;
end;
end;
function AlignImage(pImage:Pointer):Pointer;
var
IDH: PImageDosHeader;
INH: PImageNtHeaders;
ISH: PImageSectionHeader;
i: WORD;
begin
IDH := pImage;
INH := Pointer(DWORD(pImage) + IDH^._lfanew);
GetMem(Result, INH^.OptionalHeader.SizeOfImage);
ZeroMemory(Result, INH^.OptionalHeader.SizeOfImage);
CopyMemory(Result, pImage, INH^.OptionalHeader.SizeOfHeaders);
for i := 0 to INH^.FileHeader.NumberOfSections - 1 do
begin
ISH := Pointer(DWORD(pImage) + IDH^._lfanew + 248 + i * 40);
CopyMemory(Pointer(DWORD(Result) + ISH^.VirtualAddress), Pointer(DWORD(pImage) + ISH^.PointerToRawData), ISH^.SizeOfRawData);
end;
end;
function ExecuteFromMem(szFilePath:string; pFile:Pointer):DWORD;
var
PI: TProcessInformation;
SI: TStartupInfo;
CT: TContext;
IDH: PImageDosHeader;
INH: PImageNtHeaders;
dwImageBase: DWORD;
pModule: Pointer;
dwNull: DWORD;
begin
Result := 0;
IDH := pFile;
if IDH^.e_magic = IMAGE_DOS_SIGNATURE then
begin
INH := Pointer(DWORD(pFile) + IDH^._lfanew);
if INH^.Signature = IMAGE_NT_SIGNATURE then
begin
FillChar(SI, SizeOf(TStartupInfo), #0);
FillChar(PI, SizeOf(TProcessInformation), #0);
SI.cb := SizeOf(TStartupInfo);
if CreateProcess(nil, PChar(szFilePath), nil, nil, FALSE, CREATE_SUSPENDED, nil, nil, SI, PI) then
begin
CT.ContextFlags := CONTEXT_FULL;
if GetThreadContext(PI.hThread, CT) then
begin
ReadProcessMemory(PI.hProcess, Pointer(CT.Ebx + 8), #dwImageBase, 4, dwNull);
if dwImageBase = INH^.OptionalHeader.ImageBase then
begin
if NtUnmapViewOfSection(PI.hProcess, Pointer(INH^.OptionalHeader.ImageBase)) = 0 then
pModule := VirtualAllocEx(PI.hProcess, Pointer(INH^.OptionalHeader.ImageBase), INH^.OptionalHeader.SizeOfImage, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
else
pModule := VirtualAllocEx(PI.hProcess, nil, INH^.OptionalHeader.SizeOfImage, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
end
else
pModule := VirtualAllocEx(PI.hProcess, Pointer(INH^.OptionalHeader.ImageBase), INH^.OptionalHeader.SizeOfImage, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
if pModule <> nil then
begin
pFile := AlignImage(pFile);
if DWORD(pModule) <> INH^.OptionalHeader.ImageBase then
begin
PerformBaseRelocation(pFile, INH, (DWORD(pModule) - INH^.OptionalHeader.ImageBase));
INH^.OptionalHeader.ImageBase := DWORD(pModule);
CopyMemory(Pointer(DWORD(pFile) + IDH^._lfanew), INH, 248);
end;
WriteProcessMemory(PI.hProcess, pModule, pFile, INH.OptionalHeader.SizeOfImage, dwNull);
WriteProcessMemory(PI.hProcess, Pointer(CT.Ebx + 8), #pModule, 4, dwNull);
CT.Eax := DWORD(pModule) + INH^.OptionalHeader.AddressOfEntryPoint;
SetThreadContext(PI.hThread, CT);
ResumeThread(PI.hThread);
FreeMem(pFile, INH^.OptionalHeader.SizeOfImage);
Result := PI.hThread;
end;
end;
end;
end;
end;
end;
end.
Then I have Application1 and Application2.
Application1 has Application2 (the complete executable) stored in memory.
Then Application1 starts Application2 from memory like this:
ExecuteFromMem(paramstr(0), #Application2InMemory) // uses Application1 as Host
Now Application2 is loaded in memory and is started!
How can Application2 get the it's data (the Application2.exe) back to the disk (or back to a var)?
You are launching Application1 again from Application1 but suspended. Before resuming Application1 you are loading Application2 from disk and copy it to the address in memory of (the seconds instance of) Application1. The attached code takes care of copying the PE Header, DOS Header, NT Headers, Optional Headers and so on and adjusting relocations if required.
Effectively you have Application2 in memory it's just being called Application1 in Task Manager. Therefore if you dump Application2 to disk from Application2 you will get Application2, try it!

Using WinInet to identify total file size before downloading it

I got the source below from a third-party site explaining how to download a file from the internet using WinInet. I'm not too familiar with API, and I took at look at the WinInet unit but did not see any API calls like what I need.
What I'm doing is adding the ability to report back progress of downloading a file. This procedure I've already wrapped inside of a TThread and everything works fine. However, just one missing piece: Finding the total size of the source file before downloading.
See below where I have a comment //HOW TO GET TOTAL SIZE? This is where I need to find out what is the total size of the file BEFORE I begin downloading it. How do I go about doing this? Because this code seems to not know the size of the file until it's done being downloaded - and that makes this addition irrelevant.
procedure TInetThread.Execute;
const
BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: DWORD;
f: File;
S: Bool;
D: Integer;
T: Integer;
procedure DoWork(const Amt: Integer);
begin
if assigned(FOnWork) then
FOnWork(Self, FSource, FDest, Amt, T);
end;
begin
S:= False;
try
try
if not DirectoryExists(ExtractFilePath(FDest)) then begin
ForceDirectories(ExtractFilePath(FDest));
end;
hSession:= InternetOpen(PChar(FAppName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
hURL:= InternetOpenURL(hSession, PChar(FSource), nil, 0, 0, 0);
try
AssignFile(f, FDest);
Rewrite(f, 1);
T:= 0; //HOW TO GET TOTAL SIZE?
D:= 0;
DoWork(D);
repeat
InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen);
D:= D + BufferLen;
DoWork(D);
until BufferLen = 0;
CloseFile(f);
S:= True;
finally
InternetCloseHandle(hURL);
end
finally
InternetCloseHandle(hSession);
end;
except
on e: exception do begin
S:= False;
end;
end;
finally
if assigned(FOnComplete) then
FOnComplete(Self, FSource, FDest, S);
end;
end;
You can use the HEAD method and check the Content-Length to retrieve the file size of a remote file
Check these two Methods
WinInet
If you want execute a HEAD method you must use the HttpOpenRequest, HttpSendRequest and HttpQueryInfo WinInet functions .
uses
SysUtils,
Windows,
WinInet;
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;
const
sUserAgent = 'Mozilla/5.001 (windows; U; NT4.0; en-US; rv:1.0) Gecko/25250101';
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;
Indy
Also check this code using indy.
function GetRemoteFilesize(const Url :string) : Integer;
var
Http: TIdHTTP;
begin
Http := TIdHTTP.Create(nil);
try
Http.Head(Url);
result:= Http.Response.ContentLength;
finally
Http.Free;
end;
end;
Answering the question of how to get a download size with WinInet. This is out of one of my file downloaders that is based on WinInet.
This is the method I use to get the download size:
function TWebDownloader.GetContentLength(URLHandle: HINTERNET): Int64;
// returns the expected download size. Returns -1 if one not provided
var
SBuffer: Array[1..20] of char;
SBufferSize: Integer;
srv: integer;
begin
srv := 0;
SBufferSize := 20;
if HttpQueryInfo(URLHandle, HTTP_QUERY_CONTENT_LENGTH, #SBuffer, SBufferSize, srv) then
Result := StrToFloat(String(SBuffer))
else
Result := -1;
end;
Use of this method requires an open request handle, and does NOT require reading any of the data:
URLHandle := HttpOpenRequest(ConnectHandle, 'GET', Pchar(sitepath), nil,
nil, nil, INTERNET_FLAG_NO_CACHE_WRITE, 0);
...
DownloadSize := GetContentLength(URLHandle);
HTH
after fixing the types it looks better like this:
function GetContentLength(URLHandle:HINTERNET):Int64;
// returns the expected download size. Returns -1 if one not provided
var
SBufferSize, srv:Cardinal;
begin
srv:=0;
SBufferSize:=20;
if Not HttpQueryInfo(URLHandle, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, {#SBuffer} #Result, SBufferSize, srv) then Result:=-1;
end;
to call it:
{get the file handle}
hURL:=InternetOpenURL(hSession, PChar(URL), nil, 0, 0, 0);
if hURL=Nil then
begin
InternetCloseHandle(hSession);
ShowMessage('The link is incorrect!');
exit;
end;
{get the file size}
filesize:=GetContentLength(hURL);

Delphi: wait until bat-script runs to the end

I have bat-file, that make some operations. How to run this file from Delphi and wait, until it stops.
Something like that:
procedure TForm1.Button1Click(Sender: TObject);
begin
//Starting bat-file
bla-bla-bla
showmessage('Done');
end;
This executes the given command line and waits for the program started by the command line to exit. Returns true if the program returns a zero exit code and false if the program doesn't start or returns a non-zero error code.
function ExecAndWait(const CommandLine: string) : Boolean;
var
StartupInfo: Windows.TStartupInfo; // start-up info passed to process
ProcessInfo: Windows.TProcessInformation; // info about the process
ProcessExitCode: Windows.DWord; // process's exit code
begin
// Set default error result
Result := False;
// Initialise startup info structure to 0, and record length
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
// Execute application commandline
if Windows.CreateProcess(nil, PChar(CommandLine),
nil, nil, False, 0, nil, nil,
StartupInfo, ProcessInfo) then
begin
try
// Now wait for application to complete
if Windows.WaitForSingleObject(ProcessInfo.hProcess, INFINITE)
= WAIT_OBJECT_0 then
// It's completed - get its exit code
if Windows.GetExitCodeProcess(ProcessInfo.hProcess,
ProcessExitCode) then
// Check exit code is zero => successful completion
if ProcessExitCode = 0 then
Result := True;
finally
// Tidy up
Windows.CloseHandle(ProcessInfo.hProcess);
Windows.CloseHandle(ProcessInfo.hThread);
end;
end;
end;
From: http://www.delphidabbler.com/codesnip?action=named&showsrc=1&routines=ExecAndWait
Here is some code and example - under Windows 7 works fine and is invisible
(funcion ExeAndWait is borrowed).
function ExeAndWait(ExeNameAndParams: string; ncmdShow: Integer = SW_SHOWNORMAL): Integer;
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
Res: Bool;
lpExitCode: DWORD;
begin
with StartupInfo do //you can play with this structure
begin
cb := SizeOf(TStartupInfo);
lpReserved := nil;
lpDesktop := nil;
lpTitle := nil;
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := ncmdShow;
cbReserved2 := 0;
lpReserved2 := nil;
end;
Res := CreateProcess(nil, PChar(ExeNameAndParams), nil, nil, True,
CREATE_DEFAULT_ERROR_MODE
or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInformation);
while True do
begin
GetExitCodeProcess(ProcessInformation.hProcess, lpExitCode);
if lpExitCode <> STILL_ACTIVE then
Break;
Application.ProcessMessages;
end;
Result := Integer(lpExitCode);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ExeAndWait(ExtractFilePath(Application.ExeName) + 'test.bat', SW_HIDE);
ShowMessage('Done!');
end;
PS. If you like you can build batch file at runtime using TStringList class.

Resources