Arsip: Thread utk Ping ke Banyak IP

 
user image
more 8 years ago

rudisbg

Dear all master, saya pingin bikin aplikasi kayak multiping (www.nessoft.com/multiping) dengan menggunakan TPing. tapi saya masih minim pengalaman dalam menggunakan Thread. bisa tolong dibantu ? saya udh bikin spt ini, tp masih sering error "The exception unknown software exception (0x0eedfade) occured in the application at location 0x7c81eb33)" Ini Thread yg saya bikin :

unit uThread;
interface
uses
  Windows, Messages, SysUtils, Classes, Controls, ping,
  stdctrls,ExtCtrls,MPLayer;
type
  TPingThread = class(TThread)
  private
    fPing : TPing;
    { Private declarations }
    procedure fPingDNSLookupDone(Sender: TObject; Error: Word);
    procedure fPingEchoReply(Sender,icmp: TObject; Error: Integer);
  protected
    procedure Execute; override;
  public
    MemoKu: TMemo;
    PanelKu : TPanel;
    Addr,PingResult : String;
    waktuku, errCount : integer;
    { Public declarations }
    constructor Create(Memo: TMemo; Almt: String; intval: integer; panel: TPanel);
  end;

implementation
uses uPing;

constructor TPingThread.Create(Memo: TMemo; Almt: String; intval: integer; panel: TPanel);
begin
    inherited Create(True);
    memoKu :=Memo;
    Addr :=Almt;
    waktuku :=intval;
    panelKu :=Panel;
    errCount :=0;
end;
procedure TPingThread.Execute;
begin
    fPing :=TPing.Create (nil);
    fPing.OnDnsLookupDone :=fPingDNSLookupDone;
    fPing.Size :=32;
    fPing.DnsLookup(Addr);
    while not Terminated do
    begin
//       panelKu.caption :=fPing.HostIP;//Addr;
       fPing.Ping;
    end;
end;
procedure TPingThread.fPingDNSLookupDone(Sender: TObject; Error: Word);
begin
    if error<>0 then
    begin
        PingResult := 'Unknown host '''+addr+'''';
//        terminate;exit;
    end;
    with sender as TPing do
    begin
        Address :=DNSResult;
        onEchoReply :=fPingEchoReply;
//        ping; terminate;
    end;
end;
procedure TPingThread.fPingEchoReply(Sender,icmp: TObject; Error: Integer);
begin
   with sender as TPing do
   if Error = 0 then
   begin
      PanelKu.Color :=$003640F1;
      PanelKu.Font.Color :=$0037E3EC;
      inc(errCount);
      if (errCount mod 10)=0 then
      begin
        PingResult:='Critical Error ('+HostIP+') : '+Errorstring;
//        Form1.BunyikanAlarm(sender,2);
        form1.CatatError('['+formatdatetime('DD-MM-YYYY HH:MM:SS',now)+'] '+PingResult,2);
      end else
      begin
        PingResult:='Cannot ping host ('+HostIP+') : '+Errorstring;
//        Form1.BunyikanAlarm(1);
        form1.CatatError('['+formatdatetime('DD-MM-YYYY HH:MM:SS',now)+'] '+PingResult,1);
      end;
      MemoKu.Lines.Add(PingResult); 
       sleep(waktuku); ping;
   end
   else
   begin
       PingResult :='Received '+inttostr(Reply.datasize)+' bytes from '+HostIP+ ' ('+HostName+
       ') in '+inttostr(Reply.RTT)+' msecs';
       PanelKu.Font.Color :=$00FBFBFB;
       if Reply.RTT < 200 then PanelKu.Color :=$0051E83C else
       if Reply.RTT < 500 then PanelKu.Color :=$0041F1ED else
       PanelKu.Color :=$003D99F5;
       errCount :=0;
       MemoKu.Lines.Add(PingResult);
       sleep(waktuku); ping;
   end;
   Terminate;
end;
end.
dan untuk memanggilnya dari Form1

procedure TForm1.Button1Click(Sender: TObject);
begin
   ListBox1.Items.Add(edit1.text);
   inc(jlhIP);
   (findcomponent('Panel'+inttostr(jlhIP)) as TPanel).caption :=edit1.text;
   with TPingThread.Create(Memo2,edit1.Text,waktu.value*1000,TPanel(findcomponent('Panel'+inttostr(jlhIP)))) do
   begin
      FreeOnTerminate :=true;
      Resume;
   end;
end;
Kalo saya perhatikan sih, jika banyak IP yg Timed Out yg bikin cepet error itu muncul. Trus saya juga gak tau giman cara terminate Thread-nya utk masing-2 IP. Mohon pencerahannya..... trims
user image
more 8 years ago

rudisbg

Ini procedure catatError (Apa mungkin ini penyebabnya ya? karena saya bikin di Form1 ?)

procedure TForm1.CatatError(pesan: string; jenis: integer);
begin
 with richEdit1 do
 begin
   if jenis=1 then
   begin
   //bigger text
   SelAttributes.Style := [];
   SelAttributes.Color := clBlack;
   Lines.Add(pesan);
   end else
   begin
   //bigger text
   SelAttributes.Style := [fsBold];
   SelAttributes.Color := clRed;
//   SelText :=pesan+chr(13);
   Lines.Add(pesan);
   end
 end;
user image
more 8 years ago

mat_koder

secara umum , jika masing2 thread di-design mengakses komponen VCL yang sama , maka anda harus pakai Synchronize() method atau gunakan locking mechanism seperti misalnya TRTLCriticalSection. Coba anda test aplikasi anda dengan satu remote IP dulu dan lihat apakah OK (termasuk bilamana ada error misalkan network terputus / timeout atau error2 lain) baru kmudian test dengan 2 , 3 dst
user image
more 8 years ago

rudisbg

utk VCL-nya udah bisa diatasi, trus utk proses Terminate masing-masing Thread-nya gimana ya? soalnya kalo aplikasi saya tutup, banyak Error yg mungkin disebabkan krn Thread-nya belom di Terminate.
user image
more 8 years ago

rudisbg

alhamdulillah udh nemu triknya. jadinya kubuat variabel global IsKeluar: Boolean pd form1.onClose begin IsKeluar :=True; Timer1.Enabled :=true; action :=caNone; end; dan pd Timer1.OnTimer begin dec(countdown); pnlKeluar.Caption :='Menutup Aplikasi dalam '+inttostr(countdown)+' Detik'; if countdown=0 then Application.Terminate; end; kemudian di procedure TPingThread.fPingEchoReply pada perintah Ping dirubah menjadi : if not IsKeluar then ping; Karena di perintah Ping ini yg membuat Thread terus Looping, shg ketika perintah ping tidak dijalankan, thread akan 'idle' dan countdown selama 10 detik utk memberi waktu semua Thread untuk berakhir scr otomatis btw.... thanks all for u'r attention. bravo delphi indonesia
more ...
  • Pages:
  • 1
Share to
Local Business Directory, Search Engine Submission & SEO Tools FreeWebSubmission.com SonicRun.com