Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Общие вопросы Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 15.02.2014, 10:25   #1
mogo
Пользователь
 
Регистрация: 12.02.2014
Сообщений: 40
По умолчанию Пинг до сайта

Как определить пинг до сайта? Именно до сайта а не ип.
mogo вне форума Ответить с цитированием
Старый 15.02.2014, 10:56   #2
doktor255
Заблокирован
 
Регистрация: 31.03.2011
Сообщений: 976
По умолчанию

Код:
procedure Ping(IP: String; OutS: TStrings);
const BUFSIZE = 2000;
var SecAttr: TSecurityAttributes;
hReadPipe, hWritePipe: THandle;
StartupInfo: TStartUpInfo;
ProcessInfo: TProcessInformation;
Buffer: PAnsiChar;
WaitReason, BytesRead: DWord;
begin with SecAttr do begin
nlength := SizeOf(TSecurityAttributes);
binherithandle := true;
lpsecuritydescriptor := nil;
end;
if Createpipe(hReadPipe, hWritePipe, @SecAttr, 0) then begin
Buffer := AllocMem(BUFSIZE + 1);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.hStdOutput := hWritePipe;
StartupInfo.hStdInput := hReadPipe;
StartupInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_HIDE;
if CreateProcess(nil, PChar('ping.exe ' + IP), @SecAttr, @SecAttr, true, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo)
then begin
repeat WaitReason := WaitForSingleObject(ProcessInfo.hProcess, 100);
Application.ProcessMessages;
until (WaitReason <> WAIT_TIMEOUT);
Repeat BytesRead := 0;
ReadFile(hReadPipe, Buffer[0], BUFSIZE, BytesRead, nil); Buffer[BytesRead] := #0;
OemToAnsi(Buffer, Buffer); OutS.Add(String(Buffer));
until (BytesRead < BUFSIZE);
end;
FreeMem(Buffer);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(hReadPipe);
CloseHandle(hWritePipe);
end;
end;
Указывай IP сайта, смотри всю информацию.

Последний раз редактировалось doktor255; 15.02.2014 в 10:59.
doktor255 вне форума Ответить с цитированием
Старый 15.02.2014, 11:31   #3
mogo
Пользователь
 
Регистрация: 12.02.2014
Сообщений: 40
По умолчанию

Цитата:
Сообщение от doktor255 Посмотреть сообщение
Код:
procedure Ping(IP: String; OutS: TStrings);
const BUFSIZE = 2000;
var SecAttr: TSecurityAttributes;
hReadPipe, hWritePipe: THandle;
StartupInfo: TStartUpInfo;
ProcessInfo: TProcessInformation;
Buffer: PAnsiChar;
WaitReason, BytesRead: DWord;
begin with SecAttr do begin
nlength := SizeOf(TSecurityAttributes);
binherithandle := true;
lpsecuritydescriptor := nil;
end;
if Createpipe(hReadPipe, hWritePipe, @SecAttr, 0) then begin
Buffer := AllocMem(BUFSIZE + 1);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.hStdOutput := hWritePipe;
StartupInfo.hStdInput := hReadPipe;
StartupInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_HIDE;
if CreateProcess(nil, PChar('ping.exe ' + IP), @SecAttr, @SecAttr, true, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo)
then begin
repeat WaitReason := WaitForSingleObject(ProcessInfo.hProcess, 100);
Application.ProcessMessages;
until (WaitReason <> WAIT_TIMEOUT);
Repeat BytesRead := 0;
ReadFile(hReadPipe, Buffer[0], BUFSIZE, BytesRead, nil); Buffer[BytesRead] := #0;
OemToAnsi(Buffer, Buffer); OutS.Add(String(Buffer));
until (BytesRead < BUFSIZE);
end;
FreeMem(Buffer);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(hReadPipe);
CloseHandle(hWritePipe);
end;
end;
Указывай IP сайта, смотри всю информацию.
Я же говрил что нужно по хосту проверять а не по ип...
mogo вне форума Ответить с цитированием
Старый 15.02.2014, 11:33   #4
mogo
Пользователь
 
Регистрация: 12.02.2014
Сообщений: 40
По умолчанию

Нашел вот такой пример:

Код:
function gethostbyname;     external    winsocket name 'gethostbyname';

ip := gethostbyname('www.mail.ru');
Но ругается на функцию

Код:
warning W1000: W1000 Symbol 'Resume' is deprecated
error E2023: E2023 Function needs result type
error E2003: E2003 Undeclared identifier: 'winsocket'
mogo вне форума Ответить с цитированием
Старый 15.02.2014, 11:42   #5
Stilet
Белик Виталий :)
Старожил
 
Аватар для Stilet
 
Регистрация: 23.07.2007
Сообщений: 57,792
По умолчанию

Дай бог памяти, юзается кажись так:
Код:
uses    winsock2,  windows, 
...
var he:PHostEnt; wd:TWSAData;
begin
  WSAStartup(MAKEWORD( 2, 0 ),wd);
  he:=gethostbyname('localhost');
  if he=nil then Caption:=SysErrorMessageUTF8(WSAGetLastError)
  else  Caption:=he^.h_addr^;
end;
I'm learning to live...

Последний раз редактировалось Stilet; 15.02.2014 в 11:45.
Stilet вне форума Ответить с цитированием
Старый 15.02.2014, 11:50   #6
mogo
Пользователь
 
Регистрация: 12.02.2014
Сообщений: 40
По умолчанию

Цитата:
Сообщение от Stilet Посмотреть сообщение
Дай бог памяти, юзается кажись так:
Код:
uses    winsock2,  windows, 
...
var he:PHostEnt; wd:TWSAData;
begin
  WSAStartup(MAKEWORD( 2, 0 ),wd);
  he:=gethostbyname('localhost');
  if he=nil then Caption:=SysErrorMessageUTF8(WSAGetLastError)
  else  Caption:=he^.h_addr^;
end;
Код:
[dcc32 Warning] Unit1.pas(404): W1000 Symbol 'Resume' is deprecated
[dcc32 Error] Unit1.pas(417): E2003 Undeclared identifier: 'SysErrorMessageUTF8'
[dcc32 Warning] Unit1.pas(418): W1057 Implicit string cast from 'AnsiChar' to 'string'
mogo вне форума Ответить с цитированием
Старый 15.02.2014, 15:40   #7
Stilet
Белик Виталий :)
Старожил
 
Аватар для Stilet
 
Регистрация: 23.07.2007
Сообщений: 57,792
По умолчанию

Ох... Ну так убери эту функцию. Замени ее другой, которая код ошибки превращает в сообщение.
I'm learning to live...
Stilet вне форума Ответить с цитированием
Старый 15.02.2014, 16:58   #8
Розетко
Пользователь
 
Аватар для Розетко
 
Регистрация: 05.12.2013
Сообщений: 21
По умолчанию

Код:
procedure Ping(Host: String; OutS: TStrings);
const BUFSIZE = 2000;
var SecAttr: TSecurityAttributes;
    hReadPipe, hWritePipe: THandle;
    StartupInfo: TStartUpInfo;
    ProcessInfo: TProcessInformation;
    Buffer: PAnsiChar;
    WaitReason, BytesRead: DWord;
    Ip: String;
function HostToIp(const Host: AnsiString): string;
var WSAData: TWsaData;
    HostEnt:PHostEnt;
begin
  if not WSAStartup($0202, WSAData) = SOCKET_ERROR then
  begin
    HostEnt := gethostbyname(PAnsiChar(Host));
    if not(HostEnt = nil) then
      Result := inet_ntoa(PInAddr(HostEnt.H_ADDR_LIST^)^)
    else Result := 'Error: '+IntToStr(WSAGetLastError);
  end;
  WSACleanup;
end;
begin
  Ip := HostToIp(AnsiString(Host));
  with SecAttr do begin
    nlength := SizeOf(TSecurityAttributes);
    binherithandle := true;
    lpsecuritydescriptor := nil;
  end;
  if Createpipe(hReadPipe, hWritePipe, @SecAttr, 0) then begin
    Buffer := AllocMem(BUFSIZE + 1);
    FillChar(StartupInfo, SizeOf(StartupInfo), #0);
    StartupInfo.cb := SizeOf(StartupInfo);
    StartupInfo.hStdOutput := hWritePipe;
    StartupInfo.hStdInput := hReadPipe;
    StartupInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
    StartupInfo.wShowWindow := SW_HIDE;
    if CreateProcess(nil, PChar('ping.exe ' + IP), @SecAttr, @SecAttr, true, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo)
    then begin
      repeat WaitReason := WaitForSingleObject(ProcessInfo.hProcess, 100);
        Application.ProcessMessages;
      until (WaitReason <> WAIT_TIMEOUT);

      repeat BytesRead := 0;
        ReadFile(hReadPipe, Buffer[0], BUFSIZE, BytesRead, nil); Buffer[BytesRead] := #0;
        OemToAnsi(Buffer, Buffer); OutS.Add(String(Buffer));
      until (BytesRead < BUFSIZE);
    end;
    FreeMem(Buffer);
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
    CloseHandle(hReadPipe);
    CloseHandle(hWritePipe);
  end;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var Pn: TStringList;
begin
  Pn  := TStringList.Create;
  try
    Ping('vk.com', Pn);
    Memo1.Lines.AddStrings(Pn);
  finally
    FreeAndNil(Pn);
  end;
end;
Изображения
Тип файла: png 2.png (11.1 Кб, 49 просмотров)
NНOGΔΛ MHΣ KΛЖΣTСЯ, 4TO MΣHЯ HΣ ПОНNМΛЮТ :[

Последний раз редактировалось Розетко; 15.02.2014 в 17:09.
Розетко вне форума Ответить с цитированием
Старый 15.02.2014, 17:49   #9
mogo
Пользователь
 
Регистрация: 12.02.2014
Сообщений: 40
По умолчанию

Цитата:
Сообщение от Розетко Посмотреть сообщение
Код:
procedure Ping(Host: String; OutS: TStrings);
const BUFSIZE = 2000;
var SecAttr: TSecurityAttributes;
    hReadPipe, hWritePipe: THandle;
    StartupInfo: TStartUpInfo;
    ProcessInfo: TProcessInformation;
    Buffer: PAnsiChar;
    WaitReason, BytesRead: DWord;
    Ip: String;
function HostToIp(const Host: AnsiString): string;
var WSAData: TWsaData;
    HostEnt:PHostEnt;
begin
  if not WSAStartup($0202, WSAData) = SOCKET_ERROR then
  begin
    HostEnt := gethostbyname(PAnsiChar(Host));
    if not(HostEnt = nil) then
      Result := inet_ntoa(PInAddr(HostEnt.H_ADDR_LIST^)^)
    else Result := 'Error: '+IntToStr(WSAGetLastError);
  end;
  WSACleanup;
end;
begin
  Ip := HostToIp(AnsiString(Host));
  with SecAttr do begin
    nlength := SizeOf(TSecurityAttributes);
    binherithandle := true;
    lpsecuritydescriptor := nil;
  end;
  if Createpipe(hReadPipe, hWritePipe, @SecAttr, 0) then begin
    Buffer := AllocMem(BUFSIZE + 1);
    FillChar(StartupInfo, SizeOf(StartupInfo), #0);
    StartupInfo.cb := SizeOf(StartupInfo);
    StartupInfo.hStdOutput := hWritePipe;
    StartupInfo.hStdInput := hReadPipe;
    StartupInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
    StartupInfo.wShowWindow := SW_HIDE;
    if CreateProcess(nil, PChar('ping.exe ' + IP), @SecAttr, @SecAttr, true, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo)
    then begin
      repeat WaitReason := WaitForSingleObject(ProcessInfo.hProcess, 100);
        Application.ProcessMessages;
      until (WaitReason <> WAIT_TIMEOUT);

      repeat BytesRead := 0;
        ReadFile(hReadPipe, Buffer[0], BUFSIZE, BytesRead, nil); Buffer[BytesRead] := #0;
        OemToAnsi(Buffer, Buffer); OutS.Add(String(Buffer));
      until (BytesRead < BUFSIZE);
    end;
    FreeMem(Buffer);
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
    CloseHandle(hReadPipe);
    CloseHandle(hWritePipe);
  end;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var Pn: TStringList;
begin
  Pn  := TStringList.Create;
  try
    Ping('vk.com', Pn);
    Memo1.Lines.AddStrings(Pn);
  finally
    FreeAndNil(Pn);
  end;
end;
Спасибо! То что нужно.
mogo вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Неустойчивый пинг WorldMaster Windows 6 28.04.2013 23:19
Определить пинг Shouldercannon Общие вопросы Delphi 10 26.05.2011 21:32
Пинг в зоне рф Баламут Свободное общение 20 02.12.2010 12:48
Как узнать пинг до сайта? TwiX Работа с сетью в Delphi 9 15.02.2010 09:13