www.pudn.com > netcheck.zip > netCheck.pas

unit netCheck; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Db, DBTables, Grids, DBGrids, Menus, ComCtrls,WinSock, ExtCtrls; 
 
const 
  NetCheck_Time=5;                  //自动监测的时间间隔（分钟） 
type 
  TNetCheckForm = class(TForm) 
    NetChech_Menu: TMainMenu; 
    StartupItem: TMenuItem; 
    HandNetCheckItem: TMenuItem; 
    N1: TMenuItem; 
    ExitItem: TMenuItem; 
    LibModifyItem: TMenuItem; 
    ModifyItem: TMenuItem; 
    N2: TMenuItem; 
    AppendItem: TMenuItem; 
    N3: TMenuItem; 
    InsertItem: TMenuItem; 
    N4: TMenuItem; 
    DeleteItem: TMenuItem; 
    SystemItem: TMenuItem; 
    NetLibDBGrid: TDBGrid; 
    NetLibDataSource: TDataSource; 
    NetLibTable: TTable; 
    NetCheckStatusBar: TStatusBar; 
    LogItem: TMenuItem; 
    N5: TMenuItem; 
    AboutItem: TMenuItem; 
    DbCreateQuery: TQuery; 
    CreateLibItem: TMenuItem; 
    N6: TMenuItem; 
    NetCheck_Timer: TTimer; 
    N7: TMenuItem; 
    AutoNetcheckItem: TMenuItem; 
    procedure ModifyItemClick(Sender: TObject); 
    procedure AppendItemClick(Sender: TObject); 
    procedure InsertItemClick(Sender: TObject); 
    procedure DeleteItemClick(Sender: TObject); 
    procedure ExitItemClick(Sender: TObject); 
    procedure HandNetCheckItemClick(Sender: TObject); 
    procedure Net_Check(Sender:TObject); 
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); 
    procedure NetLibDBGridDrawColumnCell(Sender: TObject; 
      const Rect: TRect; DataCol: Integer; Column: TColumn; 
      State: TGridDrawState); 
    procedure FormActivate(Sender: TObject); 
    procedure AboutItemClick(Sender: TObject); 
    procedure LogItemClick(Sender: TObject); 
    procedure CreateLibItemClick(Sender: TObject); 
    procedure ReCreateLib(Sender: TObject); 
    procedure AutoNetcheckItemClick(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
 
//ICMP应用程序接口中相关的数据结构 
TIP_Option_Information = record 
  TTL:Byte;                 //存活时间（用于路由跟踪） 
  TOS:Byte;                 //服务类型（通常为0） 
  Flags:Byte;               //IP头标志（通常为0） 
  OptionsSize:Byte;         //附加数据大小 
  OptionsData:PChar;        //附加数据 
  end; 
 
TIcmp_Echo_Reply = packed record 
  Address:DWord;             //应答的主机地址 
  Status:DWord;              //IP状态码 
  RTT:DWord;                 //往返应答时间（以毫秒计） 
  DataSize:Word;             //回波应答数据大小（以字节计） 
  Reserved:Word;             //系统保留 
  Data:Pointer;              //回波应答数据指针 
  Options: TIP_Option_Information;  // 
  end; 
 
PIP_Option_Information=^TIP_Option_Information; 
PIcmp_Echo_Reply=^TIcmp_Echo_Reply; 
 
//相关函数声明 
Function IcmpCreateFile:THandle;stdcall; external 'ICMP.DLL'; 
Function IcmpCloseHandle(Icmphandle:THandle):Boolean; stdcall; external 'ICMP.DLL'; 
Function IcmpSendEcho( 
         IcmpHandle:THandle;       //用于IcmpCreateFile 打开的ICMP句柄 
         DestinationAddress:DWord; //目标主机地址 
         RequestData:Pointer;      //回波请求所发数据的缓冲区 
         RequestSize:Word;         //回波请求数据的缓冲区大小（以字节计） 
         RequestOption:PIP_Option_InFormation;  //回波请求中IP报头选项地址，可以为空 
         ReplyBuffer:Pointer;      //用于存储回波应答数据的缓冲区 
         ReplySize:DWord;          //回波应答数据的缓冲区大小（以字节计） 
         TimeOut:DWord             //等待回应的时间（以毫秒计） 
         ):DWord; stdcall; external 'ICMP.DLL'; 
 
Function YearMonthString:String; 
procedure CreateNSLog(S:String); 
 
var 
  NetCheckForm: TNetCheckForm; 
 
implementation 
 
Uses About, Historylog; 
{$R *.DFM} 
 
Function YearMonthString;  //产生年月份串,供产生记录文件用 
var 
  Present:TDateTime; 
  Year, Month,Day:Word; 
 begin 
  Present:=Now; 
  DecodeDate(Present, Year,Month, Day); 
  if Month > 9 then 
    Result:=IntToStr(Year)+IntToStr(Month) 
    else 
      Result:=IntToStr(Year)+'0'+IntToStr(Month); 
end; 
 
procedure CreateNSLog(S:String); 
var 
  NSLog:String; 
  TFile:TextFile; 
begin 
  NSLog:='NS'+ YearMonthString + '.LOG'; 
  if FileExists(NSLog) then 
     begin 
      AssignFile(TFile,NSLog); 
      Append(TFile); 
     end 
      else 
         begin 
         AssignFile(TFile,NSLog); 
         Rewrite(TFile); 
         end; 
  Writeln(TFile,S); 
  CloseFile(TFile); 
end; 
 
procedure TNetCheckForm.ReCreateLib(Sender: TObject); 
begin 
  Screen.Cursor:=CrHourglass; 
  try 
   With DbCreateQuery do 
     begin 
     Close; 
     SQL.Clear; 
     SQL.Add('CREATE TABLE "IPLIB.DB"'); 
     SQL.Add('(对端名称 CHAR(30),对端IP CHAR(15),状态 CHAR(8),联系电话 CHAR(18))'); 
     Active := True; 
     Close; 
     end; 
  except 
    on ENoResultSet do ; 
    else 
    MessageBox(0,'重建库结构失败,请重试!','提示',MB_ICONEXCLAMATION ) 
  end; 
  Screen.Cursor:=CrDefault; 
end; 
 
procedure TNetCheckForm.Net_Check(Sender:TObject); 
Const 
 PacketSize =32; 
 TimeOut = 5000; 
Var 
  ICMPHandle:Thandle; 
  DestAddress:DWord;                       //目标主机IP地址 
  RequestDataBuffer:Pointer;               //请求数据缓冲区指针 
  ReplyDataBuffer:Pointer;                 //应答数据缓冲区指针 
  IPOptionInfo:TIP_Option_Information;     //待发送数据包的IP选项 
  ICMPEchoReplyBuffer:PIcmp_Echo_Reply;    //ICMP回波应答缓冲区 
  Echo_Result:Integer;                      //ICMPSendEcho函数返回值 
  TIPAddress,NameString:String; 
begin 
  ICMPHandle:=IcmpCreateFile;                //打开ICMP句柄 
  if ICMPHandle = INVALID_HANDLE_VALUE then 
    begin 
     MessageBox(0,'得到ICMP句柄错误','错误',MB_ICONEXCLAMATION); 
     Exit; 
    end; 
 
  GetMem(RequestDataBuffer,PacketSize);       //分配请求数据缓冲区 
  FillChar(RequestDataBuffer^,PacketSize,$FF);//填充请求数据缓冲区 
 
  FillChar(IPOptionInfo,Sizeof(IPOptionInfo),0);  //填充IP选项数据 
  IPOptionInfo.TTL:=64;                           //设置存活期 
 
  GetMem(ReplyDataBuffer,PacketSize);             //分配应答数据缓冲区 
  GetMem(ICMPEchoReplyBuffer,SizeOf(TIcmp_Echo_Reply)+PacketSize);  //分配回波应答结构缓冲区 
  ICMPEchoReplyBuffer^.Data:=ReplyDataBuffer;     //填入缓冲区指针 
 
  NetLibDataSource.DataSet.First; 
  NetlibDataSource.DataSet.Edit; 
  while not NetLibDataSource.DataSet.EOF do 
   begin 
     TIpAddress:=NetLibDataSource.DataSet.FieldByName('对端IP').AsString;       //从IP库中取对端IP地址 
     NameString:=NetLibDataSource.DataSet.FieldByName('对端名称').AsString;     //从IP库中取对端名称 
 
     DestAddress:=Inet_addr(PChar(TIpAddress));  //将目标地址转换成网络格式 
     Echo_Result:=IcmpSendEcho(ICMPHandle,DestAddress,RequestDataBuffer,PacketSize,@IPOptionInfo,ICMPEchoReplyBuffer, 
                 Sizeof(TIcmp_Echo_Reply)+PacketSize,TimeOut);     //发送回波请求，并等待回波应答 
 
     if Echo_Result <> 0 then      //判断回波并给出网络结果 
        begin 
        NetLibDataSource.DataSet.FieldByName('状态').AsString:='正常'; 
        CreateNSLog(DateTimeToStr(Now)+'  '+ NameString+':['+TIpAddress+']   连接正常'); 
        end 
       else 
         begin 
         NetLibDataSource.DataSet.FieldByName('状态').AsString:='中断'; 
         CreateNSLog(DateTimeToStr(Now)+'  '+ NameString+':['+TIpAddress+']   连接中断'); 
         end; 
     NetLibDataSource.DataSet.Next; 
     NetlibDataSource.DataSet.Edit; 
   end; 
 
  Freemem(ICMPEchoReplyBuffer);  //释放分配的内存空间 
  Freemem(ReplyDataBuffer); 
  FreeMem(RequestDataBuffer); 
  IcmpCloseHandle(ICMPHandle);   //关闭ICMP句柄 
 
  NetCheckStatusBar.Panels[1].Text:=DateTimeToStr(Now); 
end; 
 
procedure TNetCheckForm.FormActivate(Sender: TObject); 
Var 
 WSAdata:TWSAData;                         //Winsock数据结构 
begin 
  if WSAStartup($102,WSAdata) <> 0 then 
   begin 
   MessageBox(0,'初始化WINSOCK错误','初始化提示',MB_ICONEXCLAMATION); 
   Halt; 
   end; 
 
  if FileExists(ExtractFilePath(Application.ExeName)+'IPLib.db') then 
     try 
      CreateLibItem.Enabled:=False; 
      NetLibTable.DatabaseName := ExtractFilePath(Application.ExeName); 
      NetLibTable.TableName := 'IPLib.db'; 
      NetLibTable.Open; 
      HandNetCheckItem.Checked :=True; 
      except 
      MessageBox(0,'数据库[IPLIB.DB]错误,请删除并重建!','错误', MB_ICONEXCLAMATION); 
      LibModifyItem.Enabled:=False; 
      HandNetCheckItem.Enabled:=False; 
      AutoNetCheckItem.Enabled:=False; 
     end 
   else 
     begin 
      MessageBox(0,'数据库[IPLIB.DB]不存在,请重建!','错误', MB_ICONEXCLAMATION); 
      LibModifyItem.Enabled:=False; 
      HandNetCheckItem.Enabled:=False; 
      AutoNetCheckItem.Enabled:=False; 
      CreateLibItem.Enabled:=True; 
     end; 
end; 
 
procedure TNetCheckForm.ModifyItemClick(Sender: TObject); 
begin 
   NetLibDBGrid.ReadOnly:=False; 
   NetLibDataSource.DataSet.Edit; 
end; 
 
procedure TNetCheckForm.AppendItemClick(Sender: TObject); 
begin 
   NetLibDBGrid.ReadOnly:=False; 
   NetLibDataSource.DataSet.Append; 
end; 
 
procedure TNetCheckForm.InsertItemClick(Sender: TObject); 
begin 
   NetlibDBGrid.ReadOnly:=False; 
   NetlibDataSource.DataSet.Insert; 
end; 
 
procedure TNetCheckForm.DeleteItemClick(Sender: TObject); 
Var 
  MessageString:String; 
begin 
  MessageString:=NetLibDataSource.DataSet.FieldByName('对端名称').AsString; 
  if MessageBox(0,PChar('您要删除所选IP记录['+MessageString+']吗？'),'删除提示',MB_YESNO or MB_ICONEXCLAMATION )= IDYES then 
     NetLibDataSource.DataSet.Delete 
     else 
       Exit; 
end; 
 
procedure TNetCheckForm.ExitItemClick(Sender: TObject); 
begin 
 Application.Terminate; 
end; 
 
procedure TNetCheckForm.HandNetCheckItemClick(Sender: TObject); 
begin 
 NetCheck_Timer.Enabled :=False; 
 
 HandNetCheckItem.Checked :=True; 
 
 Net_Check(Self); 
end; 
 
procedure TNetCheckForm.AutoNetcheckItemClick(Sender: TObject); 
begin 
 AutoNetCheckItem.Checked :=True; 
 
 NetCheck_Timer.Interval :=NetCheck_Time*60*1000; 
 
 NetCheck_Timer.Enabled :=True; 
end; 
 
 
procedure TNetCheckForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); 
begin 
  NetLibDataSource.DataSet.Close; 
  if WSACleanup <> 0 then 
       MessageBox(0,'无法关闭WINSOCK','错误',MB_ICONEXCLAMATION); 
end; 
 
procedure TNetCheckForm.NetLibDBGridDrawColumnCell(Sender: TObject; 
  const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); 
begin 
  if NetLibDataSource.DataSet.FieldByName('状态').AsString='中断' then 
    begin 
     NetlibDBGrid.Canvas.Font.Color:=clRed; 
     NetLibDbGrid.DefaultDrawColumnCell(Rect,DataCol,Column,State); 
     NetLibDBGrid.Canvas.Font.Color:=clBlack; 
    end; 
end; 
 
procedure TNetCheckForm.CreateLibItemClick(Sender: TObject); 
begin 
   ReCreateLib(Self) 
end; 
 
procedure TNetCheckForm.AboutItemClick(Sender: TObject); 
begin 
  AboutBox.ShowModal; 
end; 
 
procedure TNetCheckForm.LogItemClick(Sender: TObject); 
begin 
  LogForm.ShowModal; 
end; 
 
 
end.