unit F_GBDupdate;
interface
uses
Windows, Messages, Classes,SysUtils, Graphics, Controls, Forms,
Dialogs, UrlMon,
ActiveX, StdCtrls, ComCtrls, Gauges, iniFiles, ExtCtrls, ShellApi,
ZLIB, Spin, WinInet, WinSock , Registry, JvComponentBase, JvEmbeddedForms;
type
TGBD_update =
class(TForm)
Gauge1: TGauge;
Button2: TButton;
Panel1: TPanel;
lcheck: TLabel;
Label4: TLabel;
Label2: TLabel;
jvmbdfrmlnk_GDBUpdate: TJvEmbeddedFormLink;
procedure CheckClick(Sender: TObject);
procedure Button2Click(Sender: TObject);
end;
function IsInternetConnected: Boolean;
function LoadURL(
URL:
String):
String;
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;
public
{ Public-Deklarationen }
end;
var
GBD_update: TGBD_update;
usercancel: Boolean = False;
last_check : Integer;
function DownloadURLToFile_NOCache(
const FileURL, FileName:
String): Cardinal;
implementation
//uses Liveupdate;
{$R *.dfm}
function cDownloadStatusCallback._AddRef: Integer;
begin
Result := 0;
end;
function IsInternetConnected: Boolean;
var
dwConnectionTypes: DWORD;
wsadata : TWsaData;
hostent : pHostent;
begin
dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY+INTERNET_CONNECTION_MODEM_BUSY;
if InternetGetConnectedState(@dwConnectionTypes, 0)
then
Result := True
else
// not connected
// Versuch ne Verbindung aufzubauen
if not InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE
or
INTERNET_AUTODIAL_FORCE_UNATTENDED, 0)
then
// Error
Result := False
else
Result := InternetGetConnectedState(@dwConnectionTypes, 0);
if(Result)
then
begin
if(WsaStartup(MAKEWORD(1,0),wsadata) = 0)
then
begin
hostent := GetHostByName('
www.holfter.com');
Result := assigned(hostent);
end;
WsaCleanup;
end;
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;
var
dwConnectionTypes: DWORD;
begin
case ulStatusCode
of
BINDSTATUS_FINDINGRESOURCE:
begin
GBD_update.Label4.Caption := '
Datei wurde gefunden...';
if (usercancel)
then
begin
Result := E_ABORT;
exit;
end;
end;
BINDSTATUS_CONNECTING:
begin
GBD_update.Label4.Caption := '
Es wird verbunden...';
if (usercancel)
then
begin
Result := E_ABORT;
exit;
end;
end;
BINDSTATUS_BEGINDOWNLOADDATA:
begin
GBD_Update.Gauge1.Progress := 0;
GBD_update.Label4.Caption := '
Der Download wurde gestartet...';
if (UserCancel)
then
begin
Result := E_ABORT;
exit;
end;
end;
BINDSTATUS_DOWNLOADINGDATA:
begin
GBD_UPDATE.Gauge1.Progress := MulDiv(ulProgress,100,ulProgressMax);
GBD_update.Label4.Caption := '
Datei wird heruntergeladen...';
if (UserCancel)
then
begin
Result := E_ABORT; exit;
end;
end;
BINDSTATUS_ENDDOWNLOADDATA:
begin
GBD_update.Label4.Caption := '
Download wurd beendet...';
dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
if InternetGetConnectedState(@dwConnectionTypes, 0)
then
// connected
InternetAutodialHangup(0);
end;
end;
Application.ProcessMessages;
Result := S_OK;
end;
procedure TGBD_update.CheckClick(Sender: TObject);
var
cDownStatus : cDownloadStatusCallback;
begin
If IsInternetConnected
then
begin
cDownStatus := cDownloadStatusCallBack.Create;
try
Panel1.Visible := True;
Label4.Caption :='
Download, bitte jetzt starten';
finally
cDownStatus.Free;
end;
end
else
MessageDlg('
Keine Internetverbindung, bitte herstellen und noch einmal versuchen',
mtError, [mbOK], 0 ) ;
end;
procedure TGBD_update.Button2Click(Sender: TObject);
var
cDownStatus : cDownloadStatusCallback;
FilePath:
String;
begin
GBD_update:=self;
cDownStatus := cDownloadStatusCallBack.Create;
FilePath := ExtractFilePath(Application.ExeName);
if not DirectoryExists(FilePath)
then
if not CreateDir(FilePath)
then
raise Exception.Create('
Cannot create '+FilePath);
try
FilePath := ExtractFilePath(Application.ExeName)+'
Daten.Dat';
// zuerst den Cache löschen !!!
DeleteUrlCacheEntry('
http://www.xyz.com/Daten.Dat');
URLDownloadToFIle(
nil,'
http://www.xyz.com/Daten.Dat',
PCHAR(FilePath),0,CDownStatus);
if FileExists(FilePath)
then
DeCompress(FilePath,ExtractFilePath(Application.ExeName))
else
MessageDlg('
Datenupdatedatei wurde nicht geladen, bitte später noch einmal versuchen',
mtError, [mbOK], 0 ) ;
finally
cDownStatus.Free;
GBD_update:=nil;
end;
end;
function LoadURL(
URL:
String):
String;
var
IOpen, IURL: HINTERNET;
Read: Cardinal;
Msg:
string;
// <==
begin
Result := '
';
try
IOpen := InternetOpen(
'
Mozilla 3.0 (compatible)',
INTERNET_OPEN_TYPE_PRECONFIG, '
', '
',
INTERNET_FLAG_NEED_FILE
);
if IOpen <>
nil then
try
IURL := InternetOpenUrl(IOpen, PChar(
URL),
nil, 0,
INTERNET_FLAG_NO_UI, 0);
if IURL <>
nil then
try
SetLength(Msg, 4096);
// <====
repeat
if InternetReadFile(IURL, @Msg[1], 4096,
Read)
then // <===
Result := Result + Copy(Msg, 1,
Read)
// <===
else
Break;
until Read = 0;
finally
InternetCloseHandle(IURL);
end;
finally
InternetCloseHandle(IOpen);
end;
except
end;
end;
function DownloadURLToFile_NOCache(
const FileURL, FileName:
String): Cardinal;
var
hSession, hFile: HInternet;
Buffer:
array[1..1024]
of Byte;
BufferLen, fSize: LongWord;
f:
File;
begin
Result := 0;
hSession := InternetOpen('
MyApp', INTERNET_OPEN_TYPE_PRECONFIG,
nil,
nil, 0);
if Assigned(hSession)
then begin
hFile := InternetOpenURL(hSession, PChar(FileURL),
nil, 0, INTERNET_FLAG_RELOAD, 0);
if Assigned(hFile)
then
begin
AssignFile(f, FileName);
// Kann auch durch einen Filestream ersetzt werden
Rewrite(f,1);
fSize := 0;
repeat
InternetReadFile(hFile, @Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen);
fSize := fSize + BufferLen;
until (BufferLen = 0);
CloseFile(f);
Result := fSize;
InternetCloseHandle(hFile);
end;
InternetCloseHandle(hSession);
end;
end;
end.