最近閑來無事，重新學習了Indy10，順手寫了一段即時通訊代碼。與上次寫的筆記有不同之處，但差別不大。
未研究過TCP打洞技術，所以下面的代碼采用的是 客戶端--服務器--客戶端 模式，也就是服務器端轉發消息的模式。
客戶端模仿了QQ，可以在屏幕四周停靠自動隱藏
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.