main.pas

关于DEPHI7.0的网络聊天信息管理系统源代码

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ComCtrls, StdCtrls, ToolWin, Buttons, Menus, ActnList,
  Sockets, WinSock, Inifiles;

type
  TFormMain = class(TForm)
    Label1: TLabel;
    StatusBar1: TStatusBar;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    MemoChat: TMemo;
    Splitter1: TSplitter;
    Splitter2: TSplitter;
    Panel4: TPanel;
    PanelFriend: TPanel;
    Panel6: TPanel;
    Splitter3: TSplitter;
    Label2: TLabel;
    Label3: TLabel;
    ListBoxFriend: TListBox;
    BTNHide: TButton;
    Panel7: TPanel;
    BTNAdd: TButton;
    BTNDel: TButton;
    ListBoxUser: TListBox;
    Panel8: TPanel;
    Splitter4: TSplitter;
    Panel9: TPanel;
    Panel10: TPanel;
    Label4: TLabel;
    EditChat: TEdit;
    Label5: TLabel;
    EditMe: TEdit;
    Panel11: TPanel;
    Panel12: TPanel;
    BTNSend: TButton;
    Panel13: TPanel;
    MemoSend: TMemo;
    SaveDialog1: TSaveDialog;
    OpenDialog1: TOpenDialog;
    CoolBar1: TCoolBar;
    ToolBar1: TToolBar;
    CoolBar2: TCoolBar;
    ToolBar2: TToolBar;
    BTNMail: TBitBtn;
    BTNOpen: TBitBtn;
    BTNSave: TBitBtn;
    BTNSetting: TBitBtn;
    BTNHelp: TBitBtn;
    BTNExit: TBitBtn;
    PopMenuFriend: TPopupMenu;
    PopMenuHide: TMenuItem;
    PopMenuAdd: TMenuItem;
    PopMenuDel: TMenuItem;
    N4: TMenuItem;
    PopMenuAbout2: TMenuItem;
    N6: TMenuItem;
    PopMenuExit2: TMenuItem;
    PopMenuChat: TPopupMenu;
    PopMenuClear: TMenuItem;
    PopMenuSave: TMenuItem;
    PopMenuMail: TMenuItem;
    MenuItem4: TMenuItem;
    PopMenuAbout: TMenuItem;
    MenuItem6: TMenuItem;
    PopMenuExit: TMenuItem;
    PopMenuSend: TPopupMenu;
    PopMenuClear2: TMenuItem;
    PopMenuOpen: TMenuItem;
    MenuItem5: TMenuItem;
    PopMenuAbout3: TMenuItem;
    MenuItem8: TMenuItem;
    PopMenuExit3: TMenuItem;
    ActionList1: TActionList;
    OpenFileAction: TAction;
    SaveFileAction: TAction;
    HideFriendAction: TAction;
    AddFriendAction: TAction;
    DelFriendAction: TAction;
    AboutAction: TAction;
    ExitAction: TAction;
    ClearMsgAction: TAction;
    MailMsgAction: TAction;
    SettingAction: TAction;
    HelpAction: TAction;
    ClearSendMsgAction: TAction;
    TcpClient1: TTcpClient;
    TcpServer1: TTcpServer;
    AllClearAction: TAction;
    PopMenuAllClear: TMenuItem;
    N1: TMenuItem;
    N2: TMenuItem;
    PopMenuInfoView: TMenuItem;
    BTNModify: TButton;
    Label6: TLabel;
    EditPort: TEdit;
    procedure SettingActionExecute(Sender: TObject);
    procedure ExitActionExecute(Sender: TObject);
    procedure AboutActionExecute(Sender: TObject);
    procedure HelpActionExecute(Sender: TObject);
    procedure MailMsgActionExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure BTNSendClick(Sender: TObject);
    procedure TcpServer1Accept(Sender: TObject;
      ClientSocket: TCustomIpClient);
    procedure FormShow(Sender: TObject);
    procedure AddFriendActionExecute(Sender: TObject);
    procedure DelFriendActionExecute(Sender: TObject);
    procedure AllClearActionExecute(Sender: TObject);
    procedure HideFriendActionExecute(Sender: TObject);
    procedure OpenFileActionExecute(Sender: TObject);
    procedure SaveFileActionExecute(Sender: TObject);
    procedure ClearMsgActionExecute(Sender: TObject);
    procedure PopMenuInfoViewClick(Sender: TObject);
    procedure ListBoxFriendDblClick(Sender: TObject);
    procedure MemoSendDblClick(Sender: TObject);
    procedure ListBoxUserDblClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BTNModifyClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TClientDataThread = class(TThread)
  private
  public
    ListBuffer :TStringList;
    TargetList :TStrings;
    procedure synchAddDataToControl;
    constructor Create(CreateSuspended: Boolean);
    procedure Execute; override;
    procedure Terminate;
  end;

  //用户记录
  TUser = packed record
     UserComputerName : String[30];
     UserNickName : String[20];
     UserIPAddress : String[15];
  end;

    //查找网络内的计算机;
    Function FindAllComputer(var ComputerList : TStringList ): Boolean;
    //由主机名得到IP地址
    function GetIP(Name: string) : string;
    //查看计算机是否在线
    function FindComputer(ComputerName: string):Boolean;
    //获得所有工作组
    function GetWorkGroupList(var myList : TStringList ) : Boolean;
    //获得工作组内的全部计算机
    function GetComputerList(myWorkGroup:string ;var myList:TStringList):Boolean;

var
   FormMain: TFormMain;
   UserName, NickName, UserPassword: String;
   TalkAboutComputer : String;
   PasswordConfirmation: String;
   UserMailBox: String;
   SmtpServerName: String;
   SmtpServerPort: Integer;
   SmtpServerUser: String;
   SmtpServerPassword: String;
   SmtpAuthType: Integer;
   TcpClientRemoteHost,SocketID : String;
   ComputerName: array[0..127] of Char;
   FriendHide : Boolean;
   FriendFile: file of TUser;
   ThisUser, TempUser : TUser;
   myIni: TIniFile;
   UserID : Integer;    //当前用户序号

implementation

uses PostMsg, Setting, About, Help, Add; 
{$R *.dfm}

constructor TClientDataThread.Create(CreateSuspended: Boolean);
begin
  inherited Create(CreateSuspended);
  FreeOnTerminate := true;
  ListBuffer := TStringList.Create;
end;

procedure TClientDataThread.Terminate;
begin
  ListBuffer.Free;
  inherited;
end;

procedure TClientDataThread.Execute;
begin
  Synchronize(synchAddDataToControl);
end;

procedure TClientDataThread.synchAddDataToControl;
begin
 TargetList.AddStrings(ListBuffer);
end;

function GetIP(Name: string) : string;
type
  JlrPInAddr = array [0..10] of PInAddr;
  P_JlrPInAddr = ^JlrPInAddr;
var
  phe :PHostEnt;
  I : Integer;
  pptr : P_JlrPInAddr;
  GInitData : TWSADATA;
begin
    WSAStartup($101, GInitData);  //Socket连接
    Result := '';
    phe := GetHostByName(Pchar(Name));
    if phe = nil then Exit;
    pptr := P_JlrPInAddr(phe^.h_addr_list); //转换为IP地址
    I := 0;
    while pptr^[I] <> nil do begin
      Result:=StrPas(inet_ntoa(pptr^[I]^));  //返回IP地址
      Inc(I);
    end;
    WSACleanup;    //Socket关闭
end;

type
  TNetResourceArray = ^TNetResource;
  
function GetWorkGroupList( var myList : TStringList ) : Boolean;
var
  NetResource : TNetResource;
  Buf : Pointer;
  Count,BufSize,Res : DWORD;
  lphEnum : THandle;
  p: TNetResourceArray;
  i,j : SmallInt;
  NetworkTypeList : TList;
begin
  Result := False;
  NetworkTypeList := TList.Create;
  myList.Clear;
  Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, nil,lphEnum);
  if Res <> NO_ERROR then exit;
  Count := $FFFFFFFF;
  BufSize := 8192;
  GetMem(Buf, BufSize);
  Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
  if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR ) then Exit;

  P := TNetResourceArray(Buf);
  for I := 0 to Count - 1 do  //记录各个网络类型的信息
  begin
    NetworkTypeList.Add(p);
    Inc(P);
  end;
  Res:= WNetCloseEnum(lphEnum);
  if Res <> NO_ERROR then exit;
  for J := 0 to NetworkTypeList.Count-1 do
  begin
    NetResource := TNetResource(NetworkTypeList.Items[J]^);
    Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
                        RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);
    if Res <> NO_ERROR then break;
    while true do
    begin
      Count := $FFFFFFFF;
      BufSize := 8192;
      GetMem(Buf, BufSize);
      Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
      if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR) then break;
      P := TNetResourceArray(Buf);
      for I := 0 to Count - 1 do
      begin
        myList.Add(StrPAS( P^.lpRemoteName ));
        Inc(P);
      end;
    end;
    Res := WNetCloseEnum(lphEnum);
    if Res <> NO_ERROR then break;
  end;
  Result := True;
  FreeMem(Buf);
  NetworkTypeList.Destroy;
end;

function GetComputerList(myWorkGroup:string ;var myList:TStringList):Boolean;
var
  NetResource: TNetResource;
  Buf : Pointer;
  Count,BufSize,Res : DWord;
  Ind : Integer;
  lphEnum : THandle;
  Temp: TNetResourceArray;
begin
  Result := False;
  myList.Clear;
  FillChar(NetResource, SizeOf(NetResource), 0);
  NetResource.lpRemoteName := @myWorkGroup[1];
  NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
  NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;
  NetResource.dwScope := RESOURCETYPE_DISK;
  Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);
  if Res <> NO_ERROR then Exit;
  While true Do
  begin
    Count := $FFFFFFFF;
    BufSize := 8192;
    GetMem(Buf, BufSize);
    Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
    if Res = ERROR_NO_MORE_ITEMS then break;
    if (Res <> NO_ERROR) then Exit;
    Temp := TNetResourceArray(Buf);
    for Ind := 0 to Count - 1 do
    begin
       myList.Add(Temp^.lpRemoteName);
       Inc(Temp);
    end;
  end;
  Res := WNetCloseEnum(lphEnum);
  if Res <> NO_ERROR then exit;
  Result := True;
  FreeMem(Buf);
end;

procedure TFormMain.SettingActionExecute(Sender: TObject);
begin
  FormSetting.Show;;
end;

procedure TFormMain.ExitActionExecute(Sender: TObject);
begin
 Self.Close;
 Self.Free;
end;

procedure TFormMain.AboutActionExecute(Sender: TObject);
begin
  FormBrowser.Show;
end;

procedure TFormMain.HelpActionExecute(Sender: TObject);
begin
  FormBrowser.Show;
end;

procedure TFormMain.MailMsgActionExecute(Sender: TObject);
var  tmpString : String;
     i : Integer;