unit uUpdate;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, UrlMon,
ActiveX, StdCtrls, ShellAPI, ComCtrls, WinINet;
type
TfrmUpdate =
class(TForm)
btnUpdateCheck: TButton;
MemoInfo: TMemo;
Fortschritt: TProgressBar;
procedure btnUpdateCheckClick(Sender: TObject);
Function GetHTML(AUrl:
string):
string;
private
{ Private-Deklarationen }
public
{ Pu
blic-Deklarationen }
end;
type
cDownloadStatusCallback =
class(TObject, IUnknown, IBindStatusCallback)
private
function QueryInterface(
const IID: TGUID;
out Obj): HResult;
stdcall;
function _AddRef: Integer;
stdcall;
function _Release: Integer;
stdcall;
function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult;
stdcall;
function GetPriority(
out nPriority): HResult;
stdcall;
function OnLowResource(reserved: DWORD): HResult;
stdcall;
function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
szStatusText: LPCWSTR): HResult;
stdcall;
function OnStopBinding(HResult: HResult; szError: LPCWSTR)
: HResult;
stdcall;
function GetBindInfo(
out grfBINDF: DWORD;
var bindinfo: TBindInfo)
: HResult;
stdcall;
function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD;
formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
stdcall;
function OnObjectAvailable(
const IID: TGUID; punk: IUnknown)
: HResult;
stdcall;
end;
var
frmUpdate: TfrmUpdate;
actual_version, last_version, waiting:
string;
cDownStatus: cDownloadStatusCallback;
Datei, Ziel: PChar;
rounds: Integer;
usercancel: Boolean = False;
implementation
{$R *.dfm}
procedure TfrmUpdate.btnUpdateCheckClick(Sender: TObject);
begin
if btnUpdateCheck.Tag = 1
then
begin
waiting := '
';
rounds := 0;
sleep(10);
MemoInfo.clear;
application.ProcessMessages;
cDownStatus := cDownloadStatusCallback.Create;
try
Datei := '
http://www.DeineHP.de/Setup.exe';
Ziel := '
Setup.exe';
UrlDownloadToFile(
nil, Datei, Ziel, 0, cDownStatus);
if MessageBox(0, '
DOWNLOAD COMPLETE, RESTART', '
Info',
MB_OKCANCEL) = IDOK
then
Begin
ShellExecute(application.Handle, '
open', PChar('
Setup.exe'),
nil,
nil, SW_ShowNormal);
application.terminate;
End
else
begin
btnUpdateCheck.Caption := '
Please install Update';
btnUpdateCheck.Enabled := False;
Exit;
end;
except
showmessage('
Download aborted!');
end;
end;
if btnUpdateCheck.Tag = 0
then
begin
MemoInfo.clear;
last_version := GetHTML('
http://www.DeineHP.de/version.txt');
if actual_version <> last_version
then
begin
MemoInfo.lines.add('
NEW UPDATE AVAILABLE! ' + last_version);
MemoInfo.lines.add
('
PRESS "DOWNLOAD NEW UPDATE NOW!" Button to get newest update!');
btnUpdateCheck.Tag := 1;
btnUpdateCheck.Caption := '
DOWNLOAD NEW UPDATE NOW!';
btnUpdateCheck.font.size := 18;
btnUpdateCheck.font.style := [fsBold];
end
else
begin
MemoInfo.lines.add('
YOU USE THE LATEST AVAILABLE VERSION');
MemoInfo.lines.add(GetHTML('
http://www.DeineHP.de/news.txt'));
MemoInfo.Perform(WM_VSCROLL, SB_TOP, 0);
end;
end;
end;
function cDownloadStatusCallback._AddRef: Integer;
begin
Result := 0;
end;
function cDownloadStatusCallback._Release: Integer;
begin
Result := 0;
end;
function cDownloadStatusCallback.QueryInterface(
const IID: TGUID;
out Obj): HResult;
begin
if (GetInterface(IID, Obj))
then
begin
Result := 0
end
else
begin
Result := E_NOINTERFACE;
end;
end;
function cDownloadStatusCallback.OnStartBinding(dwReserved: DWORD;
pib: IBinding): HResult;
begin
Result := S_OK;
end;
function cDownloadStatusCallback.GetPriority(
out nPriority): HResult;
begin
Result := S_OK;
end;
function cDownloadStatusCallback.OnLowResource(reserved: DWORD): HResult;
begin
Result := S_OK;
end;
function cDownloadStatusCallback.OnStopBinding(HResult: HResult;
szError: LPCWSTR): HResult;
stdcall;
begin
Result := S_OK;
end;
function cDownloadStatusCallback.GetBindInfo(
out grfBINDF: DWORD;
var bindinfo: TBindInfo): HResult;
stdcall;
begin
Result := S_OK;
end;
function cDownloadStatusCallback.OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD;
formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin
Result := S_OK;
end;
function cDownloadStatusCallback.OnObjectAvailable(
const IID: TGUID;
punk: IUnknown): HResult;
stdcall;
begin
Result := S_OK;
end;
function cDownloadStatusCallback.OnProgress(ulProgress, ulProgressMax,
ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
begin
case ulStatusCode
of
BINDSTATUS_FINDINGRESOURCE:
begin
frmUpdate.MemoInfo.lines.add('
File found on server.');
if (usercancel)
then
begin
Result := E_ABORT;
Exit;
end;
end;
BINDSTATUS_CONNECTING:
begin
frmUpdate.MemoInfo.lines.add('
Connecting to Server..');
if (usercancel)
then
begin
Result := E_ABORT;
Exit;
end;
end;
BINDSTATUS_BEGINDOWNLOADDATA:
begin
frmUpdate.Fortschritt.Position := 0;
frmUpdate.MemoInfo.lines.add('
Start Downloading...');
if (usercancel)
then
begin
Result := E_ABORT;
Exit;
end;
end;
BINDSTATUS_DOWNLOADINGDATA:
begin
frmUpdate.Fortschritt.Position :=
MulDiv(ulProgress, 100, ulProgressMax);
// Form1.memo2.lines.add('Downloading.. PLEASE WAIT');
rounds := rounds + 1;
// if rounds = 50 then
// begin
// rounds := 0;
// frmUpdate.MemoInfo.lines.Delete(frmUpdate.MemoInfo.lines.Count - 1);
// waiting := waiting + '.';
// frmUpdate.MemoInfo.lines.add('Downloading new Update' + waiting);
// end;
if (usercancel)
then
begin
Result := E_ABORT;
Exit;
end;
end;
BINDSTATUS_ENDDOWNLOADDATA:
begin
frmUpdate.MemoInfo.lines.add('
DOWNLOAD FINISHED!');
end;
end;
Result := S_OK;
end;
Function TfrmUpdate.GetHTML(AUrl:
string):
string;
var
databuffer:
array [0 .. 4095]
of char;
ResStr:
string;
hSession, hfile: hInternet;
dwindex, dwcodelen, dwread, dwNumber: cardinal;
dwcode:
array [1 .. 20]
of char;
res: PChar;
Str: PChar;
begin
ResStr := '
';
Result := '
';
if pos('
http://', lowercase(AUrl)) = 0
then
AUrl := '
http://' + AUrl;
hSession := InternetOpen('
InetURL:/1.0', INTERNET_OPEN_TYPE_PRECONFIG,
nil,
nil, 0);
If assigned(hSession)
Then
Try
hfile := InternetOpenUrl(hSession, PChar(AUrl),
nil, 0,
INTERNET_FLAG_RELOAD, 0);
if assigned(hfile)
then
Try
dwindex := 0;
dwcodelen := 10;
HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode,
dwcodelen, dwindex);
res := PChar(@dwcode);
dwNumber := sizeof(databuffer) - 1;
if (res = '
200')
or (res = '
302')
then
begin
while (InternetReadfile(hfile, @databuffer, dwNumber, dwread))
AND
(dwread <> 0)
do
begin
databuffer[dwread] := #0;
Str := PChar(@databuffer);
ResStr := ResStr + Str;
end;
end
else
ResStr := '
Status:' + res;
Finally
InternetCloseHandle(hfile);
End;
Finally
InternetCloseHandle(hSession);
End;
Result := ResStr;
end;
end.