WINCE下的TCP

fireyu

Lazarus的INet控件在WINCE下编译不过，没办法，自己动手了
TCP_客户端

2. unit uTcp_Cln;
3. {
4.     Runtime:
5.     lazarus-1.0RC2-fpc-2.6.0-win32.exe
6.     lazarus-1.0RC2-fpc-2.6.0-cross-arm-wince-win32.exe
7.     Wince6.0
8.     Powered by: Fireyu
9.     2012.09.19;
10.     Free for All;
11. }
12. {$mode objfpc}{$H+}
13. interface
14. uses
15.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
16.   ExtCtrls, Sockets;
17. type
18.   { TfrmTcpCln }
19.   TfrmTcpCln = class(TForm)
20.     btnAccept: TButton;
21.     edtData: TEdit;
22.     ImgLogo: TImage;
23.     ip1: TEdit;
24.     ip2: TEdit;
25.     ip3: TEdit;
26.     ip4: TEdit;
27.     edtPort: TEdit;
28.     gbxTcp: TGroupBox;
29.     Label1: TLabel;
30.     Label2: TLabel;
31.     Label3: TLabel;
32.     MTCP: TMemo;
33.     procedure btnAcceptClick(Sender: TObject);
34.   private
35.     { private declarations }
36.   public
37.     { public declarations }
38.     tcpSock : TSocket;
39.     tcpServer : TSockAddr;
40.     tcpLen: tsocklen;
41.     sData : String;
42.     DataLen : Integer;
43.   end;
44. var
45.   frmTcpCln: TfrmTcpCln;
46. implementation
47. {$R *.lfm}
48. { TfrmTcpCln }
49. procedure TfrmTcpCln.btnAcceptClick(Sender: TObject);
50. var
51.   rc : Integer;
52.   sIp : String;
53.   iPort : Integer;
54.   sBuff : String;
55. begin
56.   tcpSock:= fpsocket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
57.   if tcpSock=SOCKET_ERROR then
58.   begin
59.     MTCP.Lines.Add('Socket Error!');
60.     CloseSocket(tcpSock);
61.     Exit;
62.   end;
63.   try
64.     sIp :=  IntToHex(StrToInt(Ip4.Text),2)
65.            +IntToHex(StrToInt(Ip3.Text),2)
66.            +IntToHex(StrToInt(Ip2.Text),2)
67.            +IntToHex(StrToInt(Ip1.Text),2);
68.   except
69.     MTCP.Lines.Add('IP Set Error!');
70.     CloseSocket(tcpSock);
71.     Exit;
72.   end;
73.   try
74.     iPort := StrToInt(edtPort.Text);
75.   except
76.     MTCP.Lines.Add('Port Set Error!');
77.     CloseSocket(tcpSock);
78.     Exit;
79.   end;
80.   tcpServer.sin_addr.s_addr:= StrToInt('$'+sIp);
81.   tcpServer.sin_family:= AF_INET;
82.   tcpServer.sin_port:= htons(iPort);
83.   tcpLen := SizeOf(tcpServer);
84.   rc := fpbind(tcpSock,@tcpServer,tcpLen);
85.   rc := fpconnect(tcpSock,@tcpServer,tcpLen);
86.   DataLen := Length(edtData.Text);
87.   sBuff := edtData.Text;
88.   rc := fpsend(tcpSock,PChar(sBuff),DataLen,0);
89.   if rc < 1 then
90.   begin
91.     MTCP.Lines.Add('Send Error!');
92.     CloseSocket(tcpSock);
93.     Exit;
94.   end;
95.   CloseSocket(tcpSock);
96.   MTCP.Lines.Add('Send Data Success!');
97. end;
99. end.

复制代码

TCP服务器端

1. unit uTcp_Srv;
3. {$mode objfpc}{$H+}
5. {
6.     Runtime:
7.     lazarus-1.0RC2-fpc-2.6.0-win32.exe
8.     lazarus-1.0RC2-fpc-2.6.0-cross-arm-wince-win32.exe
9.     Wince6.0
11.     Powered by: Fireyu
12.     2012.09.19;
14.     Free for All;
15. }
17. interface
19. uses
21.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
22.   ExtCtrls, Sockets;
24. type
26.   { TfrmTcp_Srv }
28.   TfrmTcp_Srv = class(TForm)
29.     btnListon: TButton;
30.     btnEnd: TButton;
31.     edtPort: TEdit;
32.     gbxLazarus: TGroupBox;
33.     ImgLogo: TImage;
34.     Label1: TLabel;
35.     MTCP: TMemo;
36.     procedure btnEndClick(Sender: TObject);
37.     procedure btnListonClick(Sender: TObject);
38.     procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
39.   private
40.     { private declarations }
41.   public
42.     { public declarations }
43.   end;
45. var
46.   frmTcp_Srv: TfrmTcp_Srv;
47.   bContinue : Boolean;
48.   TcpSock : TSocket;
49.   TcpServer : TSockAddr;
51.   TcpSock_Client : Tsocket;
52.   TcpServer_Client : TSockAddr;
53.   iLen, iCLen : Integer;
55.   sAll : String;
57. implementation
59. {$R *.lfm}
61. { TfrmTcp_Srv }
63. function TcpReceived(pParam : Pointer):Integer;register;
64. var
65.    rc,iL : Integer;
66.    sBuff : Array[0..1023] of BYTE;
67.    sktClient : Tsocket;
68. begin
69.   sktClient:= Tsocket(pParam^);                        //获取客户端Socket
71.   rc := fprecv(sktClient,@sBuff,1024,MSG_PARTIAL);     //MSG_PARTIAL阻塞模式
72.   if rc >= 0 then
73.   begin
74.     //锁开始
75.     iL := 0;
76.     sAll := '';
77.     while (iL < rc) do
78.     begin
79.       sAll := sAll+Char(sBuff[iL]);
80.       Inc(iL);
81.     end;
82.     sAll :='DataLen:'+IntToStr(rc)+'|Data:'+sAll;
83.     frmTcp_Srv.MTCP.Lines.Add(sAll);                   //错误的示范!请用消息传递或者异步锁
84.     //锁结束
85.   end;
87.   CloseSocket(sktClient);                              //不要忘记关闭Socket!
88.   Result:=1;
89. end;
91. function CreateTcp(pParam : Pointer):Integer;register;
92. var
93.   ITcp_Id : TThreadID;
94. begin
95.   ITcp_Id := 0;
96.   while (bContinue) do                                     //服务开始运行!
97.   begin
98.     TcpSock_Client := fpaccept(tcpSock,@TcpServer_Client,@iCLen);
99.     if TcpSock_Client > -1 then
100.     begin;
101.       BeginThread(@TcpReceived,@TcpSock_Client,ITcp_Id,0); //接1次数据即销毁线程,不连接不接收
102.     end;
103.   end;
104.   Result := 1;
105. end;
107. procedure TfrmTcp_Srv.btnListonClick(Sender: TObject);
108. var
109.     rc, iPort, iLog : Integer;
110.     Tcp_ID : TThreadID;
111. begin
112.     tcpSock:= fpsocket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
114.     Handle:= Self.Handle;
115.     if tcpSock=SOCKET_ERROR then
116.     begin
117.       MTCP.Lines.Add('Socket Error!');
118.       CloseSocket(tcpSock);
119.       Exit;
120.     end;
122.     iPort := StrToInt(edtPort.Text);
124.     tcpServer.sin_addr.s_addr:= INADDR_ANY;
125.     tcpServer.sin_family:= AF_INET;
126.     tcpServer.sin_port:= htons(iPort);
128.     iLen := SizeOf(tcpServer);
130.     rc := fpbind(tcpSock,@tcpServer,iLen);
132.     if rc < 0 then
133.     begin
134.       MTCP.Lines.Add('Bind Socket Error!');
135.     end;
137.     iLog := 5;                                           //最大监听连接数iLog
138.     fplisten(tcpSock,iLog);                              //开始监听
140.     bContinue:= True;
141.     Tcp_ID:=0;
142.     MTCP.Lines.Add('Server Is Ready!');
144.     iCLen := SizeOf(TcpServer_Client);
146.     BeginThread(@CreateTcp,nil,Tcp_ID,0);
148. end;
150. procedure TfrmTcp_Srv.btnEndClick(Sender: TObject);
151. begin
152.   bContinue:= False;                                     //通知程序全部结束
153. end;
155. procedure TfrmTcp_Srv.FormClose(Sender: TObject; var CloseAction: TCloseAction);
156. begin
157.   //关闭程序时,关闭Socket
158.   CloseSocket(TcpSock);
159.   CloseSocket(TcpSock_Client);
160. end;
163. end.

复制代码

fireyu

上述代码的工程文件如下：

bugxiong

Lazarus社区有你更精彩！

jmyzk

请问文件是用什么压缩工具压的？打不开

fireyu

是用winrar压缩的。

ejiemu

俺不用INet，俺自己从Delphi里面拔出来的TTCPClient、TTCPServer，用的挺好，支持多线程的，支持WinCE、Win32、Linux，有需要的联系俺。

斯文败类

楼上的可以提供下载么？让我等菜鸟研究一下