Indy10 即时通讯Demo
最近闲来无事，重新学习了Indy10，顺手写了一段即时通讯代码。与上次写的笔记有不同之处，但差别不大。
未研究过TCP打洞技术，所以下面的代码采用的是 客户端--服务器--客户端 模式，也就是服务器端转发消息的模式。
客户端模仿了QQ，可以在屏幕四周停靠自动隐藏
本文也演示了在线程中操作VCL的两张方法：
1：向主线程发送消息
2：在线程中使用临界区
program Server;
uses
Forms,
UntMain in 'UntMain.pas' {Form2},
Unit2 in 'Unit2.pas',
Unit4 in 'Unit4.pas';
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm2, Form2);
Application.Run;
end.
服务器端：
unit UntMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdContext, IdScheduler, IdSchedulerOfThread, IdSchedulerOfThreadPool,
IdBaseComponent, IdComponent, IdCustomTCPServer, IdTCPServer, ImgList,
CoolTrayIcon, ExtCtrls, RzPanel, Unit2, IdGlobal, StdCtrls, RzLstBox,
IdSchedulerOfThreadDefault, RzStatus, RzButton, RzEdit,SyncObjs;
type
TForm2 = class(TForm)
CoolTrayIcon1: TCoolTrayIcon;
ImageList1: TImageList;
IdTCPServer1: TIdTCPServer;
RzStatusBar1: TRzStatusBar;
RzListBox1: TRzListBox;
IdSchedulerOfThreadDefault1: TIdSchedulerOfThreadDefault;
Button1: TButton;
RzStatusPane1: TRzStatusPane;
RzStatusPane2: TRzStatusPane;
RzMemo1: TRzMemo;
RzButton1: TRzButton;
RzMemo2: TRzMemo;
Timer1: TTimer;
procedure IdTCPServer1Execute(AContext: TIdContext);
procedure CustomMessage(var message: TMessage); message CustMsg;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
procedure IdTCPServer1Disconnect(AContext: TIdContext);
procedure RzButton1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
//TIdServerContext 类继承自 TIdContext类
//IdCustomTCPServer 单元 第295行
TMyClass = class(TIdServerContext)
CltInfo: TCltInfo;
end;
var
Form2: TForm2;
CriticalSection:TCriticalSection;
implementation
{$R *.dfm}
uses
Unit4;
procedure TForm2.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := True;
if IdTCPServer1.Active then
begin
RzMemo1.Lines.Add('服务器开启成功...');
end;
end;
procedure TForm2.CustomMessage(var message: TMessage);
var
i,n: Integer;
ss,ip,Nc,sNc: string;
buf:TDataPack;
list:Tlist;
FContext:TIdContext;
begin
FContext := TMyClass(message.LParam);
case message.WParam of
CltConnect:
begin
ss:='';
Nc := TMyClass(FContext).CltInfo.CltName;
ip:= TMyClass(FContext).CltInfo.CltIP;
RzListBox1.Items.Add(Nc);
RzMemo2.Lines.Add('【客户:】' + Nc + ' (' + ip +') 登陆'+'---'+DateTimeToStr(Now));
for i := 0 to RzListBox1.Items.Count - 1 do // 发送连线客户端列表
ss:=ss+form2.RzListBox1.ItemCaption(i)+'|';
sNc :=Encrystrings(ss);
FillChar(buf, SizeOf(TDataPack), '');
buf.Command := CltList;
StrCopy(@buf.Data, PChar(sNc));
List := form2.IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
for I := 0 to n-1 do
begin
try
TMyClass(List.Items[i]).Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
except
//
end;
end;
finally
form2.IdTCPServer1.Contexts.UnlockList;
end;
end;
CltDisconnect:
begin
for i := 0 to RzListBox1.Items.Count - 1 do
begin
if RzListBox1.ItemCaption(i) = TMyClass(FContext).CltInfo.CltName then
begin
RzListBox1.Items.Delete(i);
RzMemo2.Lines.Add('【用户:】 '+ string(TMyClass(FContext).CltInfo.CltName) +' 离开---'+DateTimeToStr(Now));
Break;
end;
end;
FillChar(buf, SizeOf(TDataPack), '');
ss := '';
for i := 0 to RzListBox1.Items.Count - 1 do // 发送连线客户端列表
ss := ss + Form2.RzListBox1.ItemCaption(i) + '|';
ss:=Encrystrings(ss);
buf.Command := CltList;
StrCopy(@buf.Data, PChar(ss));
list:= IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
for i := 0 to n - 1 do
try
TMyClass(List.Items[i]).Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
except
//
end;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
CltSendMessage:
begin
end;
end;
end;
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
RzListBox1.Clear;
IdTCPServer1.Active := False;
end;
procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
List:TList;
i,n:Integer;
LContext: TMyClass;
buf:TDataPack;
begin
//当有客户端尚未断开连接时，服务器主动断开连接会导致异常
//所以，在服务器端退出之前，检查时候有客户端尚未断开
//若有，通知客户端主动断开连接
List:= IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
if n >0 then
begin
CanClose := False;
FillChar(buf,SizeOf(TdataPack),'');
buf.Command := SrvCloseQuery;
for I := 0 to n - 1 do
begin
LContext := TMyClass(List.Items[i]);
LContext.Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
end;
end else CanClose := True;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
//在IdCustomTCPServer 单元第302行，定义了类的指针:
//TIdServerContextClass = class of TIdServerContext;
//AContext不确定以 TIdServerContext类创建，所以定义了一个类的指针TIdServerContextClass，
//AContext将以TIdServerContextClass指针所指向的类来创建,重新赋值指针，将以新类创建实例
//这里重新赋值AContext 新类，当客户端连接后，AContext将以新类TMyClass的实例创捷
//AContext 被创建后，将包含TMyClass类的新属性 TCltInfo
//详见IdCustomTCPServer 单元第956行
//如果不重新赋值AContext新类，AContext 在IdCustomTCPServer初始化时(TIdCustomTCPServer.InitComponent方法)，
//以默认类TIdServerContext创建
//详见 IdCustomTCPServer 单元第812行
//这里我们需要给AContext 添加新属性 TCltInfo 用来保存客户端信息
//所以，以TIdServerContext 为基类，我们扩展出 TMyClass 子类
//每个客户端连接后，AContext即被创建，并把每个AContext地址(对象指针)保存在IdTCPServer.Contexts属性中
//当服务器端需要与某个客户端回话时，可以遍历Contexts属性
IdTCPServer1.ContextClass := TMyClass;
IdTCPServer1.Active := True;
if IdTCPServer1.Active then
begin
RzMemo1.Lines.Add('服务器开启成功...('+ DateTimeToStr(Now) + ')');
end;
CriticalSection:=TCriticalSection.Create;
end;
procedure TForm2.FormDestroy(Sender: TObject);
begin
CriticalSection.Free;
end;
procedure TForm2.IdTCPServer1Disconnect(AContext: TIdContext);
begin
SendMessage(Handle,CustMsg,CltDisconnect,LongInt(AContext));
end;
procedure TForm2.IdTCPServer1Execute(AContext: TIdContext);
var
BByte: TIdBytes;
buf: TDataPack;
i,n: Integer;
s,ss,ds,nr,Nc,ip:string;
List:Tlist;
begin
FillChar(buf, SizeOf(TDataPack), '');
AContext.Connection.IOHandler.ReadBytes(BByte, SizeOf(TDataPack), False);
BytesToRaw(BByte, buf, SizeOf(TDataPack));
//---------------------------------------------------------------------------------------
case buf.Command of
CltConnect:
begin
ss:='';
s:= string(buf.CltInfo.CltName);
Nc :=Uncrystrings(s);
ip:=AContext.Binding.PeerIP;
StrCopy(@TMyClass(AContext).CltInfo.CltName,PChar(Nc)) ;
StrCopy(@TMyClass(AContext).CltInfo.CltIP,PChar(ip));
Nc :=Uncrystrings(s);
for i := 0 to RzListBox1.Items.Count - 1 do
begin
if RzListBox1.Items[i]=Nc then
begin
buf.Command := CltDisconnect;
AContext.Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
Exit;
end;
end;
SendMessage(Handle,CustMsg,CltConnect,LongInt(AContext));
end;
//------------------------------------------------------------------------------------------------
CltSendMessage:
begin
s:= Uncrystrings(string(buf.CltInfo.CltName));
ds:=Uncrystrings(string(buf.DstInfo.CltName));
nr:=Uncrystrings(string(buf.Data)) +#13+#10;
List := form2.IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
for i := 0 to n - 1 do
begin
if TMyClass(List.Items[i]).CltInfo.CltName = ds then
begin
try
CriticalSection.Enter;
try
TMyClass(List.Items[i]).Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
RzMemo1.Lines.Add(s + '对 '+ds + ' 说：'+ nr);
finally
CriticalSection.Leave;
end;
except
buf.Command := SrvMessage;
AContext.Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
end;
Exit;
end;
end;
finally
form2.IdTCPServer1.Contexts.UnlockList;
end;
end;
//--------------------------------------------------------------------------------------------------------
CltTimer :
begin
AContext.Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
end;
//---------------------------------------------------------------------------------------------------------
CltClear :
begin
s:= Uncrystrings(string(buf.CltInfo.CltName));
ds:=Uncrystrings(string(buf.DstInfo.CltName));
List := form2.IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
for i := 0 to n - 1 do
begin
if TMyClass(List.Items[i]).CltInfo.CltName = ds then
begin
try
CriticalSection.Enter;
try
TMyClass(List.Items[i]).Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
RzMemo1.Lines.Add(s + ' 清除了 '+ds + ' 的屏幕'+#13+#10);
finally
CriticalSection.Leave;
end;
except
//
end;
Exit;
end;
end;
finally
form2.IdTCPServer1.Contexts.UnlockList;
end;
end;
//-------------------------------------------------------------------------------------------------------
CltLockSrc:
begin
s:= Uncrystrings(string(buf.CltInfo.CltName));
List := form2.IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
for i := 0 to n - 1 do
begin
if TMyClass(List.Items[i]).CltInfo.CltName <> s then
begin
try
CriticalSection.Enter;
try
TMyClass(List.Items[i]).Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
finally
CriticalSection.Leave;
end;
except
//
end;
end;
end;
finally
form2.IdTCPServer1.Contexts.UnlockList;
end;
RzMemo1.Lines.Add(s + ' 锁定了屏幕 '+#13+#10);
end;
//-------------------------------------------------------------------------------------------------------
CltUnlockSrc :
begin
s:= Uncrystrings(string(buf.CltInfo.CltName));
List := form2.IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
for i := 0 to n - 1 do
begin
if TMyClass(List.Items[i]).CltInfo.CltName <> s then
begin
try
TMyClass(List.Items[i]).Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
except
//
end;
end;
end;
finally
form2.IdTCPServer1.Contexts.UnlockList;
end;
RzMemo1.Lines.Add(s + ' 解锁了屏幕 '+#13+#10);
end;
//---------------------------------------------------------------------------------------------------------------
CltMessage :
begin
ds:=Uncrystrings(string(buf.DstInfo.CltName));
List := form2.IdTCPServer1.Contexts.LockList;
n:= List.Count;
try
for i := 0 to n - 1 do
begin
if TMyClass(List.Items[i]).CltInfo.CltName = ds then
begin
try
TMyClass(List.Items[i]).Connection.IOHandler.Write(RawToBytes(buf, SizeOf(TDataPack)), SizeOf(TDataPack));
except
//
end;
Exit;
end;
end;
finally
form2.IdTCPServer1.Contexts.UnlockList;
end;
end;
//-----------------------------------------------------------------------------------------------------------------
end;
end;
procedure TForm2.RzButton1Click(Sender: TObject);
begin
RzMemo1.Clear;
end;
end.
客户端
program Project3;
uses
Forms,
windows,
Unit3 in 'Unit3.pas' {Form3},
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas',
Unit4 in 'Unit4.pas';
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := False ;
Application.CreateForm(TForm3, Form3);
SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
Application.Run;
end.
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, RzLstBox, ExtCtrls, ShellAPI, ImgList, RzTray, IdGlobal,
Unit2,Clipbrd,
IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, RzButton,
RzRadChk, RzPanel, Mask, RzEdit, RzLabel, ComCtrls, Menus, RzBHints, RzSplit,
RzAnimtr, IdZLibCompressorBase, IdCompressorZLib,RxRichEd, RzListVw,Buttons,
RzSpnEdt ;
type
TForm3 = class(TForm)
RzListBox1: TRzListBox;
Timer1: TTimer;
RzTrayIcon1: TRzTrayIcon;
ImageList1: TImageList;
IdTCPClient1: TIdTCPClient;
RzCheckBox1: TRzCheckBox;
RzPanel1: TRzPanel;
RzPanel2: TRzPanel;
RzMemo2: TRzMemo;
RzLabel1: TRzLabel;
RzEdit1: TRzEdit;
RzButton2: TRzButton;
RzLabel2: TRzLabel;
RzEdit2: TRzEdit;
Timer2: TTimer;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
RzButton3: TRzButton;
BalloonHint1: TBalloonHint;
RzLabel5: TRzLabel;
RzEdit3: TRzEdit;
RzSplitter1: TRzSplitter;
RzSplitter2: TRzSplitter;
RzAnimator1: TRzAnimator;
ImageList2: TImageList;
RzToolButton1: TRzToolButton;
PopupMenu2: TPopupMenu;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
ImageList3: TImageList;
RzButton4: TRzButton;
RzButton5: TRzButton;
RxRichEdit1: TRxRichEdit;
LabeledEdit1: TLabeledEdit;
RzPanel3: TRzPanel;
Image01: TImage;
Image02: TImage;
Image03: TImage;
Image04: TImage;
Image05: TImage;
Image06: TImage;
Image07: TImage;
Image08: TImage;
Image09: TImage;
Image10: TImage;
Image11: TImage;
Image12: TImage;
Image13: TImage;
Image14: TImage;
Image15: TImage;
Image16: TImage;
Image17: TImage;
Image18: TImage;
Image19: TImage;
Image20: TImage;
Image21: TImage;
Image22: TImage;
Image23: TImage;
Image24: TImage;
Image25: TImage;
Image26: TImage;
Image27: TImage;
Image28: TImage;
Image29: TImage;
Image30: TImage;
Image31: TImage;
Image32: TImage;
Image33: TImage;
Image34: TImage;
Image35: TImage;
Image36: TImage;
Image37: TImage;
Image38: TImage;
Image39: TImage;
Image40: TImage;
Image41: TImage;
Image42: TImage;
Image43: TImage;
Image44: TImage;
Button1: TButton;
RzButton1: TRzButton;
ScrollBox1: TScrollBox;
Image1: TImage;
Image45: TImage;
Image46: TImage;
Image47: TImage;
Image48: TImage;
Image49: TImage;
Image50: TImage;
Image51: TImage;
Timer3: TTimer;
Image2: TImage;
FontDialog1: TFontDialog;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure WMMOVING(var Msg: TMessage); message WM_MOVING;
procedure wmsizing(var Msg: TMessage); message WM_SIZING;
procedure RevCustMsg(var Msg:TMessage);message CustMsg;
procedure SetBarHeight;
procedure RzListBox1DblClick(Sender: TObject);
procedure RzCheckBox1Click(Sender: TObject);
procedure IdTCPClient1Connected(Sender: TObject);
procedure IdTCPClient1Disconnected(Sender: TObject);
procedure RzButton1Click(Sender: TObject);
procedure RzButton2Click(Sender: TObject);
procedure RzMemo2KeyPress(Sender: TObject; var Key: Char);
procedure Timer2Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure RzTrayIcon1RestoreApp(Sender: TObject);
procedure RzTrayIcon1MinimizeApp(Sender: TObject);
procedure RzMemo2MouseEnter(Sender: TObject);
procedure FormMouseEnter(Sender: TObject);
function MousePosion:Boolean;
procedure RzListBox1MouseEnter(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure RzButton3Click(Sender: TObject);
procedure LabeledEdit1KeyPress(Sender: TObject; var Key: Char);
procedure RzEdit3KeyPress(Sender: TObject; var Key: Char);
procedure RzEdit1KeyPress(Sender: TObject; var Key: Char);
procedure PopupMenu1Popup(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure RzButton4Click(Sender: TObject);
procedure RzButton5Click(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure RxRichEdit1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Image01Click(Sender: TObject);
procedure RzSpinButtons1DownLeftClick(Sender: TObject);
procedure RzSpinButtons1UpRightClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure RxRichEdit1URLClick(Sender: TObject; const URLText: string;
Button: TMouseButton);
procedure Image1Click(Sender: TObject);
function MouseInScrollBox:Boolean;
procedure Timer3Timer(Sender: TObject);
procedure Image2Click(Sender: TObject);
private
{ Private declarations }
FAnchors: TAnchors;
public
{ Public declarations }
end;
TRevDataThread = class(TThread)
private
buf: TDataPack;
protected
procedure Execute; override;
procedure ShowMsg;
procedure AddCltList;
procedure DoDiscnt;
procedure ClearScr;
procedure AddMessage;
procedure CltMessageIn;
procedure DoSrvMessage;
procedure DoSrvCloseQuery;
end;
// HidePosKind = (hpTop, hpLeft, hpBottom, hpRight);
// THidePos = set of HidePosKind;
var
Form3: TForm3;
Lst_Height: Integer; // 记录窗体隐藏前的高度
Lst_Width: Integer; // 记录窗体隐藏前的宽度
Rec_Position: Boolean; // 是否启动窗体宽高记录标志
Cur_Top, Cur_Bottom: Integer; // 隐藏后窗体的顶端和底部位置
RevDataThread:TRevDataThread;
BoolEnable:Boolean;
implementation
uses Math, types, Unit1,StrUtils,Unit4;
{$R *.dfm}
procedure TForm3.WMMOVING(var Msg: TMessage);
begin
inherited;
with PRect(Msg.LParam)^ do
begin
if (akLeft in FAnchors) or (akRight in FAnchors) then
begin
if (Left > 0) and (Right < Screen.Width) then
begin
if Rec_Position then
begin
Bottom := top + Lst_Height;
Right := Left + Lst_Width;
Height := Lst_Height;
Width := Lst_Width;
end;
end
else
begin
SetBarHeight;
top := Cur_Top;
Bottom := Cur_Bottom;
exit;
end;
end;
Left := Min(Max(0, Left), Screen.Width - Width);
top := Min(Max(0, top), Screen.Height - Height);
Right := Min(Max(Width, Right), Screen.Width);
Bottom := Min(Max(Height, Bottom), Screen.Height);
if not Rec_Position then
begin
Lst_Height := Form3.Height;
Lst_Width := Form3.Width;
end;
FAnchors := [];
if Left = 0 then
Include(FAnchors, akLeft);
if Right = Screen.Width then
Include(FAnchors, akRight);
if top = 0 then
Include(FAnchors, akTop);
if Bottom = Screen.Height then
Include(FAnchors, akBottom);
Timer1.Enabled := FAnchors <> [];
if (akLeft in FAnchors) or (akRight in FAnchors) then
begin
Rec_Position := True;
SetBarHeight;
top := Cur_Top;
Bottom := Cur_Bottom;
end
else
Rec_Position := False;
Timer1.Enabled := FAnchors <> [];
end;
end;
procedure TForm3.Button1Click(Sender: TObject);
var
c:TComponent;
s:string;
begin
s:='01';
c:= FindComponent('Image'+s);
Clipboard.Assign(TImage(c).Picture);
RxRichEdit1.PasteFromClipboard;
end;
procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Assigned(RevDataThread) then FreeAndNil(RevDataThread);
IdTCPClient1.Disconnect;
end;
procedure TForm3.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := False;
RzButton3.Click;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
Timer1.Enabled := False;
Timer1.Interval := 200;
//FormStyle := fsStayOnTop;
BoolEnable:= False;
RzListBox1.Clear;
UnLcokTimes :=0;
LockStatus := False;
RxRichEdit1.Paragraph.LineSpacingRule:=lsSpecified;
RxRichEdit1.Paragraph.LineSpacing:=20;
ScrollBox1.VertScrollBar.Position :=0;
end;
procedure TForm3.FormMouseEnter(Sender: TObject);
begin
RzTrayIcon1.Animate := False;
RzTrayIcon1.IconIndex := 0;
end;
procedure TForm3.Timer1Timer(Sender: TObject);
const
cOffset = 2;
begin
if MousePosion then
begin
if akLeft in FAnchors then
Left := 0;
if akTop in FAnchors then
top := 0;
if akRight in FAnchors then
Left := Screen.Width - Width;
if akBottom in FAnchors then
top := Screen.Height - Height;
end
else
begin
if akLeft in FAnchors then
begin
Left := -Width + cOffset;
SetBarHeight;
top := Cur_Top;
Height := Cur_Bottom;
end;
if akTop in FAnchors then
top := -Height + cOffset;
if akRight in FAnchors then
begin
Left := Screen.Width - cOffset;
SetBarHeight;
top := Cur_Top;
Height := Cur_Bottom;
end;
if akBottom in FAnchors then
top := Screen.Height - cOffset;
end;
end;
procedure TForm3.Timer2Timer(Sender: TObject);
var
buf:TDataPack;
bbyte:TIdBytes;
begin
FillChar(buf,SizeOf(TDataPack),'');
buf.Command := CltTimer;
BByte := RawToBytes(buf, SizeOf(TDataPack));
try
IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
except
Timer2.Enabled := False;
RzAnimator1.Animate := False;
RzAnimator1.ImageIndex :=1;
ShowMessage('与服务器断开连接');
end;
end;
procedure TForm3.Timer3Timer(Sender: TObject);
begin
if not MouseInScrollBox then
begin
if ScrollBox1.Visible then ScrollBox1.Visible := False;
end;
Timer3.Enabled := ScrollBox1.Visible;
end;
procedure TForm3.IdTCPClient1Connected(Sender: TObject);
//var
// BByte: TIdBytes;
// buf: TDataPack;
begin
// FillChar(buf, SizeOf(TDataPack), '');
// buf.Command := CltConnect;
// buf.CltInfo.CltName := 'ZZPC';
// BByte := RawToBytes(buf, SizeOf(TDataPack));
// IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
// if Assigned(RevDataThread) then RevDataThread.Terminate;
end;
procedure TForm3.IdTCPClient1Disconnected(Sender: TObject);
begin
if Assigned(RevDataThread) then RevDataThread.Terminate;
RzListBox1.Items.Clear;
RzEdit2.ReadOnly := False;
RzToolButton1.Enabled := False;
RzButton4.Enabled := False;
RzCheckBox1.Checked := False;
end;
procedure TForm3.Image01Click(Sender: TObject);
var
s:String;
begin
s:=RightStr(TImage(Sender).Name,2);
RzMemo2.Text := '['+s+']';
ScrollBox1.Visible := False;
RzToolButton1.Click;
end;
procedure TForm3.Image1Click(Sender: TObject);
begin
ScrollBox1.Visible := not ScrollBox1.Visible;
Timer3.Enabled := ScrollBox1.Visible;
end;
procedure TForm3.Image2Click(Sender: TObject);
begin
if FontDialog1.Execute then RxRichEdit1.Font := FontDialog1.Font;
end;
procedure TForm3.LabeledEdit1KeyPress(Sender: TObject; var Key: Char);
begin
if ((Key = #13) and (((hi(GetKeyState(VK_CONTROL))) and $80) <> $80)) then
begin
Key :=#0;
RzButton3.Click;
end;
end;
function TForm3.MouseInScrollBox: Boolean;
begin
Result := False;
if WindowFromPoint(Mouse.CursorPos) = ScrollBox1.Handle then Result := True;
end;
function TForm3.MousePosion: Boolean;
begin
Result := False;
if (WindowFromPoint(Mouse.CursorPos) = Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzListBox1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzPanel1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzPanel2.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RxRichEdit1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzMemo2.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzCheckBox1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzEdit1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzEdit2.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzEdit3.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzAnimator1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzButton2.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzButton3.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzSplitter1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzSplitter2.Handle) or
(WindowFromPoint(Mouse.CursorPos) = LabeledEdit1.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzButton4.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzButton5.Handle) or
(WindowFromPoint(Mouse.CursorPos) = RzPanel3.Handle) or
(WindowFromPoint(Mouse.CursorPos) = ScrollBox1.Handle) then
Result := True;
end;
procedure TForm3.N1Click(Sender: TObject);
begin
RzButton5.Click;
end;
procedure TForm3.N4Click(Sender: TObject);
begin
RzButton3.Click;
end;
procedure TForm3.PopupMenu1Popup(Sender: TObject);
begin
N3.Visible :=RzButton3.Caption = '锁定';
N4.Visible := RzButton3.Caption = '锁定';
end;
procedure TForm3.RevCustMsg(var Msg: TMessage);
var
s:string;
buf:TDataPack;
begin
FillChar(buf,SizeOf(TDataPack),'');
s:=string(PDatapack(Pointer(msg.LParam))^.Data);
form1.RzMemo1.Lines.Add(s);
end;
procedure TForm3.RxRichEdit1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if RzTrayIcon1.Animate then
begin
RzTrayIcon1.Animate := False;
RzTrayIcon1.IconIndex := 0;
end;
end;
procedure TForm3.RxRichEdit1URLClick(Sender: TObject; const URLText: string;
Button: TMouseButton);
begin
ShellExecute(Application.Handle, nil, PChar(URLText), nil, nil, SW_SHOWNORMAL);
end;
procedure TForm3.RzButton1Click(Sender: TObject);
var
buf:TDataPack;
Bbyte:TIdBytes;
s,tm,bm:string;
pt:TPoint;
ctl:TComponent;
begin
if Trim(RzMemo2.Text) <>'' then
begin
if RzListBox1.ItemIndex <> -1 then
begin
s:=RzListBox1.SelectedItem;
if s= form3.RzEdit2.Text then
begin
RzListBox1.CustomHint.Title :='提示';
RzListBox1.CustomHint.Description :='您不能跟自己聊天，那是欲魔行为！';
pt.X :=RzListBox1.Width div 2;
pt.Y :=RzListBox1.Height div 6;
RzListBox1.CustomHint.ImageIndex :=1;
RzListBox1.CustomHint.HideAfter :=5000;
RzListBox1.CustomHint.ShowHint(RzListBox1.ClientToScreen(pt));
Exit;
end;
FillChar(buf, SizeOf(TDataPack), '');
buf.Command := CltSendMessage;
StrCopy(@buf.CltInfo.CltName, PChar(Encrystrings(form3.RzEdit2.Text)));
StrCopy(@buf.DstInfo.CltName, PChar(Encrystrings(s)));
tm:= RzMemo2.Text + ' (' +datetimetostr(Now)+ ')';
StrCopy(@buf.Data, PChar(Encrystrings(tm)));
BByte := RawToBytes(buf, SizeOf(TDataPack));
try
IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
if CheckBmp(tm) then
begin
bm := Copy(tm,2,2);
RxRichEdit1.Lines.Add('你对 ' +RzListBox1.SelectedItem + ' 说：');
ctl:= FindComponent('Image'+bm);
//ShowMessage(TImage(ctl).Name);
if ctl <> nil then
begin
Clipboard.Assign(TImage(ctl).Picture);
RxRichEdit1.PasteFromClipboard;
end;
end else RxRichEdit1.Lines.Add('你对 '+ RzListBox1.SelectedItem + '说: '+ tm);
PostMessage(RxRichEdit1.Handle, WM_VSCROLL, SB_BOTTOM, 0);
RzMemo2.Clear;
except
// if not IdTCPClient1.IOHandler.Opened then
// begin
ShowMessage('已与服务器断开连接,消息发送不成功');
RzListBox1.Items.Clear;
RzEdit2.ReadOnly := False;
RzToolButton1.Enabled := False;
RzButton4.Enabled := False;
RzCheckBox1.Checked := False;
// end;
end;
end else begin
RzListBox1.CustomHint.Title :='提示';
RzListBox1.CustomHint.Description :='请在这里选择一个聊天对象';
pt.X :=RzListBox1.Width div 2;
pt.Y :=RzListBox1.Height div 6;
RzListBox1.CustomHint.ImageIndex :=1;
RzListBox1.CustomHint.HideAfter :=3000;
RzListBox1.CustomHint.ShowHint(RzListBox1.ClientToScreen(pt));
end;
end else begin
RzMemo2.CustomHint.Title :='提示';
RzMemo2.CustomHint.Description :='不能发送空消息哦';
pt.X :=RzMemo2.Width div 2;
pt.Y :=RzMemo2.Height div 2;
RzMemo2.CustomHint.ImageIndex :=0;
RzMemo2.CustomHint.HideAfter :=2000;
RzMemo2.CustomHint.ShowHint(RzMemo2.ClientToScreen(pt));
end;
end;
procedure TForm3.RzButton2Click(Sender: TObject);
begin
RxRichEdit1.Clear;
end;
procedure TForm3.RzButton3Click(Sender: TObject);
var
pt:TPoint;
buf:TDataPack;
Bbyte:TIdBytes;
begin
if RzButton3.Caption = '锁定' then
begin
FillChar(buf, SizeOf(TDataPack), '');
buf.Command := CltLockSrc;
StrCopy(@buf.CltInfo.CltName, PChar(Encrystrings(form3.RzEdit2.Text)));
BByte := RawToBytes(buf, SizeOf(TDataPack));
try
try
IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
except
//
end;
finally
RxRichEdit1.Visible := False;
RzMemo2.Visible := False;
RzListBox1.Visible := False;
RzToolButton1.Visible := False;
RzButton4.Visible := False;
RzButton2.Visible := False;
RzCheckBox1.Visible := False;
RzLabel5.Visible := False;
RzEdit3.Visible := False;
RzTrayIcon1.MinimizeApp;
RzButton3.Caption :='解锁';
LabeledEdit1.Visible := True;
RzLabel1.Visible := False;
RzLabel2.Visible := False;
RzEdit1.Visible := False;
RzEdit2.Visible := False;
RzPanel3.Visible := False;
LabeledEdit1.SetFocus;
LockStatus :=True; //屏幕锁定状态
ScrollBox1.Visible := False;
end;
// except
// RzButton3.CustomHint.Title :='错误';
// RzButton3.CustomHint.Description :='锁屏失败，请重试';
// pt.X :=RzButton3.Width div 2;
// pt.Y :=RzButton3.Height div 2;
// RzButton3.CustomHint.ImageIndex :=1;
// RzButton3.CustomHint.HideAfter :=3000;
// RzButton3.CustomHint.ShowHint(RzButton3.ClientToScreen(pt));
// end;
end else begin
if LabeledEdit1.Text = UnLockString then
begin
FillChar(buf, SizeOf(TDataPack), '');
buf.Command := CltUnlockSrc;
StrCopy(@buf.CltInfo.CltName, PChar(Encrystrings(form3.RzEdit2.Text)));
BByte := RawToBytes(buf, SizeOf(TDataPack));
try
try
IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
except
//
end;
finally
UnLcokTimes :=0;
RxRichEdit1.Visible := True ;
RzMemo2.Visible := True ;
RzListBox1.Visible := True ;
RzToolButton1.Visible := True ;
RzButton4.Visible := True;
RzButton2.Visible := True ;
RzCheckBox1.Visible := True;
RzPanel3.Visible := True;
RzButton3.Caption :='锁定';
LabeledEdit1.Text :='';
LabeledEdit1.Visible := False;
if not RzCheckBox1.Checked then
begin
RzLabel5.Visible := True;
RzEdit3.Visible := True;
RzLabel1.Visible := True;
RzLabel2.Visible := True;
RzEdit1.Visible := True;
RzEdit2.Visible := True;
RzPanel3.Visible := False;
end;
LockStatus := False; //屏幕锁定状态
// RzButton3.CustomHint.Title :='错误';
// RzButton3.CustomHint.Description :='解锁失败，请重试';
// pt.X :=RzButton3.Width div 2;
// pt.Y :=RzButton3.Height div 2;
// RzButton3.CustomHint.ImageIndex :=1;
// RzButton3.CustomHint.HideAfter :=3000;
// RzButton3.CustomHint.ShowHint(RzButton3.ClientToScreen(pt));
end;
end else begin
UnLcokTimes := UnLcokTimes+1;
LabeledEdit1.Text :='';
LabeledEdit1.CustomHint.Title :='错误';
LabeledEdit1.CustomHint.Description :='解锁密码不正确';
pt.X :=LabeledEdit1.Width div 2;
pt.Y :=LabeledEdit1.Height div 2;
LabeledEdit1.CustomHint.ImageIndex :=0;
LabeledEdit1.CustomHint.HideAfter :=2000;
LabeledEdit1.CustomHint.ShowHint(LabeledEdit1.ClientToScreen(pt));
LabeledEdit1.SetFocus;
if UnLcokTimes >=3 then
begin
ShowMessage('解锁密码尝试3次均不正确，程序退出');
if IdTCPClient1.Connected then IdTCPClient1.Disconnect;
if Assigned(RevDataThread ) then RevDataThread.Terminate;
Close;
end;
end;
end;
end;
procedure TForm3.RzButton4Click(Sender: TObject);
var
buf:TDataPack;
Bbyte:TIdBytes;
s:string;
pt:TPoint;
begin
if RzListBox1.ItemIndex <>-1 then
begin
FillChar(buf, SizeOf(TDataPack), '');
s:=RzListBox1.SelectedItem;
StrCopy(@buf.CltInfo.CltName, PChar(Encrystrings(form3.RzEdit2.Text)));
StrCopy(@buf.DstInfo.CltName, PChar(Encrystrings(s)));
buf.Command :=CltClear;
BByte := RawToBytes(buf, SizeOf(TDataPack));
try
IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
RxRichEdit1.CustomHint.Title :='提示';
RxRichEdit1.CustomHint.Description :='您已清除自己和对方聊天记录';
pt.X :=RxRichEdit1.Width div 2;
pt.Y :=RxRichEdit1.Height div 2;
RxRichEdit1.CustomHint.ImageIndex :=1;
RxRichEdit1.CustomHint.HideAfter :=8000;
RxRichEdit1.CustomHint.ShowHint(RxRichEdit1.ClientToScreen(pt));
RxRichEdit1.Clear;
except
ShowMessage('已与服务器断开连接,清除屏幕不成功');
RzListBox1.Items.Clear;
RzEdit2.ReadOnly := False;
RzToolButton1.Enabled := False;
RzButton4.Enabled := False;
RzCheckBox1.Checked := False;
end;
end else begin
RzListBox1.CustomHint.Title :='提示';
RzListBox1.CustomHint.Description :='请在这里选择一个清除屏幕对象';
pt.X :=RzListBox1.Width div 2;
pt.Y :=RzListBox1.Height div 6;
RzListBox1.CustomHint.ImageIndex :=1;
RzListBox1.CustomHint.HideAfter :=3000;
RzListBox1.CustomHint.ShowHint(RzListBox1.ClientToScreen(pt));
end;
end;
procedure TForm3.RzButton5Click(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm3.RzCheckBox1Click(Sender: TObject);
var
pt:TPoint;
begin
IdTCPClient1.Host := RzEdit1.Text;
if RzEdit3.Text <>'' then IdTCPClient1.Port := StrToInt(RzEdit3.Text)
else begin
RzEdit3.CustomHint.Title :='提示';
RzEdit3.CustomHint.Description :='服务器端口不能为空';
pt.X :=RzEdit3.Width div 2;
pt.Y :=RzEdit3.Height div 2;
RzEdit3.CustomHint.ImageIndex :=0;
RzEdit3.CustomHint.HideAfter :=2000;
RzEdit3.CustomHint.ShowHint(RzEdit3.ClientToScreen(pt));
RzCheckBox1.Checked := False;
Exit;
end;
if (RzEdit2.Text ='') then
begin
RzEdit2.CustomHint.Title :='提示';
RzEdit2.CustomHint.Description :='聊天昵称不能为空';
pt.X :=RzEdit2.Width div 2;
pt.Y :=RzEdit2.Height div 2;
RzEdit2.CustomHint.ImageIndex :=0;
RzEdit2.CustomHint.HideAfter :=2000;
RzEdit2.CustomHint.ShowHint(RzEdit2.ClientToScreen(pt));
RzCheckBox1.Checked := False;
Exit;
end;
if Pos(' ',RzEdit2.Text)<>0 then
begin
RzEdit2.CustomHint.Title :='提示';
RzEdit2.CustomHint.Description :='聊天昵称中不能包含空格和 | 字符';
pt.X :=RzEdit2.Width div 2;
pt.Y :=RzEdit2.Height div 2;
RzEdit2.CustomHint.ImageIndex :=0;
RzEdit2.CustomHint.HideAfter :=2000;
RzEdit2.CustomHint.ShowHint(RzEdit2.ClientToScreen(pt));
RzCheckBox1.Checked := False;
Exit;
end;
if (RzEdit1.Text ='') then
begin
RzEdit1.CustomHint.Title :='提示';
RzEdit1.CustomHint.Description :='服务器地址不能为空';
pt.X :=RzEdit1.Width div 2;
pt.Y :=RzEdit1.Height div 2;
RzEdit1.CustomHint.ImageIndex :=0;
RzEdit1.CustomHint.HideAfter :=2000;
RzEdit1.CustomHint.ShowHint(RzEdit1.ClientToScreen(pt));
RzCheckBox1.Checked := False;
Exit;
end;
try
if RzCheckBox1.Checked then
begin
IdTCPClient1.Connect;
RevDataThread := TRevDataThread.Create(True);
RevDataThread.FreeOnTerminate := True;
RevDataThread.Start;
RzToolButton1.Enabled := True;
RzButton4.Enabled := True;
RzCheckBox1.Checked := True;
RzEdit2.ReadOnly := True;
Timer2.Enabled := True;
RzEdit3.Visible := False;
RzLabel5.Visible := False;
RzLabel1.Visible := False;
RzLabel2.Visible := False;
RzPanel3.Visible := True;
RzEdit1.Visible := False;
RzEdit2.Visible := False;
RzAnimator1.Animate := True;
end
else
begin
IdTCPClient1.Disconnect;
if Assigned(RevDataThread) then RevDataThread.Terminate;
RzCheckBox1.Checked := False;
RzToolButton1.Enabled :=False;
RzButton4.Enabled := False;
RzEdit2.ReadOnly := False;
Timer2.Enabled := False;
RzEdit3.Visible := True;
RzLabel5.Visible := True;
RzLabel1.Visible := True;
RzLabel2.Visible := True;
RzPanel3.Visible := False;
RzEdit1.Visible := True;
RzEdit2.Visible := True;
RzAnimator1.Animate := False;
RzAnimator1.ImageIndex :=1;
end;
except
RzEdit2.ReadOnly := False;
RzCheckBox1.Checked := False;
RzToolButton1.Enabled :=False;
RzButton4.Enabled := False;
if Assigned(RevDataThread) then RevDataThread.Terminate;
if IdTCPClient1.Connected then IdTCPClient1.Disconnect;
ShowMessage('连接服务器失败，请确认服务器地址是否正确');
end;
end;
procedure TForm3.RzEdit1KeyPress(Sender: TObject; var Key: Char);
var
tmp: string;
begin
tmp := '0123456789.' + Char(VK_BACK) + Char(VK_DELETE);
if Pos(Key, tmp) = 0 then Key := #0;
end;
procedure TForm3.RzEdit3KeyPress(Sender: TObject; var Key: Char);
var
tmp: string;
begin
tmp := '0123456789' + Char(VK_BACK) + Char(VK_DELETE);
if Pos(Key, tmp) = 0 then Key := #0;
end;
procedure TForm3.RzListBox1DblClick(Sender: TObject);
begin
// form1.Show;
end;
procedure TForm3.RzListBox1MouseEnter(Sender: TObject);
begin
if RzTrayIcon1.Animate then
begin
RzTrayIcon1.Animate := False;
RzTrayIcon1.IconIndex := 0;
end;
end;
procedure TForm3.RzMemo2KeyPress(Sender: TObject; var Key: Char);
begin
if (Key = #13) then
begin
if (((hi(GetKeyState(VK_CONTROL))) and $80) <> $80) and n2.Checked then
begin
Key :=#0;
if RzToolButton1.Enabled then RzToolButton1.Click;
end;
end;
end;
procedure TForm3.RzMemo2MouseEnter(Sender: TObject);
begin
if RzTrayIcon1.Animate then
begin
RzTrayIcon1.Animate := False;
RzTrayIcon1.IconIndex := 0;
end;
end;
procedure TForm3.RzSpinButtons1DownLeftClick(Sender: TObject);
begin
if RzPanel3.Height > 40 then RzPanel3.Height := (RzPanel3.Height -4) div 3;
end;
procedure TForm3.RzSpinButtons1UpRightClick(Sender: TObject);
begin
if RzPanel3.Height <40 then RzPanel3.Height := RzPanel3.Height *3 +4;
end;
procedure TForm3.RzTrayIcon1MinimizeApp(Sender: TObject);
begin
BoolEnable:= True;
end;
procedure TForm3.RzTrayIcon1RestoreApp(Sender: TObject);
begin
BoolEnable:= False;
RzTrayIcon1.Animate:= False;
RzTrayIcon1.IconIndex := 0;
end;
procedure TForm3.SetBarHeight;
var
AppBarData: TAPPBARDATA;
begin
AppBarData.cbSize := SizeOf(AppBarData);
If SHAppBarMessage(ABM_GETSTATE, AppBarData) AND (ABS_AUTOHIDE) <> 0 then
begin
Cur_Top := 1;
Cur_Bottom := Screen.Height - 1;
end
else
begin
SHAppBarMessage(ABM_GETTASKBARPOS, AppBarData);
case AppBarData.uEdge of
ABE_TOP:
begin
Cur_Top := AppBarData.rc.Bottom + 1;
Cur_Bottom := Screen.Height - 1;
end;
ABE_LEFT:
begin
Cur_Top := 1;
Cur_Bottom := Screen.Height - 1;
end;
ABE_RIGHT:
begin
Cur_Top := 1;
Cur_Bottom := Screen.Height - 1;
end;
ABE_BOTTOM:
begin
Cur_Top := 1;
Cur_Bottom := Screen.Height -
(AppBarData.rc.Bottom - AppBarData.rc.top) - 1;
end;
end;
end;
end;
procedure TForm3.wmsizing(var Msg: TMessage);
begin
inherited;
if (akRight in FAnchors) then
begin
with PRect(Msg.LParam)^ do
begin
Left := Screen.Width - Width;
top := Cur_Top;
Right := Screen.Width;
Bottom := Cur_Bottom
end;
end
else if (akLeft in FAnchors) then
begin
with PRect(Msg.LParam)^ do
begin
Left := 0;
top := Cur_Top;
Right := Width;
Bottom := Cur_Bottom;
end;
end;
end;
{ TRevDataThread }
procedure TRevDataThread.AddCltList;
var
t,s:string;
List:TStringList;
OldCount,NewCount:Integer;
begin
list:= TStringList.Create;
OldCount := Form3.RzListBox1.Count;
Form3.RzListBox1.Clear;
t:= string(buf.Data);
// count:=0; // dak|dkej|dinna|
// for i:= 0 to strlen(pchar(s)) do if copy(s,i,1)='|' then count:=count+1; //计算字符串中包含几个分隔符 |
// for I := 0 to Count do
// begin
// ss:= LeftStr(s,Pos('|',s)-1);
// end;
s:= Uncrystrings(t);
s:=LeftStr(s,StrLen(PChar(s))-1);
List.Delimiter:='|';
List.DelimitedText:=s;
//Form3.RzTrayIcon1.Hint := List.Text;
Form3.RzListBox1.Items.Assign(list);
NewCount := form3.RzListBox1.Count;
List.Free;
if NewCount > OldCount then form3.RzTrayIcon1.ShowBalloonHint('提示','有用户登录',bhiInfo,10)
else if NewCount < OldCount then form3.RzTrayIcon1.ShowBalloonHint('提示','有用户下线',bhiInfo,10);
end;
procedure TRevDataThread.AddMessage;
var
ss:string;
begin
ss:= DecryStr(UncrypKey(string(buf.CltInfo.CltName),TKey),mkey);
case buf.Command of
CltLockSrc: Form3.RxRichEdit1.Lines.Add(ss + ' 锁定了屏幕');
CltUnlockSrc : Form3.RxRichEdit1.Lines.Add(ss + ' 解锁了屏幕');
end;
PostMessage(Form3.RxRichEdit1.Handle, WM_VSCROLL, SB_BOTTOM, 0);
end;
procedure TRevDataThread.ClearScr;
var
pt:TPoint;
ss:string;
begin
Form3.RxRichEdit1.Clear;
ss:= Uncrystrings(string(buf.CltInfo.CltName));
Form3.RxRichEdit1.CustomHint.Title :='提示';
Form3.RxRichEdit1.CustomHint.Description := ss+' 清除了您的聊天记录';
pt.X :=Form3.RxRichEdit1.Width div 2;
pt.Y :=Form3.RxRichEdit1.Height div 2;
Form3.RxRichEdit1.CustomHint.ImageIndex :=1;
Form3.RxRichEdit1.CustomHint.HideAfter :=8000;
Form3.RxRichEdit1.CustomHint.ShowHint(Form3.RxRichEdit1.ClientToScreen(pt));
Form3.RxRichEdit1.Clear;
Form3.RxRichEdit1.Lines.Add(ss+' 清除了您的聊天记录');
end;
procedure TRevDataThread.CltMessageIn;
var
s:string;
begin
s:= Uncrystrings(string(buf.CltInfo.CltName));
form3.RxRichEdit1.Lines.Add(s + ' 可能离开，TA的屏幕是锁定状态') ;
PostMessage(Form3.RxRichEdit1.Handle, WM_VSCROLL, SB_BOTTOM, 0);
end;
procedure TRevDataThread.DoDiscnt;
begin
form3.RzCheckBox1.Checked := False;
Form3.IdTCPClient1.Disconnect;
ShowMessage(Form3.RzEdit2.Text +' 已经存在，请更名重新登录');
end;
procedure TRevDataThread.DoSrvCloseQuery;
begin
Form3.IdTCPClient1.Disconnect;
Form3.RzCheckBox1.Checked := False;
end;
procedure TRevDataThread.DoSrvMessage;
var
nr,ds:string;
begin
nr:=Uncrystrings(string(buf.Data));
ds:= Uncrystrings(string(buf.DstInfo.CltName));
Form3.RxRichEdit1.Lines.Add('[服务器消息]：您发送给 ['+ ds +'] 的消息： “'+ nr +'"，转发不成功，请重新发送');
PostMessage(Form3.RxRichEdit1.Handle, WM_VSCROLL, SB_BOTTOM, 0);
end;
procedure TRevDataThread.Execute;
var
BByte: TIdBytes;
Nc:string;
begin
inherited;
FillChar(buf, SizeOf(TDataPack), '');
buf.Command := CltConnect;
Nc := Encrystrings(form3.RzEdit2.Text);
StrCopy(@buf.CltInfo.CltName, PChar(Nc));
BByte := RawToBytes(buf, SizeOf(TDataPack));
Form3.IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
while (not Terminated) and (Form3.IdTCPClient1.Connected) do
begin
FillChar(buf, SizeOf(TDataPack), '');
Form3.IdTCPClient1.IOHandler.ReadBytes(BByte, SizeOf(TDataPack), False);
BytesToRaw(BByte, buf, SizeOf(TDataPack));
case buf.Command of
CltSendMessage:
begin
//SendMessage(Handle,CustMsg,CltSendMessage,Integer(PDataPack(buf)));
Synchronize(showmsg);
if LockStatus then
begin
buf.DstInfo.CltName := buf.CltInfo.CltName;
buf.Command := CltMessage;
StrCopy(@buf.CltInfo.CltName, PChar(Encrystrings(form3.RzEdit2.Text)));
BByte := RawToBytes(buf, SizeOf(TDataPack));
Form3.IdTCPClient1.IOHandler.Write(BByte, SizeOf(TDataPack));
end;
end;
CltList : Synchronize(AddCltList);
CltDisconnect : Synchronize(DoDiscnt);
CltTimer : ;
CltClear : Synchronize(clearscr);
CltLockSrc,CltUnlockSrc : Synchronize(Addmessage);
CltMessage : Synchronize(cltmessageIn);
SrvMessage : Synchronize(DoSrvMessage);
SrvCloseQuery : Synchronize(DoSrvCloseQuery);
end;
end;
end;
procedure TRevDataThread.ShowMsg;
var
s,ss,bm:string;
ctl:TComponent;
begin
s:=Uncrystrings(string(buf.Data));
ss:= Uncrystrings(string(buf.CltInfo.CltName));
if CheckBmp(s) then
begin
bm := Copy(s,2,2);
Form3.RxRichEdit1.Lines.Add(ss + ' 对你说：');
//Clipboard.Assign(form3.Image1.Picture);
ctl:= Form3.FindComponent('Image'+bm);
if ctl <> nil then
begin
Clipboard.Assign(TImage(ctl).Picture);
form3.RxRichEdit1.PasteFromClipboard;
end;
end else Form3.RxRichEdit1.Lines.Add(ss + ' 对你说：'+s );
PostMessage(Form3.RxRichEdit1.Handle, WM_VSCROLL, SB_BOTTOM, 0);
if BoolEnable or ((form3.Timer1.Enabled) and (not form3.MousePosion)) then
begin
if not Form3.RzTrayIcon1.Animate then Form3.RzTrayIcon1.Animate:=True;
end;
end;
end.
公共单元
unit Unit2;
interface
uses Windows,Messages,Classes,SysUtils,StrUtils;
const CustMsg = WM_USER + 2110;
CltConnect = 1;
CltDisconnect =2;
CltSendMessage =3;
CltList=4;
CltTimer =5;
CltClear = 6;
CltLockSrc =7;
CltUnlockSrc = 8;
CltMessage = 9;
SrvMessage =10;
SrvTimer =11;
SrvCloseQuery =12;
DataSize = 1024 *5; //数据缓冲区大小
UnLockString = '123456';
type
TCltInfo = packed record
CltIP:array[0..14] of Char;
CltName:array[0..255] of Char;
end;
TDataPack = record
CltInfo:TCltInfo;
DstInfo:TCltInfo;
Command:Integer;
Data:array[0..DataSize -1] of Char;
end;
PDataPack = ^TDataPack;
function Encrystrings(str:string):string;
function Uncrystrings(str:string):string;
function EncrypKey(Src: String; Key: String): string;
function UncrypKey(Src: String; Key: String): string;
function GetTMkey:string;
function CheckBmp(Str:string):Boolean;
var
UnLcokTimes:Integer;
LockStatus:Boolean;
implementation
uses Unit4;
function CheckBmp(Str:string):Boolean;
begin
Result := False;
if Length(Str) < 4 then Exit;
if (LeftStr(Str,1) ='[') and (Copy(Str,4,1) = ']') then Result :=True;
end;
function Encrystrings(str:string):string;
var
tmp:string;
begin
tmp := EncryStr(str,MKey);
Result := EncrypKey(tmp,TKey);
end;
function Uncrystrings(str:string):string;
var
tmp:string;
begin
tmp:= UncrypKey(str,TKey);
Result := DecryStr(tmp,MKey);
end;
// 加密函数
function EncrypKey(Src: String; Key: String): string;
var
KeyLen: integer;
KeyPos: integer;
offset: integer;
dest: string;
SrcPos: integer;
SrcAsc: integer;
Range: integer;
begin
//此处省略，自己写
end;
// 解密函数
function UncrypKey(Src: String; Key: String): string;
var
//idx: integer;
KeyLen: integer;
KeyPos: integer;
offset: integer;
dest: string;
SrcPos: integer;
SrcAsc: integer;
TmpSrcAsc: integer;
begin
//此处省略，自己写
end;
function GetTMkey:string;
var
ss: string;
n: Integer;
begin
ss := '';
Randomize;
repeat
n := Random(127);
if n>=34 then ss := ss + char(n);
until (Length(ss)>=12);
Result := ss;
end;
end.