DBR Delphi-Ecke

// Hiermit kann man testen, ob eine Internetverbindung besteht.

// Variante 0.9

// Getestet mit D2010 unter W7

function connect(lpdwFlags: LPDWORD): Boolean; 
const 
  DLL = 'wininet.dll'; 
var 
  hDLL: THandle; 
  State: function(lpdwFlags: LPDWORD; dwReserved: DWORD): BOOL; 
stdcall; 
begin 
  Result := false; 
  hDLL := LoadLibrary(DLL); 
  if hDLL > 0 then 
  begin 
    @State := GetProcAddress(hDLL, 'InternetGetConnectedState'); 
    if Assigned(State) then 
    begin 
      Result := State(lpdwFlags, 0); 
    end; 
    FreeLibrary(hDLL); 
  end; 
end; 
 
function inet: Boolean; 
var 
  dw: Cardinal; 
begin 
  try 
    dw := 15; 
    Result := connect(@dw); 
  except 
    Result := false; 
  end; 
end; 
 
// Beispielaufruf 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if inet then 
    showmessage('Verbindung steht') 
  else 
    showmessage('keine Verbindung'); 
end;

// Variante 1 (Nachteil: Nicht für NT oder höher)
// Wenn man Dauertest gleich True setzt, wird sofort ab Programmstart
// (je nach Wert in TestIntervall) laufend geprüft.

// Getestet mit D4 unter WinME

type 
  TForm1 = class(TForm) 
    Timer1: TTimer; 
    Label1: TLabel; 
    Button1: TButton; 
    Button2: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
  private 
{ Private-Deklarationen } 
  public 
    function testen: boolean; 
    procedure auswertung; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
uses registry; 
 
var 
  Reg: TRegistry; 
 
const 
  TestIntervall: cardinal = 1000; // einmal pro Sekunde 
  DauerTest: boolean = false; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Reg := TRegistry.Create; 
  Reg.RootKey := HKEY_LOCAL_MACHINE; 
  if DauerTest then 
    timer1.interval := TestIntervall 
  else timer1.interval := 0; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  Reg.Free; 
end; 
 
procedure TForm1.auswertung; 
begin 
  if testen then label1.caption := 'Es besteht eine Verbindung' 
  else label1.caption := 'keine Verbindung'; 
end; 
 
function TForm1.testen: boolean; 
var 
  buff: array[0..3] of byte; 
begin 
  result := false; 
  try 
    if Reg.OpenKey('\System\CurrentControlSet\Services\RemoteAccess', false) 
      then begin 
      Reg.ReadBinaryData('Remote Connection', buff, 4); 
      result := longword(buff) <> 0; 
    end; 
  finally 
    Reg.CloseKey; 
  end; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  auswertung; 
end; 
 
// Einmal-Test 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  auswertung; 
end; 
 
// Dauertest 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  timer1.interval := TestIntervall; 
end;

// Variante 2 (Nachteil: Es muss eine zusätzliche Unit eingebunden werden)
// (auf einen Dauertest wird in diesem Beispiel verzichtet)

// Getestet mit D4 unter XP und ME

uses wininet; 
 
function InetVerbindung: boolean; 
var 
  flags: DWord; 
begin 
  if InternetGetConnectedState(@flags, 0) then begin 
    result := ((flags and $40) > 0) and ((flags and $20) = 0); 
  end else result := false; 
end; 
 
// Beispielaufruf 
procedure TForm1.Button1Click(Sender: TObject); 
var meld: string; 
begin 
  meld := 'Es ist '; 
  if not inetverbindung then meld := meld + 'k'; 
  meld := meld + 'eine Internetverbindung vorhanden.'; 
  showmessage(meld); 
end;

// Variante 3 (Weiterführung der Variante 2)

// Getestet mit D4 unter XP und ME

uses wininet; 
  
procedure TForm1.Button1Click(Sender: TObject); 
var 
  flags: DWord; 
  meld: string; 
const 
  no = 'Es besteht im Moment keine Internetverbindung.'; 
begin 
  if InternetGetConnectedState(@flags, 0) then begin 
    meld := ''; 
    if (flags and $40) = 0 then 
      meld := no else begin 
      meld := 'Es ist eine Internetverbindung eingerichtet.' + #13; 
      if (flags and INTERNET_CONNECTION_LAN) > 0 then 
        meld := meld + 'Die Internetverbindung erfolgt über ein Netzwerk'; 
      if (flags and INTERNET_CONNECTION_MODEM) > 0 then 
        meld := meld + 'Die Internetverbindung erfolgt über ein Modem'; 
      if (flags and INTERNET_CONNECTION_PROXY) > 0 then 
        meld := meld + ' mittels eines Proxy-Servers.' + #13 
      else meld := meld + '.' + #13; 
      if (flags and $20) > 0 then meld := meld + no; 
      if (flags and INTERNET_CONNECTION_MODEM_BUSY) > 0 then 
        meld := meld + 'Das Modem nutzt z.Zt eine andere Verbindung.'; 
      if (flags and $10) > 0 then 
        meld := meld + 'Ein Remote Access Service (RAS) ist installiert.'; 
    end; 
  end else meld := no; 
  showmessage(meld); 
end;