Inno Setup - How to validate serial number online - windows

Using Inno Setup, setup.exe was given to a client, according to contract he is allowed only to use 2016 and 2017. But on 01-01-2018 he should not be able to continue with same serial 2017.
How to make the setup.exe by innosetup limited to from and to date?
[Setup]
#define SerialNumber "2017"
UserInfoPage=yes
[Code]
function CheckSerial(Serial: String): Boolean;
begin
Result := Serial = '{#SerialNumber}';
end;
setup.exe is executed
license key is inserted
after submit, i want to check URL https://www.example.com/query/license?id=2017
if the result is ok or nok based on that the installation continue

Starting with a code from: Inno Setup - HTTP request - Get www/web content, you will get something like:
[Setup]
UserInfoPage=yes
[Code]
// Presence of the CheckSerial event function displays the serial number box.
// But here we accept any non-empty serial.
// We will validate it only in the NextButtonClick,
// as the online validation can take long.
function CheckSerial(Serial: String): Boolean;
begin
Result := (Serial <> '');
end;
function NextButtonClick(CurPageID: Integer): Boolean;
var
WinHttpReq: Variant;
Url: string;
begin
Result := True;
if CurPageID = wpUserInfo then
begin
WinHttpReq := CreateOleObject('WinHttp.WinHttpRequest.5.1');
Url := 'https://www.example.com/serial.php?serial=' +
WizardForm.UserInfoSerialEdit.Text;
WinHttpReq.Open('GET', Url, False);
WinHttpReq.Send('');
// Depending on implementation of the server,
// use either HTTP status code (.Status)
// or contents of returned "page" (.ResponseText)
// Here we use the HTTP status code:
// 200 = serial is valid, anything else = serial is invalid,
// and when invalid, we display .ResponseText
Result := (WinHttpReq.Status = 200);
if not Result then
MsgBox(WinHttpReq.ResponseText, mbError, MB_OK);
end;
end;
A simple server-side validation PHP script (serial.php) would be like:
<?
if (empty($_REQUEST["serial"]) || ($_REQUEST["serial"] != "2017"))
{
header("HTTP/1.0 401 The serial number is not valid");
// error message to be displayed in installer
echo "The serial number is not valid";
}
For consideration:
This validation is not difficult to bypass, i.e. using a proxy server.
It also does not prevent the user from extracting the files from the installer and installing them manually.
You may consider instead an on-line download of the actual files only after validating the serial number.
Or downloading some license file that the application will require for functioning. You need that anyway, if you want to enforce the application to stop working once the license expires.
Or you can also encrypt the installer and make the online service return the decryption password:
Read Inno Setup encryption key from Internet instead of password box
For a similar question, see also
How to store serial numbers in a Sharepoint List, for to call from Inno Setup and verify if is autorized user?

Related

Indy HttpClient.Post gives range check error when built for release but not in debug - why?

I am using Delphi 2009, Indy ver 10.5498 together with libeay32.dll and ssleay32.dll from the zip file openssl-1.0.2r-i386-win32 at https://indy.fulgan.com/SSL/.
Range checking is turned on in project options and not turned off anywhere.
Using the code below, which I generated with Remy's help from this post, I can upload data to an API on a server via https when running in the IDE with debugging turned on or from a compiled exe generated with debugging tuned on.
However, if I build a release version then whether I run it through the IDE or as an exe I get a range check error on the line result := HttpClient.Post(THE_URL, FormData);
The params list simply contains the to, from, subject, body etc and there is no attachment in the filenames list ie filenames.Count = 0. U_GeneralRoutines.TheFileStoreFolder is simply a folder inside ProgramData where the SSL DLL's are stored.
As the debugger didn't catch this I put in the two showmessage lines before and after the call. When built as debug, both messages get shown and the post succeeds. When built as release the first one gets displayed and then I get the range check error.
I don't suppose there is a bug in the POST code, so what can be going wrong?
function UploadToAPI(params, filenames: TStrings): string;
var
HttpClient: TIdHttp;
IdSSLIOHandler: TIdSSLIOHandlerSocketOpenSSL;
FormData : TIdMultiPartFormDataStream;
i : integer;
PathToSSLlibraries : string;
begin
FormData := TIdMultiPartFormDataStream.Create;
HttpClient:= TIdHttp.Create;
IdSSLIOHandler:= TIdSSLIOHandlerSocketOpenSSL.Create;
PathToSSLlibraries := IncludeTrailingPathDelimiter(U_GeneralRoutines.TheFileStoreFolder);
IdOpenSSLSetLibPath(PathToSSLlibraries); //set path to libeay32.dll and ssleay32.dll in the common ProgramData folder
HttpClient.IOHandler := IdSSLIOHandler;
HttpClient.Request.CustomHeaders.FoldLines := true ;
try
for i := 0 to params.Count - 1 do
FormData.AddFormField(params.Names[i], params.ValueFromIndex[i]);
for i := 0 to filenames.Count - 1 do
FormData.AddFile('attachment', filenames[i]); //works with ver 10.5498 but not with 10.2.5
//add authorisation header
HttpClient.Request.CustomHeaders.Add('Authorization:Basic ' + ATHORISATION_STR); //byte64 encoding of the api key
HttpClient.ProtocolVersion := pv1_1; //get the full server response which allows for just one try-except
HttpClient.HTTPOptions := HttpClient.HTTPOptions + [hoKeepOrigProtocol, hoNoProtocolErrorException, hoWantProtocolErrorContent];
try
showmessage('about to post');
result := HttpClient.Post(THE_URL, FormData); //post to the api
showmessage('posted');
except
on E: Exception do
begin
result := E.ClassName + ': ' + E.message;
raise;
end;
end; //try
finally
FormData.Free;
IdSSLIOHandler.free;
HttpClient.free;
end;
I appreciate that this type of scenario is often caused by unintialised variables in the release version that would get automatically initialised when in the IDE / debug. But all the variables in my procedure do seem to be getting initialised before the call to POST.

Inno Setup detect Windows Firewall state

I need to detect the Windows Firewall state (i.e. whether it is enabled or not) in order to display a message warning that a Firewall rule may need to be configured to allow inbound connections on specific ports when the Firewall is enabled, but not when it isn't. See below code example:
[Code]
//Check if Windows Firewall is enabled
function IsWindowsFirewallEnabled(): Boolean;
begin
//Method required here
Result := True;
end;
function NextButtonClick(CurPageID: Integer): Boolean;
begin
//Display a warning message on a Server install if Windows Firewall is enabled
if CurPageID = wpSelectComponents and IsComponentSelected('Server') and IsWindowsFirewallEnabled then
begin
MsgBox('Windows Firewall is currently enabled.' + #13#10 + #13#10 +
'You may need to enable inbound connections on ports 2638, 445 and 7.'
mbInformation, MB_OK);
Result := True;
end;
end;
What I need is a method for the IsWindowsFirewallEnabled function. One way I have read about, and ironically has now more or less been suggested below whilst I was in the middle of updating the question with this information anyway, would appear to be reading the EnableFirewall value from the Registry:
//Check if Windows Firewall is enabled
function IsWindowsFirewallEnabled(): Boolean;
var
crdFirewallState: Cardinal;
begin
RegQueryDwordValue(HKLM, 'SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile',
'EnableFirewall', crdFirewallState);
if crdFirewallState = 1 then
Result := True;
end;
However, I am not convinced by this method as the Registry values for all the profiles show enabled on my work PC, but looking in Control Panel the Domain profile shows disabled (I assume this is related to a Group Policy).
Note, that this needs to work for both Windows XP and Server 2003, and for Windows Vista and Server 2008 and above.
Therefore, what's the most reliable or recommended way to do this?
You would need to determine the registry entry and then query it in a manner similar to this using Innosetup's registry query ability.
var
Country: String;
begin
if RegQueryStringValue(HKEY_CURRENT_USER, 'Control Panel\International',
'sCountry', Country) then
begin
// Successfully read the value
MsgBox('Your country: ' + Country, mbInformation, MB_OK);
end;
end;
http://www.jrsoftware.org/ishelp/index.php?topic=isxfunc_regquerystringvalue
Allegedly this is the information for the registry key:
Path: HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\WindowsFirewall\DomainProfile
Location: Local Machine
Value Name: EnableFirewall
Data Type: DWORD (DWORD Value)
Enabled Value: 0
Disabled Value: 1

How to ensure that messages sent with TTetheringAppProfile.SendStream were delivered properly?

I have a simple mobile app, that takes a series of photos and sends it via SendStream() to the connected Profile.
myTetherAppProfile.SendStream(myTetherManager.RemoteProfiles[idConnected],
'ImageData',
bmpStreamData);
The occurring problem here is that the receiver-app doesn't get all the image-streams depending on the connection-strength (The ResourceReceived-Event isn't triggered on the receiver-app).
This would be no problem if I get a response that the delivery failed. But I don't get this (SendStream() returns "True")
Is there a possibility other than implementing a "please answer with another message if you received my image"-function to achieve stable transmissions even with bad connection? Or is App-Tethering by default designed to be lossy?
Also after a big stack of images I sometimes get the "connection reset by peer"-error. (I'm not sure if this error is related to the actual problem, so I preferred posting it.)
Looking at the relevant code from System.Tether.AppProfile (XE8 version), it appears to be a bug. See my inline comments below. Please report to https://quality.embarcadero.com
function TTetheringAppProfile.SendStream(const AProfile: TTetheringProfileInfo; const Description: string;
const AStream: TStream): Boolean;
var
LProfileInfo: TTetheringProfileInfo;
LConnection: TTetheringConnection;
LCommand: TTetheringCommand;
begin
if not FindProfile(AProfile.ProfileIdentifier, LProfileInfo) then
raise ETetheringException.CreateFmt(SNoProfile, [AProfile.ProfileIdentifier]);
CheckProfileIsConnected(AProfile);
LConnection := GetConnectionTo(AProfile);
TMonitor.Enter(LConnection);
try
LCommand := LConnection.Protocol.SendCommandWithResponse(SendStreamCommand, Version, Description);
if LCommand.Command = SendStreamOkResponse then
begin
Result := LConnection.Protocol.TransferStream(AStream);
if Result then
begin <-- Result here is guaranteed to be True
LCommand := LConnection.Protocol.ReceiveCommand;
if LCommand.Command = SendStreamContentOKResponse then
Result := True; <-- Sets Result to True if succeeds,
<-- but nothing to set Result to False if call failed.
end;
end
else
Result := False;
finally
TMonitor.Exit(LConnection);
end;
end;

How to drop files onto .MAPIMail

Given some files (or shell file objects) how do i invoke the .MAPIMail registered shell extension handler with them?
The Question
i have some files on the computer:
C:\Users\ian\AppData\Local\Temp\Contoso_Invoice_141174.pdf
C:\Users\ian\AppData\Local\Temp\Contoso_Invoice_141173.pdf
C:\Users\ian\AppData\Local\Temp\Contoso_Invoice_141171.pdf
That i want to do the programmatic equivalent of dropping them on the .MAPIMail registered handler:
The Sent to folder's Mail recipient option is actually a special registered .MAPIMail extension:
Which is a file type that is registered on the system:
HKEY_CLASSES_ROOT\.mapimail
How do i invoke a drop onto a ephermeral .mapimail file?
Can't you just look in the registry?
Now, i could be a bad developer, and spellunk the registry, the .mapimail entry's default value:
CLSID\{9E56BE60-C50F-11CF-9A2C-00A0C90A90CE}
Extract the clsid {9E56BE60-C50F-11CF-9A2C-00A0C90A90CE}, and confirm that class is registered:
HKEY_CLASSES_ROOT\CLSID\{9E56BE60-C50F-11CF-9A2C-00A0C90A90CE}
(default) = Desktop Shortcut
\InProcServer32
(default) = %SystemRoot%\System32\sendmail.dll
And use CoCreateInstance to create that COM object:
IUnknown unk = CreateComObject("{9E56BE60-C50F-11CF-9A2C-00A0C90A90CE}");
And then i'm in an undocumented, unsupported world, where i don't know what interface i have to QueryInterface for, and what methods to call in what order.
So we're left with shell programming
What i'd like is to likely something involving the shell (pseudo-code):
IShellFolder desktop;
OleCheck(SHGetDesktopFolder(out desktop));
List<pidl> pidls = new List<pidl>();
ULONG chEaten = 0;
ULONG dwAttributes = 0;
PIDL pidl;
foreach (String filename in Files) do
{
OleCheck(desktop.ParseDisplayName(0, nil, filename, out chEaten, out pidl, ref dwAttributes));
pidls.Add(pidl);
}
//Get the shell folder of the temp folder
IShellFolder tempShellFolder;
desktop.ParseDisplayName(0, nil, GetTemporaryPath, out chEaten, out pidl, ref dwAttributes));
desktop.BindToObject(pidl, nil, IShellFolder, tempShellFolder);
//i have no idea what i've been doing; just throwing reasonable looking code together
//nobody will actually ever read this
IDontCare context;
tempShellFolder.GetUIObjectOf(0, pidls.Count, pidls, IDontCareAnymore, nil, ref context);
Except all that code relies on the extistance of a context menu, which i don't have. Nobody says that .MAPIMail has to be in any context Send to menu.
i was asking how to drop files on a .mapimail file.
And my god.
Why not just use MAPI?
Because no MAPI client is installed when you're a 32-bit application running on Windows 64-bit with Office 64-bit installed. So i need to be able to accomplish what the user already can.
Although it doesn't answer my question, Raymond pointed out that it's a stupid question. Nobody in their right mind should be trying to send mail to recipients. But i was desperate!
Turns out i'm not completely stuck. While there is a bitness nightmare when dealing with 64-bit Outlook (MAPI provider) from 32-bit applications (or vice versa), there is one out.
If i use just MapiSendMail, and no other MAPI functions, it is safe to cross the 32-bit/64-bit barrier. From Building MAPI Applications on 32-Bit and 64-Bit Platforms:
32-bit MAPI Application and 64-Bit Outlook
32-bit MAPI applications are not supported to run on a computer installed with 64-bit Outlook and 64-bit Windows. The application developer must update and rebuild the application as a 64-bit application for the 64-bit platform. This is because a 32-bit application cannot load a 64-bit Msmapi32.dll file. There are a small number of API changes that application developers must incorporate to build their code successfully for a 64-bit environment. MAPI header files have been updated with these changes to support the 64-bit platform. You can download these header files at Outlook 2010: MAPI Header Files. Developers can use this same set of MAPI header files to build both 32-bit and 64-bit MAPI applications
That makes it sound like all hope is lost. But, there is, on Windows 7:
Exception: MAPISendMail
However, one function call among all Simple MAPI and MAPI elements, MAPISendMail, would succeed in a Windows-32-bit-on-Windows-64-bit (WOW64) or Windows-64-bit-on-Windows-32-bit (WOW32) scenario and would not result in the above alert. This WOW64 scenario only applies to Windows 7. Figure 2 shows a WOW64 scenario in which a 32-bit MAPI application calls MAPISendMail on a computer installed with 64-bit Windows 7. In this scenario, the MAPI library makes a COM call to launch a 64-bit Fixmapi application. The Fixmapi application implicitly links to the MAPI library, which routes the function call to the Windows MAPI stub, which in turn forwards the call to the Outlook MAPI stub, enabling the MAPISendMail function call to succeed.
So, as a Delphi Jedi user, their Simple Send E-mail functions will fail (as they use too much of MAPI). So i had to create my own:
procedure MapiSimpleSendMail(slFiles: TStrings; ToEmailAddress: string=''; ToName: string='');
var
mapiMessage: TMapiMessage;
flags: LongWord;
// senderName: AnsiString;
// senderEmailAddress: AnsiString;
emailSubject: AnsiString;
emailBody: AnsiString;
// sender: TMapiRecipDesc;
recipients: packed array of TMapiRecipDesc;
attachments: packed array of TMapiFileDesc;
i: Integer;
hr: Cardinal;
es: string;
const
MAPI_E_UNICODE_NOT_SUPPORTED = 27; //Windows 8. The MAPI_FORCE_UNICODE flag is specified and Unicode is not supported.
begin
ZeroMemory(#mapiMessage, SizeOf(mapiMessage));
{ senderName := '';
senderEmailAddress := '';
ZeroMemory(#sender, sizeof(sender));
sender.ulRecipClass := MAPI_ORIG; //MAPI_TO, MAPI_CC, MAPI_BCC, MAPI_ORIG
sender.lpszName := PAnsiChar(senderName);
sender.lpszAddress := PAnsiChar(senderEmailAddress);}
mapiMessage.lpOriginator := nil; //PMapiRecipDesc; { Originator descriptor }
if ToEmailAddress <> '' then
begin
SetLength(recipients, 1);
recipients[0].ulRecipClass := MAPI_TO;
recipients[0].lpszName := LPSTR(ToName);
recipients[0].lpszAddress := LPSTR(ToEmailAddress);
mapiMessage.lpRecips := #recipients[0]; //A value of NULL means that there are no recipients. Additionally, when this member is NULL, the nRecipCount member must be zero.
mapiMessage.nRecipCount := 1;
end
else
begin
mapiMessage.lpRecips := nil; //A value of NULL means that there are no recipients. Additionally, when this member is NULL, the nRecipCount member must be zero.
mapiMessage.nRecipCount := 0;
end;
mapiMessage.lpszMessageType := nil;
if slFiles.Count > 0 then
begin
emailSubject := 'Emailing: ';
emailBody :=
' '+#13#10+ //Yes, the shell really does create a blank mail with a leading line of ten spaces
'Your message is ready to be sent with the following file or link attachments:'+#13#10;
SetLength(attachments, slFiles.Count);
for i := 0 to slFiles.Count-1 do
begin
attachments[i].ulReserved := 0; // Cardinal; { Reserved for future use (must be 0) }
attachments[i].flFlags := 0; // Cardinal; { Flags }
attachments[i].nPosition := $FFFFFFFF; //Cardinal; { character in text to be replaced by attachment }
attachments[i].lpszPathName := PAnsiChar(slFiles[i]); { Full path name of attachment file }
attachments[i].lpszFileName := nil; // LPSTR; { Original file name (optional) }
attachments[i].lpFileType := nil; // Pointer; { Attachment file type (can be lpMapiFileTagExt) }
if i > 0 then
emailSubject := emailSubject+', ';
emailSubject := emailSubject+ExtractFileName(slFiles[i]);
emailBody := emailBody+#13#10+
ExtractFileName(slFiles[i]);
end;
emailBody := emailBody+#13#10+
#13#10+
#13#10+
'Note: To protect against computer viruses, e-mail programs may prevent sending or receiving certain types of file attachments. Check your e-mail security settings to determine how attachments are handled.';
mapiMessage.lpFiles := #attachments[0];
mapiMessage.nFileCount := slFiles.Count;
end
else
begin
emailSubject := '';
emailBody := '';
mapiMessage.lpFiles := nil;
mapiMessage.nFileCount := 0;
end;
{
Subject
Emailing: 4388_888871544_MVM_10.tmp, amt3.log, swtag.log, wct845C.tmp, ~vs1830.sql
Body
<-- ten spaces
Your message is ready to be sent with the following file or link attachments:
4388_888871544_MVM_10.tmp
amt3.log
swtag.log
wct845C.tmp
~vs1830.sql
Note: To protect against computer viruses, e-mail programs may prevent sending or receiving certain types of file attachments. Check your e-mail security settings to determine how attachments are handled.
}
mapiMessage.lpszSubject := PAnsiChar(emailSubject);
mapiMessage.lpszNoteText := PAnsiChar(emailBody);
flags := MAPI_DIALOG;
hr := Mapi.MapiSendMail(0, 0, mapiMessage, flags, 0);
case hr of
SUCCESS_SUCCESS: {nop}; //The call succeeded and the message was sent.
MAPI_E_AMBIGUOUS_RECIPIENT:
begin
//es := 'A recipient matched more than one of the recipient descriptor structures and MAPI_DIALOG was not set. No message was sent.';
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_AMBIGUOUS_RECIPIENT', SysErrorMessage(hr)]);
end;
MAPI_E_ATTACHMENT_NOT_FOUND:
begin
//The specified attachment was not found. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_ATTACHMENT_NOT_FOUND', SysErrorMessage(hr)]);
end;
MAPI_E_ATTACHMENT_OPEN_FAILURE:
begin
//The specified attachment could not be opened. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_ATTACHMENT_OPEN_FAILURE', SysErrorMessage(hr)]);
end;
MAPI_E_BAD_RECIPTYPE:
begin
//The type of a recipient was not MAPI_TO, MAPI_CC, or MAPI_BCC. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_BAD_RECIPTYPE', SysErrorMessage(hr)]);
end;
MAPI_E_FAILURE:
begin
//One or more unspecified errors occurred. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_FAILURE', SysErrorMessage(hr)]);
end;
MAPI_E_INSUFFICIENT_MEMORY:
begin
//There was insufficient memory to proceed. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_INSUFFICIENT_MEMORY', SysErrorMessage(hr)]);
end;
MAPI_E_INVALID_RECIPS:
begin
//One or more recipients were invalid or did not resolve to any address.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_INVALID_RECIPS', SysErrorMessage(hr)]);
end;
MAPI_E_LOGIN_FAILURE:
begin
//There was no default logon, and the user failed to log on successfully when the logon dialog box was displayed. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_LOGIN_FAILURE', SysErrorMessage(hr)]);
end;
MAPI_E_TEXT_TOO_LARGE:
begin
//The text in the message was too large. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_TEXT_TOO_LARGE', SysErrorMessage(hr)]);
end;
MAPI_E_TOO_MANY_FILES:
begin
//There were too many file attachments. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_TOO_MANY_FILES', SysErrorMessage(hr)]);
end;
MAPI_E_TOO_MANY_RECIPIENTS:
begin
//There were too many recipients. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_TOO_MANY_RECIPIENTS', SysErrorMessage(hr)]);
end;
MAPI_E_UNICODE_NOT_SUPPORTED:
begin
//The MAPI_FORCE_UNICODE flag is specified and Unicode is not supported.
//Note This value can be returned by MAPISendMailW only.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_UNICODE_NOT_SUPPORTED', SysErrorMessage(hr)]);
end;
MAPI_E_UNKNOWN_RECIPIENT:
begin
//A recipient did not appear in the address list. No message was sent.
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_UNKNOWN_RECIPIENT', SysErrorMessage(hr)]);
end;
MAPI_E_USER_ABORT:
begin
es := 'The user canceled one of the dialog boxes. No message was sent.';
raise Exception.CreateFmt('Error %s sending e-mail message: %s', ['MAPI_E_USER_ABORT', es]);
end;
else
raise Exception.CreateFmt('Error %d sending e-mail message: %s', [hr, SysErrorMessage(hr)]);
end;
end;
Note: Any code is released into the public domain. No attribution required.

How to retrieve a file from Internet via HTTP?

I want to download a file from Internet and InternetReadFile seem a good and easy solution at the first glance. Actually, too good to be true. Indeed, digging a bit I have started to see that actually there are a lot of issues with it. People are complaining about all kinds of problems when using this code.
Problems could appear because:
the application freezes temporarily until the HTTP server responds
the application freezes temporarily because the Internet connections breaks
the application locks up because the HTTP server never responds
the InternetOpen (I just discovered this recently) MUST be called only once during application life time
I could not find a complete example about how to use it properly and robustly. Does anybody have an idea about how to implement it in a separate thread and with a time out? There is another SIMPLE way to robustly download a file from Internet. Though I don't want to complicate my life with very large libraries like Jedi or even Indy.
function GetFileHTTP (const fileURL, FileName: String): boolean;
CONST
BufferSize = 1024;
VAR
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: DWORD;
f: File;
sAppName: string;
begin
// result := false;
sAppName := ExtractFileName(Application.ExeName) ;
hSession := InternetOpen(PChar(sAppName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0) ; { be aware that InternetOpen need only be called once in your application!!!!!!!!!!!!!! }
TRY
hURL := InternetOpenURL(hSession, PChar(fileURL), nil, 0, 0, 0) ;
TRY
AssignFile(f, FileName) ;
Rewrite(f, 1) ;
REPEAT
InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen)
UNTIL BufferLen = 0;
CloseFile(f) ;
Result:= True;
FINALLY
InternetCloseHandle(hURL)
end
FINALLY
InternetCloseHandle(hSession)
END;
END;
Edit:
This functions checks if Internet connection is available. It seems to work on Win98 also.
{ Are we connected to the Internet? }
function IsConnectedToInternet: Boolean; { Call SHELL32.DLL for Win < Win98 otherwise call URL.dll }
var InetIsOffline: function(dwFlags: DWORD): BOOL; stdcall;
begin
Result:= FALSE;
if IsApiFunctionAvailable('URL.DLL', 'InetIsOffline', #InetIsOffline)
then Result:= NOT InetIsOffLine(0)
else
if IsApiFunctionAvailable('SHELL32.DLL', 'InetIsOffline', #InetIsOffline)
then Result:= NOT InetIsOffLine(0)
end;
I am using Delphi 7. Many thanks.
Edit:
Losing customers because the application hangs at the first start up is the perfect recipe for losing money.
Writing your code to be Microsoft platform dependent is bad. You never know if the customer has the IE version x.x installed.
Installing stuff into a user's computer is like playing with guns. It will backfire.
(see more about this here: http://thesunstroke.blogspot.com/2010/06/programmig-like-there-is-no-ms-windows.html)
I basically do the same as you do. For me it works fairly flawlessly.
The only differences between my code and your code is I have an INTERNET_FLAG_RELOAD parameter to force a download from the file and not the cache. You can try that and see if it works better:
hURL := InternetOpenURL(hSession, PChar(fileURL), nil, 0, INTERNET_FLAG_RELOAD, 0) ;
Also check for an internet connection before downloading. Do this:
dwConnectionTypes := INTERNET_CONNECTION_MODEM
+ INTERNET_CONNECTION_LAN
+ INTERNET_CONNECTION_PROXY;
InternetConnected := InternetGetConnectedState(#dwConnectionTypes, 0);
if InternetConnected then ...
Here's some sample code that uses Indy. This code is for Delphi 2010 (with Indy 10?), but the code for Delphi 7 would be similar. I've used Indy for years with D7 and have been very happy with it. I think in D7 we use Indy 9. Check if you need to download a new version...
You can use OnWork and OnWorkBegin to add a progress meter if you need to.
This code I excerpted from a bigger piece, editing it a bit. I did not try compiling it, but it will give you a good starting place.
function Download( const aSourceURL: String;
const aDestFileName: String;
out aDownloadResult: TDownloadResult;
out aErrm: String): boolean;
var
Stream: TMemoryStream;
IDAntiFreeze: TIDAntiFreeze;
begin
aDownloadResult := DROther;
Result := FALSE;
fIDHTTP := TIDHTTP.Create;
fIDHTTP.HandleRedirects := TRUE;
fIDHTTP.AllowCookies := FALSE;
fIDHTTP.Request.UserAgent := 'Mozilla/4.0';
fIDHTTP.Request.Connection := 'Keep-Alive';
fIDHTTP.Request.ProxyConnection := 'Keep-Alive';
fIDHTTP.Request.CacheControl := 'no-cache';
IDAntiFreeze := TIDAntiFreeze.Create;
Stream := TMemoryStream.Create;
try
try
fIDHTTP.Get(aSourceURL, Stream);
if FileExists(aDestFileName) then
DeleteFile(PWideChar(aDestFileName));
Stream.SaveToFile(aDestFileName);
Result := TRUE;
aDownloadResult :=drSuccess;
except
On E: Exception do
begin
Result := FALSE;
aErrm := E.Message + ' (' + IntToStr(fIDHTTP.ResponseCode) + ')';
end;
end;
finally
Stream.Free;
IDAntiFreeze.Free;
fIDHTTP.Free;
end;
end; { Download }
My personal favorite is using the WebHttpRequest component from importing the "Microsoft WinHTTP Services" type library: http://yoy.be/item.asp?i142
var
w:IWebHttpRequest;
f:TFileStream;
os:TOleStream;
begin
w:=CoWebHttpRequest.Create;
w.Open('GET',SourceURL,false);
w.Send(EmptyParam);
os:=TOleStream.Create(IUnknown(w.ResponseStream) as IStream);
f:=TFileStream.Create(DestinationFilePath,fmCreate);
os.Position:=0;
f.CopyFrom(os,os.Size);
f.Free;
os.Free;
w:=nil;
end;
I recommend Synapse. It's small, stable and easy-to-use (no need of any external libraries).
Example from httpsend.pas
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
Result := HTTP.HTTPMethod('GET', URL);
if Result then
Response.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
Instead of fiddling with the WinAPI, the ExtActns unit provides just what you need for downloading to a file.
procedure TMainForm.DownloadFile(URL: string; Dest: string);
var
dl: TDownloadURL;
begin
dl := TDownloadURL.Create(self);
try
dl.URL := URL;
dl.FileName := Dest;
dl.ExecuteTarget(nil); //this downloads the file
dl.Free;
except
dl.Free;
end;
end;
Under the hood, it uses URLDownloadToFile from the URLMon library - which is part of IE, and therefore part of Windows.
TDownloadURL doesn't handle any timeout for you - it doesn't look like such a thing is supported in URLMon at all, although there could be some default timeout that causes the call to fail - but you could use the OnProgress event on TDownloadURL to get notified when something happens, and then do something in another thread if it's been too long since the last callback.
Solved using improved version of the above code.
(it still does not solve all issues - MS does not actually implemented full support for server time out)
The connection does not timeout while downloading file from internet

Resources