1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
| unit UnitThreadTestReseau;
interface
uses
Classes, SysUtils, Dialogs, Windows;
type
TThreadTestReseau = class(TThread)
private
procedure TestReseau;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean);
end;
implementation
uses Main;
{ ThreadTestReseau }
constructor TThreadTestReseau.Create(CreateSuspended: Boolean);
begin
FreeOnTerminate := True;
inherited Create(CreateSuspended);
end;
procedure TThreadTestReseau.Execute;
begin
try
while not Terminated do
Synchronize(TestReseau);
except
on E: Exception do
begin
MessageDlg('.Erreur : ' + E.Message, mtError, [mbOK], 0);
end;
end;
end;
procedure TThreadTestReseau.TestReseau;
procedure GetConsoleText(const szCommande: String; var szResult: String);
const
LENBUFF = 512; //.Augmenter si problème.
var
hReadPipe, hWritePipe: THandle;
sa: TSecurityAttributes;
si: TStartupInfo;
pi: TProcessInformation;
lpBuffer: Array[0..LENBUFF] of char;
nBytesRead: Cardinal;
nBytesToRead: Integer;
begin
sa.nLength := Sizeof(sa);
sa.lpSecurityDescriptor := nil;
sa.bInheritHandle := True;
if not CreatePipe(hReadPipe, hWritePipe, @sa, 0) then
begin
MessageDlg('.Erreur : la création du pipe a échoué !', mtError, [mbOK], 0);
Exit;
end;
FillChar(si, Sizeof(si), 0);
si.cb := Sizeof(si);
si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
si.wShowWindow := SW_HIDE;
si.hStdInput := 0;
si.hStdOutput := hWritePipe;
si.hStdError := hWritePipe;
if not CreateProcess(nil, PChar(szCommande), nil, nil, True, 0, nil, nil, si, pi) then
begin
MessageDlg('.Erreur : l''exécution de la commande a échoué !', mtError, [mbOK], 0);
CloseHandle(hReadPipe);
CloseHandle(hWritePipe);
Exit;
end;
CloseHandle(hWritePipe);
nBytesToRead := LENBUFF;
nBytesRead := 0;
szResult := '';
while(True) do
begin
lpBuffer := '';
ReadFile(hReadPipe, lpBuffer, nBytesToRead, nBytesRead, nil);
if nBytesRead = 0 then
Break;
szResult := szResult + StrPas(lpBuffer);
end;
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
CloseHandle(hReadPipe);
end;
var
szResult: String;
begin
//.Test du réseau.
GetConsoleText('tnsping ' + MainForm.DatabaseOracle.Params.Values['SERVER NAME'], szResult);
//.Si réseau.
if Pos('OK ', szResult) > 0 then
begin
if not MainForm._Result.bTimeOut then
begin
MainForm._Result.bTimeOut := True;
MainForm._Result.bReseau := True;
end;
end
else //.Pas de réseau.
begin
if not MainForm._Result.bTimeOut then
begin
MainForm._Result.bTimeOut := True;
MainForm._Result.bReseau := False;
end;
end;
Terminate;
end;
end. |