Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

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

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

Ответ
 
Опции темы
Старый 10.10.2017, 10:06   #1
Sairox
 
Регистрация: 10.10.2017
Сообщений: 9
Репутация: 10
По умолчанию Ping

Добрый день! Пишу программу на delphi ping ip адресов. Хочется реализовать чтобы если есть пинг то компонент TListView заносились адрес и в сети он или нет. Программу дописал но не могу это реазиловать. Что если есть пинг то заносился в строку и был зеленым , если нет пинга то красным. Вот исходный код программы. Подскажите пожалуйста.
Код:

unit Main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.ComCtrls,
  Vcl.XPMan;

type
  TfmMain = class(TForm)
    edtAddress: TEdit;
    butPing: TButton;
    memResult: TMemo;
    Memo1: TMemo;
    ListView1: TListView;
    Button1: TButton;
    Timer1: TTimer;
    XPManifest1: TXPManifest;
    ListBox1: TListBox;
    procedure butPingClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmMain: TfmMain;

implementation

{$R *.dfm}

procedure DoPing(Address: String; OutText: TStrings);
const
	READ_SIZE = 4096;
var
	SecAttr: TSecurityAttributes;
	hRP, hWP: THandle;
	StartInfo: TStartUpInfo;
	ProcInfo: TProcessInformation;
	buf: PAnsiChar;
	ReadSize: DWORD;
begin
  SecAttr.nlength := SizeOf(TSecurityAttributes);
  SecAttr.binherithandle := True;
  SecAttr.lpsecuritydescriptor := nil;
	if Createpipe(hRP, hWP, @SecAttr, 0) then
  try
		buf := AllocMem(READ_SIZE + 1);
		FillChar(StartInfo, SizeOf(TStartUpInfo), #0);
		StartInfo.cb := SizeOf(TStartUpInfo);
		StartInfo.hStdOutput := hWP;
		StartInfo.hStdInput := hRP;
		StartInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
		StartInfo.wShowWindow := SW_HIDE;
		if CreateProcess(nil, PChar('ping.exe ' + Address), @SecAttr, @SecAttr, True, NORMAL_PRIORITY_CLASS, nil, nil, StartInfo, ProcInfo) then
    try
      while WaitForSingleObject(ProcInfo.hProcess, 100) = WAIT_TIMEOUT do
        Application.ProcessMessages;
      ReadSize := READ_SIZE+1;
      while ReadSize > READ_SIZE do
      begin
				ReadFile(hRP, buf[0], READ_SIZE, ReadSize, nil);
				buf[ReadSize] := #0;
				OemToAnsi(buf, buf);
				OutText.Add(String(buf));
			end;
    finally
      CloseHandle(ProcInfo.hProcess);
		  CloseHandle(ProcInfo.hThread);
		end;
  finally
		FreeMem(buf);
		CloseHandle(hRP);
		CloseHandle(hWP);
	end;
end;

procedure TfmMain.butPingClick(Sender: TObject);
var a:integer;
    Item: TListItem;
  begin
  if Memo1.Lines.Count <> 0 then // проверяем, не пустое ли мемо
  begin
  Memo1.Lines.LoadFromFile('ip.conf');
  for a := 0 to Memo1.Lines.Count-1 do
  begin
  edtAddress.Text:= Memo1.Lines[a]; //копируем 1ю строку мемо в эдит
  begin
 if (edtAddress.text = '') then

 Item := TListItem.Create(ListView1.Items);
 Item.Caption := edtAddress.Text;
 listview1.Font.color:=clgreen;
 Item.SubItems.Add('В сети');
  ListView1.Items.Insert(0);
 ListView1.Items.Item[0] := Item;
 Item.Free;
  end;


  butPing.Enabled := False;
  try

    DoPing(edtAddress.Text, memResult.Lines);
  finally
    butPing.Enabled := True;
  end;
  end;
  end;
end;

procedure TfmMain.Button1Click(Sender: TObject);
begin
  sleep(10000)
end;

end.

_____
Код программы нужно выделять (форматировать) тегами [CODE] (читать FAQ)
Модератор

Последний раз редактировалось Serge_Bliznykov; 10.10.2017 в 10:36.
Sairox вне форума   Ответить с цитированием
Старый 10.10.2017, 10:37   #2
min@y™
Цифровой кот
Профессионал
 
Аватар для min@y™
 
Регистрация: 29.08.2014
Адрес: 1600, пенсильвания-авеню, п.г.т. верхний Вашингтонск, 8126 км от МКАД, от поста ГАИ - налево.
Сообщений: 7,636
Репутация: 2371

icq: 100500
skype: kick-ass
По умолчанию

__________________
Расскажу я вам, дружочки, как выращивать грибочки: нужно в поле утром рано сдвинуть два куска урана...
min@y™ вне форума   Ответить с цитированием
Старый 10.10.2017, 10:44   #3
Serge_Bliznykov
МегаМодератор
СуперМодератор
 
Регистрация: 09.01.2008
Сообщений: 24,499
Репутация: 5308
По умолчанию

Цитата:
Сообщение от Sairox Посмотреть сообщение
Код:

procedure TfmMain.Button1Click(Sender: TObject);
begin
  sleep(10000)
end;

ОМГ! Зачем? Зачем на кнопку вызов sleep'а?! Вы хотите проверить, реально ли sleep полностью замораживает форму и она перестаёт отвечать на все запросы? или что-то другое?
Serge_Bliznykov вне форума   Ответить с цитированием
Старый 10.10.2017, 11:29   #4
Sairox
 
Регистрация: 10.10.2017
Сообщений: 9
Репутация: 10
По умолчанию

Вы меня не поняли раскрасить получилось, мне нужно создать цикл проверки если есть пинг то зеленый, если нету то красный.
Sairox вне форума   Ответить с цитированием
Старый 10.10.2017, 11:34   #5
Sairox
 
Регистрация: 10.10.2017
Сообщений: 9
Репутация: 10
По умолчанию

Да хотел проверить перестанет отвечать на запрос или нет.
Sairox вне форума   Ответить с цитированием
Старый 10.10.2017, 11:50   #6
Serge_Bliznykov
МегаМодератор
СуперМодератор
 
Регистрация: 09.01.2008
Сообщений: 24,499
Репутация: 5308
По умолчанию

Цитата:
Сообщение от Sairox Посмотреть сообщение
Да хотел проверить перестанет отвечать на запрос или нет.
и как - перестало? а зачем Вы это делали? Какой смысл?
И почему не убрали это безумие из своего кода после того, как проверили?


Цитата:
Сообщение от Sairox Посмотреть сообщение
Вы меня не поняли раскрасить получилось, мне нужно создать цикл проверки
Вы адрес для пинга берёте из текстового контрола edtAddress

А если делать цикл, то от чего и до чего его делать? Все возможные IP в сети Интернет хотите пингануть? Так это многовато, не дождётесь окончания.
Или есть какой-то конкретный диапазон?
Serge_Bliznykov вне форума   Ответить с цитированием
Старый 10.10.2017, 12:02   #7
Sairox
 
Регистрация: 10.10.2017
Сообщений: 9
Репутация: 10
По умолчанию

Есть конкретный диапозон берется с текстового документа.
Sairox вне форума   Ответить с цитированием
Старый 10.10.2017, 12:22   #8
Serge_Bliznykov
МегаМодератор
СуперМодератор
 
Регистрация: 09.01.2008
Сообщений: 24,499
Репутация: 5308
По умолчанию

Цитата:
Сообщение от Sairox Посмотреть сообщение
Есть конкретный диапозон берется с текстового документа.
тогда в чём вопрос то?

примерно так:
Код:

var
  sl, slRez : TStringList;

.....


 sl :=  TStringList.Create;
 slRez := TStringList.Create; 
 sl.LoadFromFile('ПутьКВашемуТекстовомуФайлу.txt');
 butPing.Enabled := False;
 for i:=0 to sl.Count-1 do begin
   slRez.Clear;
   DoPing(sl.Strings[i], slRez);
   Item := ListView1.Items.Add;
   Item.Caption := sl.Strings[i]; 
   if slRez.Count>0 then
     Item.SubItems.Add('В сети')
   else
     Item.SubItems.Add('не в сети');
 end;

 ...

 FreeAndNil(sl);
 FreeAndNil(slRez);

Serge_Bliznykov вне форума   Ответить с цитированием
Старый 10.10.2017, 13:07   #9
min@y™
Цифровой кот
Профессионал
 
Аватар для min@y™
 
Регистрация: 29.08.2014
Адрес: 1600, пенсильвания-авеню, п.г.т. верхний Вашингтонск, 8126 км от МКАД, от поста ГАИ - налево.
Сообщений: 7,636
Репутация: 2371

icq: 100500
skype: kick-ass
По умолчанию


10.png
__________________
Расскажу я вам, дружочки, как выращивать грибочки: нужно в поле утром рано сдвинуть два куска урана...
min@y™ вне форума   Ответить с цитированием
Старый 10.10.2017, 17:21   #10
Black Fregat
Программист
Профессионал
 
Аватар для Black Fregat
 
Регистрация: 23.06.2009
Сообщений: 1,067
Репутация: 754
По умолчанию

Что за поветрие пошло - постить всё картинками
Black Fregat вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
ping ramm_89 Работа с сетью в Delphi 2 31.07.2016 23:46
Ping Drago56 C/C++ Сетевое программирование 2 02.02.2016 16:41
[ping] unbanned Работа с сетью в Delphi 6 09.07.2013 14:06
ping на c++ маришка001 Помощь студентам 3 30.10.2011 11:51
ping TaTT DoGG Общие вопросы .NET 2 06.10.2008 12:48


00:43.


Powered by vBulletin® Version 3.8.8 Beta 2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

RusProfile.ru


Справочник российских юридических лиц и организаций.
Проекты отопления, пеллетные котлы, бойлеры, радиаторы
интернет магазин respective.ru