我把源码给大家看看。
用到BusinessSkin.
//Msg的格式:
//前15位是本机IP地址,虽然FromIP包含了发信息方的IP,但是如果有代理服务器的话,
//这个IP有时是代理服务器的IP;
//16-21是信息标识:
// 'Login' --上线信息
// 'Logout'--离线信息
// 'Broad' --广播信息
// 'Chat' --聊天信息
//从22位起就是实际信息
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, StdCtrls, AppEvnts,Winsock, NMUDP, Menus,ReceivedUnit,ShellApi,
BusinessSkinForm, bsSkinCtrls, bsSkinBoxCtrls, bsSkinMenus, bsTrayIcon,
bsSkinData;
const
HeaderLen=6;
IPLen =15;
ColorArray: array[0..15] of TColor =
(clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray,clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
type
TMainForm = class(TForm)
NMUDP: TNMUDP;
bsBusinessSkinForm1: TbsBusinessSkinForm;
UserListBox: TbsSkinListBox;
StatusBar: TbsSkinStatusBar;
bsTrayIcon1: TbsTrayIcon;
Popup: TbsSkinPopupMenu;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
p1: TLabel;
bsStoredSkin1: TbsStoredSkin;
bsSkinData1: TbsSkinData;
N1: TMenuItem;
N2: TMenuItem;
N8: TMenuItem;
N10: TMenuItem;
N11: TMenuItem;
N12: TMenuItem;
N13: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure ApplicationEvents1Minimize(Sender: TObject);
procedure ApplicationEvents1Restore(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure NMUDPDataReceived(Sender: TComponent; NumberBytes: Integer;
FromIP: String; Port: Integer);
procedure LoginItemClick(Sender: TObject);
procedure LogoutItemClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure N8Click(Sender: TObject);
procedure AutoPopupItemClick(Sender: TObject);
procedure N14Click(Sender: TObject);
procedure mniExitClick(Sender: TObject);
procedure UserListBoxListBoxDblClick(Sender: TObject);
procedure N13Click(Sender: TObject);
procedure N11Click(Sender: TObject);
procedure N12Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
LocalIP: String;
BroadCastIP: String;
ComputerName: String;
MsgStream: TMemoryStream;
UserList: TStringList;
Login: Boolean; //是否已经登录
InChatRoom: Boolean; //是否在聊天室里
function GetLocalIP:String;
function GetComputerNameByIP(const IP:String):String;
procedure SetBroadCastIp;
function FindIP(const IP:String):Integer;
procedure AddUser(const IP,UserName:string);
procedure DelUser(const IP:String);
function FindWindowByIP(const IP:String):TReceivedMsgForm;
procedure IniMsgStream;
procedure SendMsg(const IP,Msg:String);
procedure SendLoginMsg(const IP:String);
procedure SendLogoutMsg;
procedure ReceivedLoginMsg(const FromIP,Msg:String); //收到了登录信息
procedure ReceivedLogoutMsg(const FromIP:String);
procedure ReceivedBroadCastMsg(const FromIP,Msg:String);
procedure ReceivedChatMsg(const FromIP,Msg:String);
procedure SendInRoomMsg(const IP,NickName:String;const Echo:Boolean);
procedure SendOutRoomMsg;
procedure SendChatRoomMsg(const IP,Msg:String);
procedure ReceivedInRoomMsg(const FromIP,UserName:String);
procedure ReceivedOutRoomMsg(const FromIP:String);
procedure ReceivedChatRoomMsg(const FromIP,Msg:String);
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
function TMainForm.GetLocalIP:String;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe : PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of char;
I : Integer;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
try
Result:='';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^
<> nil do
begin
result:=StrPas(inet_ntoa(pptr^^));
Inc(I);
end;
finally
WSACleanup;
end;
end;
procedure TMainForm.FormCreate(Sender: TObject);
var
pComputerNameChar;
ComputerNameLenWORD;
i:Integer;
TempItem:TMenuItem;
begin
Application.HintShortPause:=0;
{PopupMenu.Items.Clear;
for i:=0 to MainMenu1.Items[0].Count-1 do
begin
TempItem:=MainMenu1.Items[0].Items;
PopupMenu.Items.Add(TempItem);
end;}
MsgStream:=TMemoryStream.Create;
UserList:=TStringList.Create;
ComputerNameLen:=255;
GetMem(pComputerName,ComputerNameLen);
try
if not GetComputerName(pComputerName,ComputerNameLen) then
pComputerName:='无名氏';
ComputerName:=String(PComputerName);
//p1.Caption:=ComputerName+'[离线]';
p1.Color:=clRed;
finally
FreeMem(pComputerName);
end;
LocalIp:=GetLocalIP;
SetBroadCastIP;
Login:=False;
InChatRoom:=False;
StatusBar.Height:=6;
SendLoginMsg(BroadCastIP);
//Login;
end;
procedure TMainForm.ApplicationEvents1Minimize(Sender: TObject);
begin
ShowWindow(Application.Handle,SW_HIDE);
end;
procedure TMainForm.ApplicationEvents1Restore(Sender: TObject);
begin
ShowWindow(Application.Handle,SW_SHOW);
end;
procedure TMainForm.SetBroadCastIp;
var
i,j,iHead:Integer;
sHead,s:String;
ai:array [1..3] of integer;
begin
{1~126.255.255.255 (A类网广播地址)
128~191.XXX.255.255 (B类网广播地址)
192~254.XXX.XXX.255 (C类网广播地址)}
j:=1;
for i:=0 to Length(LocalIP) do
begin
if LocalIP='.' then
begin
ai[j]:=i;
Inc(j);
end;
if j>3 then break;
end;
sHead:=Copy(LocalIp,1,ai[1]-1);
iHead:=StrToInt(sHead);
if iHead<128 then //A类网
begin
BroadCastIP:=sHead+'.255.255.255';
end
else
begin
if iHead<192 then //B类网
begin
s:=Copy(LocalIP,1,ai[2]-1);
BroadCastIP:=s+'.255.255';
end
else //C类网
begin
s:=Copy(LocalIP,1,ai[3]-1);
BroadCastIP:=s+'.255';
end;
end;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
MsgStream.Free;
UserList.Free;
end;
procedure TMainForm.SendLoginMsg(const IP:String);
//启动UDP,在局域网中发广播
var
Msg:String;
begin
Login:=True;
Msg:=Format('%-15s%-6s%-255s',[LocalIP,'Login',ComputerName]);
Msg:=Trim(Msg);
SendMsg(IP,Msg);
//p1.Caption:=ComputerName+'[在线]';
p1.Color:=clGreen;
end;
procedure TMainForm.SendLogoutMsg;
//退出UDP,发广播
var
Msg:String;
begin
Login:=False;
UserListBox.Clear;
UserList.Clear;
Msg:=Format('%-15s%-6s',[LocalIp,'Logout']);
SendMsg(BroadCastIp,Msg);
//p1.Caption:=ComputerName+'[离线]';
p1.Color:=clRed;
end;
function TMainForm.FindIP(const IP: String): Integer;
//在UserList中查找指定的IP,返回索引值
var
i:Integer;
ts:String;
begin
Result:=-1;
for i:=0 to UserList.Count-1 do
begin
ts:=Trim(Copy(UserList.Strings,1,15));
if ts=IP then
begin
Result:=i;
exit;
end;
end;
end;
procedure TMainForm.AddUser(const IP, UserName: string);
//将Ip和UserName加入UserList中
var
s:String;
begin
s:=Trim(Format('%-15s%-255s',[IP,UserName]));
UserList.Add(s);
UserListBox.Items.Add(UserName);
end;
procedure TMainForm.DelUser(const IP: String);
//根据IP来删除用户
var
i:Integer;
begin
i:=FindIp(IP);
if i>=0 then
begin
UserList.Delete(i);
UserListBox.Items.Delete(i);
end;
end;
procedure TMainForm.IniMsgStream;
//初始化MsgStream;
begin
MsgStream.Position:=0;
MsgStream.Size:=0;
end;
procedure TMainForm.NMUDPDataReceived(Sender: TComponent;
NumberBytes: Integer; FromIP: String; Port: Integer);
var
Msg,TrueFromIP,Header:String;
begin
if not Login then exit;
IniMsgStream;
NMUDP.ReadStream(MsgStream);
SetLength(Msg,NumberBytes);
MsgStream.Read(Msg[1],NumberBytes);
TrueFromIP:=Trim(Copy(Msg,1,IPLen));
Header:=Trim(Copy(Msg,IPLen+1,HeaderLen));
Msg:=Copy(Msg,IPLen+HeaderLen+1,Length(Msg)-IPLen-HeaderLen);
if (Header='Login')then
ReceivedLoginMsg(TrueFromIP,Msg);
if (Header='Logout') then
ReceivedLogoutMsg(TrueFromIP);
if (Header='Broad') then
ReceivedBroadCastMsg(TrueFromIP,Msg);
if (Header='Chat') then
ReceivedChatMsg(TrueFromIP,Msg);
end;
procedure TMainForm.LoginItemClick(Sender: TObject);
begin
SendLoginMsg(BroadCastIP);
end;
procedure TMainForm.ReceivedBroadCastMsg(const FromIP,Msg:String);
//接收到了广播信息,用于聊天室
//头信息
//1、'InRoom':进入房间
//2、'OtRoom':出房间
//3、'ChatMg':聊天信息
var
Header:String;
begin
if not InChatRoom then exit;
Header:=Copy(Msg,1,HeaderLen);
if Header='InRoom' then
begin
ReceivedInRoomMsg(FromIP,Copy(Msg,HeaderLen+1,Length(Msg)-HeaderLen));
exit;
end;
if Header='OtRoom' then
begin
ReceivedOutRoomMsg(FromIP);
exit;
end;
if Header='ChatMg' then ReceivedChatRoomMsg(FromIP,Copy(Msg,HeaderLen+1,Length(Msg)-HeaderLen));
end;
procedure TMainForm.ReceivedChatMsg(const FromIP,Msg:String);
//接收到了个人的聊天信息
var
ReceivedMsgForm:TReceivedMsgForm;
begin
//if FromIP=LocalIP then //自己不应该给自己发信息吧
// exit;
//ReceivedMsgForm:=FindWindowByIP(FromIP);
//if ReceivedMsgForm=Nil then
application.CreateForm(TReceivedMsgForm,ReceivedMsgForm);
//ReceivedMsgForm:=TReceivedMsgForm.Create(Self);
ReceivedMsgForm.FromIP:=FromIP;
with ReceivedMsgForm do
begin
RemoteComputerName:=GetComputerNameByIP(FromIP);
MsgList.Add(Msg);
//if MsgList.Count>1 then btnNext.Enabled:=True;
sp2.Visible:=true;
sp1.Visible:=false;
Show;
end;
end;
procedure TMainForm.ReceivedLoginMsg(const FromIP,Msg:String);
//接收到了登录信息
var
RemoteComputerName:String;
begin
if FindIP(FromIP)=-1 then
begin
RemoteComputerName:=Msg;
AddUser(FromIP,RemoteComputerName);
SendLoginMsg(FromIP);
end;
end;
procedure TMainForm.ReceivedLogoutMsg(const FromIP:String);
//接收到了退出信息
begin
DelUser(FromIP);
end;
procedure TMainForm.LogoutItemClick(Sender: TObject);
begin
SendLogoutMsg;
end;
procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
SendLogoutMsg;
end;
function TMainForm.FindWindowByIP(const IP: String): TReceivedMsgForm;
//按照IP来查找ReceivedMsgForm窗口,如果未找到则返回Nil;
var
i:Integer;
begin
Result:=Nil;
for i:=0 to Screen.FormCount-1 do
begin
if Screen.Forms.Caption='消息窗口' then
begin
if TReceivedMsgForm(Screen.Forms).FromIP=IP then
begin
Result:=TReceivedMsgForm(Screen.Forms);
exit;
end;
end;
end;
end;
function TMainForm.GetComputerNameByIP(const IP: String): String;
//通过IP获得机器名
var
i:Integer;
ts:String;
begin
Result:='';
i:=FindIP(IP);
if i>=0 then
begin
ts:=UserList.Strings;
Result:=Copy(ts,IPLen+1,Length(ts)-IPLen);
end;
end;
procedure TMainForm.N8Click(Sender: TObject);
begin
Close;
end;
procedure TMainForm.SendMsg(const IP, Msg: String);
//向IP发送信息
begin
IniMsgStream;
MsgStream.Write(Msg[1],Length(Msg));
NMUDP.RemoteHost:=IP;
NMUDP.SendStream(MsgStream);
end;
procedure TMainForm.SendChatRoomMsg(const IP,Msg: String);
//广播聊天消息
var
s:String;
begin
s:=Format('%-15s%-6s%-6s',[LocalIP,'Broad','ChatMg'])+Msg;
SendMsg(IP,s);
end;
procedure TMainForm.SendInRoomMsg(const IP,NickName: String;const Echo:Boolean);
//广播进入聊天室的信息
var
Msg:String;
begin
if Echo then
Msg:=Format('%-15s%-6s%-6s',[LocalIP,'Broad','InRoom'])+'1'+NickName
else
Msg:=Format('%-15s%-6s%-6s',[LocalIP,'Broad','InRoom'])+'0'+NickName;
SendMsg(IP,Msg);
end;
procedure TMainForm.SendOutRoomMsg;
//广播离开聊天室的信息
var
Msg:String;
begin
Msg:=Format('%-15s%-6s%-6s',[LocalIP,'Broad','OtRoom']);
SendMsg(BroadCastIP,Msg);
end;
procedure TMainForm.ReceivedChatRoomMsg(const FromIP, Msg: String);
begin
end;
procedure TMainForm.ReceivedInRoomMsg(const FromIP, UserName: String);
begin
end;
procedure TMainForm.ReceivedOutRoomMsg(const FromIP: String);
begin
end;
procedure TMainForm.AutoPopupItemClick(Sender: TObject);
begin
//TMenuItem(Sender).checked:=not TMenuItem(Sender).Checked;
//不知为什么这一句不能对两个菜单项都起作用???
//AutoPopupItem.Checked:=not AutoPopupItem.Checked;
end;
procedure TMainForm.N14Click(Sender: TObject);
var
Icon:Integer;
Title,Msg:String;
begin
Icon:=LoadIcon(hinstance,'mainicon');
Title:='NetICQ V1.0';
Msg:='开博科技'#13#10'http://www.coerp.com';
ShellAbout(Handle,PChar(Title),PChar(Msg),Icon);
end;
procedure TMainForm.mniExitClick(Sender: TObject);
begin
close;
end;
procedure TMainForm.UserListBoxListBoxDblClick(Sender: TObject);
var
i:Integer;
UserInfo,sFromIP,sRemoteComputerName:String;
ReceivedMsgForm:TReceivedMsgForm;
begin
i:=UserListBox.ItemIndex;
UserInfo:=UserList.Strings;
sFromIP:=Trim(Copy(UserInfo,1,IPLen));
//if sFromIP=LocalIP then exit;
sRemoteComputerName:=Copy(UserInfo,IPLen+1,Length(UserInfo)-IPLen);
//ReceivedMsgForm:=FindWindowByIP(sFromIP);
// if ReceivedMsgForm=Nil then
// ReceivedMsgForm:=TReceivedMsgForm.Create(Self);
application.CreateForm(TReceivedMsgForm,ReceivedMsgForm);
with ReceivedMsgForm do
begin
FromIP:=sFromIP;
RemoteComputerName:=sRemoteComputerName;
sp1.Visible:=true;
sp2.Visible:=false;
Show;
end;
end;
procedure TMainForm.N13Click(Sender: TObject);
begin
N11.Checked:=false;
N12.Checked:=false;
N13.Checked:=true;
MainForm.Align:=alNone;
end;
procedure TMainForm.N11Click(Sender: TObject);
begin
N11.Checked:=true;
N12.Checked:=false;
N13.Checked:=false;
MainForm.Align:=alRight;
end;
procedure TMainForm.N12Click(Sender: TObject);
begin
N11.Checked:=false;
N12.Checked:=true;
N13.Checked:=false;
MainForm.Align:=alLeft;
end;
end.
-------------------------------------------------
unit ReceivedUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, StdCtrls, ExtCtrls, bsSkinCtrls, BusinessSkinForm,dateutils,
bsSkinBoxCtrls, bsSkinTabs;
type
TReceivedMsgForm = class(TForm)
bsBusinessSkinForm1: TbsBusinessSkinForm;
sp1: TbsSkinPanel;
sp2: TbsSkinPanel;
bsSkinPanel1: TbsSkinPanel;
btnMsg: TbsSkinButton;
btnClear: TbsSkinButton;
btnClose: TbsSkinButton;
btnSend: TbsSkinButton;
SendMsgMemo: TbsSkinMemo2;
bsSkinPanel2: TbsSkinPanel;
btnCancel: TbsSkinButton;
btnAnswer: TbsSkinButton;
ReceivedMsgMemo: TbsSkinMemo2;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure SendMsgMemoKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure btnAnswerClick(Sender: TObject);
procedure btnClearClick(Sender: TObject);
procedure btnMsgClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure btnCancelClick(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
MsgList:TStringList;
FromIP,RemoteComputerName:String;
MsgPointer:Integer;
end;
var
ReceivedMsgForm: TReceivedMsgForm;
implementation
uses main;
{$R *.DFM}
procedure TReceivedMsgForm.FormCreate(Sender: TObject);
begin
MsgList:=TStringList.Create;
MsgPointer:=0;
end;
procedure TReceivedMsgForm.FormDestroy(Sender: TObject);
begin
MsgList.Free;
end;
procedure TReceivedMsgForm.SendMsgMemoKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (Key=13) and (ssCtrl in Shift) then
btnSend.Click;
end;
procedure TReceivedMsgForm.btnAnswerClick(Sender: TObject);
begin
sp1.Visible:=true;
sp2.Visible:=false;
end;
procedure TReceivedMsgForm.btnClearClick(Sender: TObject);
begin
SendMsgMemo.Clear;
end;
procedure TReceivedMsgForm.btnMsgClick(Sender: TObject);
begin
sp2.Visible:=true;
sp1.Visible:=false;
end;
procedure TReceivedMsgForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action:=caFree;
end;
procedure TReceivedMsgForm.btnCancelClick(Sender: TObject);
begin
Close;
end;
procedure TReceivedMsgForm.btnCloseClick(Sender: TObject);
begin
if MsgPointer>=MsgList.Count-1 then
Close
else
sp1.Visible:=true;
sp2.Visible:=false;
end;
procedure TReceivedMsgForm.btnSendClick(Sender: TObject);
var
Msg:String;
begin
with MainForm do
begin
Msg:=Format('%-15s%-6s',[LocalIP,'Chat']);
Msg:=Msg+SendMsgMemo.Text;
SendMsg(FromIP,Msg);
end;
close;
end;
procedure TReceivedMsgForm.FormShow(Sender: TObject);
begin
sp1.Align:=alClient;
SendMsgMemo.Align:=alClient;
sp2.Align:=alClient;
ReceivedMsgMemo.Align:=alClient;
ReceivedMsgForm.Caption:='IP:'+FromIP + ' ' + '名称:'+RemoteComputerName;
if MsgList.Count=0 then
btnMsg.Enabled:=False
else
btnMsg.Enabled:=True;
try
ReceivedMsgMemo.Lines.Add('在本机时间' + datetimetostr(now));
ReceivedMsgMemo.Lines.Add('收到来自计算机'+RemoteComputerName +'(IP:' + FromIP+ ')的消息:');
ReceivedMsgMemo.Lines.Add('----------------------------------');
ReceivedMsgMemo.Lines.Add(MsgList.Strings[MsgPointer]);
ReceivedMsgMemo.Lines.Add('----------------------------------');
except
end;
end;
end.