请选择 进入手机版 | 继续访问电脑版

Lazarus中文社区

 找回密码
 立即注册

QQ登录

只需一步,快速开始

Lazarus IDE and 组件 下载地址版权申明
查看: 3163|回复: 6

WINCE下的TCP

[复制链接]

该用户从未签到

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

TCP服务器端
  1. unit uTcp_Srv;
  2. {$mode objfpc}{$H+}
  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. interface
  13. uses
  14.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  15.   ExtCtrls, Sockets;
  16. type
  17.   { TfrmTcp_Srv }
  18.   TfrmTcp_Srv = class(TForm)
  19.     btnListon: TButton;
  20.     btnEnd: TButton;
  21.     edtPort: TEdit;
  22.     gbxLazarus: TGroupBox;
  23.     ImgLogo: TImage;
  24.     Label1: TLabel;
  25.     MTCP: TMemo;
  26.     procedure btnEndClick(Sender: TObject);
  27.     procedure btnListonClick(Sender: TObject);
  28.     procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
  29.   private
  30.     { private declarations }
  31.   public
  32.     { public declarations }
  33.   end;
  34. var
  35.   frmTcp_Srv: TfrmTcp_Srv;
  36.   bContinue : Boolean;
  37.   TcpSock : TSocket;
  38.   TcpServer : TSockAddr;
  39.   TcpSock_Client : Tsocket;
  40.   TcpServer_Client : TSockAddr;
  41.   iLen, iCLen : Integer;
  42.   sAll : String;
  43. implementation
  44. {$R *.lfm}
  45. { TfrmTcp_Srv }
  46. function TcpReceived(pParam : Pointer):Integer;register;
  47. var
  48.    rc,iL : Integer;
  49.    sBuff : Array[0..1023] of BYTE;
  50.    sktClient : Tsocket;
  51. begin
  52.   sktClient:= Tsocket(pParam^);                        //获取客户端Socket
  53.   rc := fprecv(sktClient,@sBuff,1024,MSG_PARTIAL);     //MSG_PARTIAL阻塞模式
  54.   if rc >= 0 then
  55.   begin
  56.     //锁开始
  57.     iL := 0;
  58.     sAll := '';
  59.     while (iL < rc) do
  60.     begin
  61.       sAll := sAll+Char(sBuff[iL]);
  62.       Inc(iL);
  63.     end;
  64.     sAll :='DataLen:'+IntToStr(rc)+'|Data:'+sAll;
  65.     frmTcp_Srv.MTCP.Lines.Add(sAll);                   //错误的示范!请用消息传递或者异步锁
  66.     //锁结束
  67.   end;
  68.   CloseSocket(sktClient);                              //不要忘记关闭Socket!
  69.   Result:=1;
  70. end;
  71. function CreateTcp(pParam : Pointer):Integer;register;
  72. var
  73.   ITcp_Id : TThreadID;
  74. begin
  75.   ITcp_Id := 0;
  76.   while (bContinue) do                                     //服务开始运行!
  77.   begin
  78.     TcpSock_Client := fpaccept(tcpSock,@TcpServer_Client,@iCLen);
  79.     if TcpSock_Client > -1 then
  80.     begin;
  81.       BeginThread(@TcpReceived,@TcpSock_Client,ITcp_Id,0); //接1次数据即销毁线程,不连接不接收
  82.     end;
  83.   end;
  84.   Result := 1;
  85. end;
  86. procedure TfrmTcp_Srv.btnListonClick(Sender: TObject);
  87. var
  88.     rc, iPort, iLog : Integer;
  89.     Tcp_ID : TThreadID;
  90. begin
  91.     tcpSock:= fpsocket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
  92.     Handle:= Self.Handle;
  93.     if tcpSock=SOCKET_ERROR then
  94.     begin
  95.       MTCP.Lines.Add('Socket Error!');
  96.       CloseSocket(tcpSock);
  97.       Exit;
  98.     end;
  99.     iPort := StrToInt(edtPort.Text);
  100.     tcpServer.sin_addr.s_addr:= INADDR_ANY;
  101.     tcpServer.sin_family:= AF_INET;
  102.     tcpServer.sin_port:= htons(iPort);
  103.     iLen := SizeOf(tcpServer);
  104.     rc := fpbind(tcpSock,@tcpServer,iLen);
  105.     if rc < 0 then
  106.     begin
  107.       MTCP.Lines.Add('Bind Socket Error!');
  108.     end;
  109.     iLog := 5;                                           //最大监听连接数iLog
  110.     fplisten(tcpSock,iLog);                              //开始监听
  111.     bContinue:= True;
  112.     Tcp_ID:=0;
  113.     MTCP.Lines.Add('Server Is Ready!');
  114.     iCLen := SizeOf(TcpServer_Client);
  115.     BeginThread(@CreateTcp,nil,Tcp_ID,0);
  116. end;
  117. procedure TfrmTcp_Srv.btnEndClick(Sender: TObject);
  118. begin
  119.   bContinue:= False;                                     //通知程序全部结束
  120. end;
  121. procedure TfrmTcp_Srv.FormClose(Sender: TObject; var CloseAction: TCloseAction);
  122. begin
  123.   //关闭程序时,关闭Socket
  124.   CloseSocket(TcpSock);
  125.   CloseSocket(TcpSock_Client);
  126. end;
  127. end.
复制代码

评分

参与人数 1威望 +7 收起 理由
bugxiong + 7 Lazarus社区有你更精彩!

查看全部评分

回复

使用道具 举报

该用户从未签到

 楼主 发表于 2012-9-19 19:15:38 | 显示全部楼层
上述代码的工程文件如下:

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
回复 支持 反对

使用道具 举报

该用户从未签到

发表于 2012-9-20 08:37:14 | 显示全部楼层
Lazarus社区有你更精彩!
回复 支持 反对

使用道具 举报

该用户从未签到

发表于 2012-9-22 12:03:35 | 显示全部楼层
请问文件是用什么压缩工具压的?打不开
回复 支持 反对

使用道具 举报

该用户从未签到

 楼主 发表于 2012-9-22 13:32:20 | 显示全部楼层
是用winrar压缩的。
回复 支持 反对

使用道具 举报

该用户从未签到

发表于 2013-2-24 06:49:14 | 显示全部楼层
俺不用INet,俺自己从Delphi里面拔出来的TTCPClient、TTCPServer,用的挺好,支持多线程的,支持WinCE、Win32、Linux,有需要的联系俺。
回复 支持 反对

使用道具 举报

该用户从未签到

发表于 2013-3-26 15:46:25 | 显示全部楼层
楼上的可以提供下载么?让我等菜鸟研究一下
回复 支持 反对

使用道具 举报

QQ|手机版|小黑屋|Lazarus中国|Lazarus中文社区 ( 鄂ICP备16006501号-1

GMT+8, 2019-7-19 16:42 , Processed in 0.145087 second(s), 28 queries .

Powered by Discuz! F1.0 Build 20160930

© 2001-2019 Comsenz Inc. & Discuz! Fans

快速回复 返回顶部 返回列表