unit1.pas

运用DELPHI开发的聊天工具

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdUDPBase, IdUDPClient, DB,
  StdCtrls, IdUDPServer, ExtCtrls,IdSocketHandle, Grids, DBGrids, ComCtrls,
  ADODB, IdTrivialFTPServer, IdTrivialFTP, jpeg, Buttons, WinSock,
  Menus, XPMan;

type

  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    Button1: TButton;
    IdUDPClient1: TIdUDPClient;
    IdUDPServer1: TIdUDPServer;
    TabSheet2: TTabSheet;
    ADODataSet1: TADODataSet;
    DataSource1: TDataSource;
    UserName: TStringField;
    UserIP: TStringField;
    StatusBar1: TStatusBar;
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    Memo1: TMemo;
    GroupBox3: TGroupBox;
    Memo2: TMemo;
    GroupBox4: TGroupBox;
    Image1: TImage;
    GroupBox5: TGroupBox;
    DBGrid1: TDBGrid;
    Image2: TImage;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    ADODataSet2: TADODataSet;
    ListBox1: TListBox;
    ADODataSet2UserName: TStringField;
    ADODataSet2UserIP: TStringField;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    XPManifest1: TXPManifest;
    procedure Button1Click(Sender: TObject);
    procedure IdUDPServer1UDPRead(Sender: TObject; AData: TStream;
      ABinding: TIdSocketHandle);
    function GettoName:String;
    function NameTOIP(NameZ:String):String;
    procedure Memo1DblClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Memo2KeyPress(Sender: TObject; var Key: Char);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure N4Click(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
    IP,Name,IPName,ZHUName:string;
    FileName:string;
    function GetName(IP:string;var Name:String):Boolean;
    procedure ADDlist;
  end;

var
  Form1: TForm1;

implementation
uses Unit2;
{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  STR:string;
begin
  ZHUName := GettoName;
  IPName := NameTOIP(ZHUName);
  ADODataSet2.Filtered := True;
  ADODataSet2.Filter := format('UserIP'+'='+'''%s''',[IPName]);
  name := ADODataSet2.fieldbyname('UserName').AsString;
  IdUDPClient1.Host:=IP;
  if Length(Memo2.Lines.GetText)>0 then
  begin
    IdUDPClient1.Send(Memo2.Lines.GetText);
    STR:=IdUDPClient1.ReceiveString;
    Memo1.Lines.Insert(0,Name+'：'+STR);
    Memo2.Clear;
    Memo2.Lines.Clear;
  end;
  Memo2.SetFocus;
end;

procedure TForm1.IdUDPServer1UDPRead(Sender: TObject; AData: TStream;
  ABinding: TIdSocketHandle);
var
  Str,Names:string;
  Stream:TStringStream;
begin
  Stream := TStringStream.Create('');
  Stream.CopyFrom(AData,AData.Size);
  Str:=Stream.DataString;
  ABinding.SendTo(ABinding.PeerIP,ABinding.PeerPort,Str[1],Length(Str));
  if GetName(ABinding.PeerIP,Names) then
    Memo1.Lines.Insert(0,Names+'：'+STR)//Memo1.Lines.Add(Names+'：'+Str
  else
    Memo1.Lines.Insert(0,ABinding.PeerIP+'：'+STR);
end;

procedure TForm1.Memo1DblClick(Sender: TObject);
begin
    Memo1.Clear;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  IP:='127.0.0.1';
  Name:='本机';
  FileName:='';
  ADODataSet1.CreateDataSet;
  if FileExists('.\Data.Dat') then
  begin
    ADODataSet1.LoadFromFile('.\Data.Dat');
  end;
  StatusBar1.Panels.Items[0].Text:=' 当前好友姓名为：'+Name;
  StatusBar1.Panels.Items[1].Text:=' IP地址为：'+IP;
  ADDlist;
end;

function TForm1.GetName(IP: string;var Name:String): Boolean;
var
  IsFind:Boolean;
begin
  IsFind := ADODataSet1.Locate('UserIP',IP,[]);
  if IsFind then
    Name:=ADODataSet1.FieldByName('UserName').AsString
  else
    Name:='';
  Result := IsFind;
end;

procedure TForm1.Memo2KeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
  begin
    Button1.Click;
  end;
  Exit;
end;

{ Thread }

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  Form2.ADOState:=1;
  Form2.DelTxt;
  Form2.ShowModal;

end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  Form2.ADOState:=2;
  Form2.GetTxt;
  Form2.ShowModal;

end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  if Application.MessageBox('是否要删除该记录！', '明日科技', MB_OKCANCEL) = IDOK then
  begin
    ADODataSet1.Delete;
    ADODataSet1.SaveToFile('.\Data.Dat');
  end;
  form1.ADDlist;
end;

procedure TForm1.ADDlist;
var
  same : Integer;
  IsAdd:boolean;
begin
  ADODataSet2.Close;
  ADODataSet2.CreateDataSet;
  if FileExists('.\Data.Dat') then
  begin
    ADODataSet2.LoadFromFile('.\Data.Dat');
  end;
  ADODataSet2.Open;
  ADODataSet2.First;
  ListBox1.Items.Clear;
  While not ADODataSet2.Eof do
  begin
    isadd:=true;
    for same:=0 to ListBox1.Count-1 do
    begin
      if  ADODataSet2.Fields[0].asstring=listbox1.Items[same] then
      begin
        isadd:=false;
        break;
      end;
    end;
    if isadd then
      ListBox1.Items.Add(ADODataSet2.Fields[0].asstring);
    ADODataSet2.Next;
  end;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
  i : Integer;
begin
  For i := 0 to ListBox1.Items.Count - 1 do
  if (ListBox1.SelCount <> 0 ) then
  begin
    ADODataSet2.Filtered := True;
    ADODataSet2.Filter := format('UserName'+'='+'''%s''',[ListBox1.Items[ListBox1.ItemIndex]]);
    StatusBar1.Panels.Items[0].Text := '向：'+ADODataSet2.FieldByName('UserName').AsString + ' 发送信息';
    StatusBar1.Panels.Items[1].Text := 'IP地址为：'+ADODataSet2.FieldByName('UserIP').AsString;
    IP := ADODataSet2.FieldByName('UserIP').AsString;
    Name := ADODataSet2.FieldByName('UserName').AsString;
  end;
end;

function TForm1.GettoName: String;
var
  Size : Cardinal;
  ComputerName : PAnsichar;
begin
  result := '';
  Size := 255;
  getmem(ComputerName,Size);
  GetComputerName(ComputerName,Size);
  Result := StrPas(ComputerName);
end;

function TForm1.NameTOIP(NameZ: String): String;
var
  WSAData: TWSAData;
  HostEnt: PHostEnt;
  sComputerName, sIP: string;
begin
  sComputername:=nameZ;
  WSAStartup(2, WSAData);
  HostEnt := gethostbyname(PChar(sComputerName));
  if HostEnt <> nil then
  begin
    with HostEnt^ do
      sIP := Format('%d.%d.%d.%d', [Byte(h_addr^[0]), Byte(h_addr^[1]), Byte(h_addr^[2]), Byte(h_addr^[3])]);
  end;
  WSACleanup;
  Result := sIP;
end;

procedure TForm1.N1Click(Sender: TObject);
begin
  Memo1.CopyToClipboard;
end;

procedure TForm1.N2Click(Sender: TObject);
begin
  Memo1.CutToClipboard;
end;

procedure TForm1.N3Click(Sender: TObject);
begin
  Memo1.PasteFromClipboard;
end;

procedure TForm1.N4Click(Sender: TObject);
begin
  Memo1.Clear;
end;

end.