untmain.~pas

本代码是展示了如何通过delphi监控指定web站点的运行情况

unit UntMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, MSNPopUp, xmldom, XMLIntf, msxmldom, XMLDoc, HttpProt,
  ExtCtrls, ComCtrls;

const
  DefTiTle = '报警';
    
type
  TfrmMain = class(TForm)
    MSNPopUp: TMSNPopUp;
    XML: TXMLDocument;
    HttpCli: THttpCli;
    BtnStart: TButton;
    Timer: TTimer;
    MMO: TMemo;
    GroupBox1: TGroupBox;
    procedure FormCreate(Sender: TObject);
    procedure BtnStartClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure HttpCliRequestDone(Sender: TObject; RqType: THttpRequest;
      ErrCode: Word);
  private
    FUser, FPwd: string;
    FTimerInterval:Integer;
    procedure PopUpMsg(FMsg:string;FTitle:string=DefTiTle);
    procedure AddWndMsg(FMsg:string);
    procedure GetAlermInfo();
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;



implementation

uses PubUtils,IniFiles;

{$R *.dfm}

procedure TfrmMain.GetAlermInfo();
var
  Params: TStrings;
  S: string;
  Node, Node1, Node2: IXMLNode;
begin
  Params := TStringList.Create;
  try
    Params.Add('username=' + FUser);
    Params.Add('password=' + FPwd);
    Params.Add('action=geterror');

    HttpCli.RcvdStream := TStringStream.Create('');
    HttpCli.SendStream := TStringStream.Create(ParamsEncode(Params));
  finally
    Params.Free;
  end;   

  try
    HttpCli.Post;
  except
    //S := '提交失败' + #10#13 + '错误:' + HttpCli.ReasonPhrase;
    //MessageBox(Handle, PChar(S), '错误', MB_ICONERROR + MB_OK);
    S := 'E-SMS服务器可能出现故障，请及时处理！,错误原因：'+HttpCli.ReasonPhrase;

    PopUpMsg(S);
    AddWndMsg(S);

    Exit;
  end;

  XML.LoadFromStream(HttpCli.RcvdStream);
  HttpCli.RcvdStream.Free;
  HttpCli.RcvdStream := nil;

  Node := XML.ChildNodes.FindNode('resultset');
  Node := Node.ChildNodes.FindNode('result');

  Node1 := Node.ChildNodes.FindNode('code');
  Node2 := Node.ChildNodes.FindNode('msg');

  PopUpMsg(Node2.NodeValue);
  AddWndMsg(Node2.NodeValue);

end;   

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  with TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'Config.ini') do
  try
    HttpCli.URL := ReadString('Server', 'Url', '');
    HttpCli.Proxy := ReadString('Proxy', 'Host', '');
    HttpCli.ProxyPort := ReadString('Proxy', 'Port', '');
    HttpCli.ProxyUsername := ReadString('Proxy', 'User', '');
    HttpCli.ProxyPassword := ReadString('Proxy', 'Password', '');

    FUser := ReadString('Login', 'UserName', '');
    FPwd := ReadString('Login', 'Password', '');
    FTimerInterval := ReadInteger('Setting','TimerInterval',10000);
  finally
    Free;
  end;

  Timer.Enabled:=False;
  Timer.Interval:=FTimerInterval;

  AddWndMsg('客户端当前状态:停止监控');

end; 

procedure TfrmMain.PopUpMsg(FMsg:string;FTitle:string=DefTiTle);
begin
  with MSNPopUp do
  begin
    Title:=FTitle;
    Text:=FMsg;
    ShowPopUp;
  end;
end;

procedure TfrmMain.AddWndMsg(FMsg:string);
begin
  with MMO do
  begin
    if Lines.Count>500 then
      Lines.Clear;

    MMO.Lines.Add( Format('[%s] - %s' , [ DateTimeToStr(Now) , FMsg]) );  
  end;
end;

procedure TfrmMain.BtnStartClick(Sender: TObject);
begin
  Timer.Enabled:=not Timer.Enabled;
  if(Timer.Enabled) then
  begin
    BtnStart.Caption:='停止监控';
    AddWndMsg('客户端当前状态:开启监控');
  end
  else
  begin
    BtnStart.Caption:='开启监控';
    AddWndMsg('客户端当前状态:停止监控');
  end;
end;

procedure TfrmMain.TimerTimer(Sender: TObject);
begin
  GetAlermInfo;
end;

procedure TfrmMain.HttpCliRequestDone(Sender: TObject;
  RqType: THttpRequest; ErrCode: Word);
begin
  HttpCli.SendStream.Free;
  HttpCli.SendStream := nil;

  if ErrCode <> 0 then
  begin
    HttpCli.RcvdStream.Free;
    HttpCli.RcvdStream := nil;
    Exit;
  end;

  if HttpCli.StatusCode <> 200 then
  begin
    HttpCli.RcvdStream.Free;
    HttpCli.RcvdStream := nil;
    Exit;
  end;

end;

end.