图片传输问题(50分)

我想在internet上点对点传输图片信息,但我从来没接触过网络编程,
那位朋友给我点思路,谢谢

Delphi提供了很多这样的组件。
直接流传输

>>

get it from demo of delphi

服务器端发送图象例程
var
m1:tmemorystream;//全局
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
desk:tcanvas;
bitmap:tbitmap;
jpg:tjpegimage;
begin
bitmap:=tbitmap.Create;
jpg:=tjpegimage.Create;
desk:=tcanvas.Create; //以下代码为取得当前屏幕图象
desk.Handle:=getdc(hwnd_desktop);
m1:=tmemorystream.Create; //初始化流m1,在用sendstream(m1)发送流后，
//它将保留到socket对话结束，
//不能用手工free掉，否则会触发异常
with bitmap do
begin
width:=screen.Width;
height:=screen.Height;
canvas.CopyRect(canvas.cliprect,desk,desk.cliprect);//获得桌面的图象
end;
jpg.Assign(bitmap); //将图象转成JPG格式
jpg.SaveToStream(m1); //将JPG图象写入流中
jpg.free;
m1.Position:=0;
s1:=inttostr(m1.size);
Socket.sendtext(s1);
end;
客户端接受图象例程
var
c:longint;
m:tmemorystream;//全局
procedure TForm1.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var
buffer:array [0..10000] of byte; //设置接收缓冲区
len:integer;
ll:string;
b:tbitmap;
j:tjpegimage;
begin
len:=socket.ReceiveLength; //读出包长度
socket.ReceiveBuf(buffer,len); //接收数据包并读入缓冲区内
m.Write(buffer,len); //追加入流M中
if m.Size>=c then //如果流长度大于需接收的字节数，则接收完毕
begin
m.Position:=0;
b:=tbitmap.Create;
j:=tjpegimage.Create;
try
j.LoadFromStream(m); //将流M中的数据读至JPG图像对象J中
b.Assign(j); //将JPG转为BMP
Image1.Picture.Bitmap.Assign(b); //分配给image1元件
finally //以下为清除工作
b.free;
j.free;
clientsocket1.Active:=false;
clientsocket1.Active:=true;
m.Clear;
c:=0;
end;
end;
end;
希望对你有用！

最好加上压缩和解压缩模块

用JPG不如用ZLIB，
在 uses 中加入 zlib

procedure CompressStream(var MyStream: TMemoryStream);
var
SourceStream: TCompressionStream;
DestStream: TMemoryStream;
Count: Integer;
Begin
//压缩图像
//获得图像流的原始尺寸
Count := MyStream.Size;
DestStream := TMemoryStream.Create;
SourceStream:=TCompressionStream.Create(clDefault, DestStream);
Try
//SourceStream中保存着原始的图像流
MyStream.SaveToStream(SourceStream);
//将原始图像流进行压缩， DestStream中保存着压缩后的图像流
SourceStream.Free;
MYStream.Clear;
//写入原始图像的尺寸
MyStream.WriteBuffer(Count, SizeOf(Count));
//写入经过压缩的图像流
MyStream.CopyFrom(DestStream, 0);
//复位流指针
MyStream.Position := 0;
finally
DestStream.Free;
end;
end;

发之前compressStream一下，然后显示的时候

procedure UnCompressStream(var MyStream: TMemoryStream);
var
SourceStream: TDecompressionStream;
Buffer: PChar;
Count: Integer;
Begin
//还原被压缩图像
//从被压缩的图像流中读出原始图像的尺寸
MyStream.ReadBuffer(Count, SizeOf(Count));
//根据图像尺寸大小为将要读入的原始图像流分配内存块
GetMem(Buffer, Count);
SourceStream := TDecompressionStream.Create(MyStream);
Try
//将被压缩的图像流解压缩，然后存入 Buffer内存块中
SourceStream.ReadBuffer(Buffer^, Count);
//将原始图像流保存至 DestStream流中
MyStream.Clear;
MyStream.WriteBuffer(Buffer^, Count);
//复位流指针
MyStream.Position := 0;
finally
FreeMem(Buffer);
end;
end;

就可以了。

关注

参考一下这个：　
　----在网络管理中，有时需要通过监视远程计算机屏幕来了解网
上微机的使用情况。虽然，市面上有很多软件可以实现该功能，有些
甚至可以进行远程控制，但在使用上缺乏灵活性，如无法指定远程计
算机屏幕区域的大小和位置，进而无法在一屏上同时监视多个屏幕。
其实，可以用Delphi自行编制一个灵活的远程屏幕抓取工具，简述如
下。

　　----一、软硬件要求。

　　---- Windows95/98对等网，用来监视的计算机（以下简称主控
机）和被监视的计算机（以下简称受控机）都必须装有TCP/IP协议，
并正确配置。如没有网络，也可以在一台计算机上进行调试。

　　----二、实现方法。

　　----编制两个应用程序，一个为VClient.exe，装在受控机上，
另一个为VServer.exe，装在主控机上。VServer.exe指定要监视的受
控机的IP地址和将要在受控机屏幕上抓取区域的大小和位置，并发出
屏幕抓取指令给VClient.exe，VClient.exe得到指令后，在受控机屏
幕上选取指定区域，生成数据流，将其发回主控机，并在主控机上显
示出抓取区域的BMP图象。由以上过程可以看出，该方法的关键有二
：一是如何在受控机上进行屏幕抓取，二是如何通过TCP/IP协议在两
台计算机中传输数据。

　　---- UDP(User Datagram Protocol，意为用户报文协议)是
Internet上广泛采用的通信协议之一。与TCP协议不同，它是一种非连
接的传输协议，没有确认机制，可靠性不如TCP，但它的效率却比TCP高，
用于远程屏幕监视还是比较适合的。同时，UDP控件不区分服务器端和
客户端，只区分发送端和接收端，编程上较为简单，故选用UDP协议，
使用Delphi 4.0提供的TNMUDP控件。

　　----三、创建演示程序。

　　----第一步，编制VClient.exe文件。新建Delphi工程，将默认
窗体的Name属性设为“Client”。加入TNMUDP控件，Name属性设为
“CUDP”；LocalPort属性设为“1111”，让控件CUDP监视受控机的
1111端口，当有数据发送到该口时，触发控件CUDP的OnDataReceived
事件；RemotePort属性设为“2222”，当控件CUDP发送数据时，将数
据发到主控机的2222口。

---- 在implementation后面加入变量定义

const BufSize=2048;{ 发送每一笔数据的缓冲区大小 }
var
BmpStream:TMemoryStream;
LeftSize:Longint;{ 发送每一笔数据后剩余的字节数 }

为Client的OnCreate事件添加代码：
procedure TClient.FormCreate(Sender: TObject);
begin
BmpStream:=TMemoryStream.Create;
end;

为Client的OnDestroy事件添加代码：
procedure TClient.FormDestroy(Sender: TObject);
begin
BmpStream.Free;
end;

为控件CUDP的OnDataReceived事件添加代码：
procedure TClient.CUDPDataReceived(Sender: TComponent;
NumberBytes: Integer; FromIP: String);
var
CtrlCode:array［0..29］ of char;
Buf:array［0..BufSize-1］ of char;
TmpStr:string;
SendSize,LeftPos,TopPos,RightPos,BottomPos:integer;
begin
CUDP.ReadBuffer(CtrlCode,NumberBytes);{ 读取控制码 }
if CtrlCode［0］+CtrlCode［1］+CtrlCode［2］+CtrlCode［3］
='show' then
begin { 控制码前4位为“show”表示主控机发出了抓屏指令 }
if BmpStream.Size=0 then { 没有数据可发，必须截屏生成数据 }
begin
TmpStr:=StrPas(CtrlCode);
TmpStr:=Copy(TmpStr,5,Length(TmpStr)-4);
LeftPos:=StrToInt(Copy(TmpStr,1,Pos(':',TmpStr)-1));
TmpStr:=Copy(TmpStr,Pos(':',TmpStr)+1,Length(TmpStr)
-Pos(':',TmpStr));
TopPos:=StrToInt(Copy(TmpStr,1,Pos(':',TmpStr)-1));
TmpStr:=Copy(TmpStr,Pos(':',TmpStr)+1,Length(TmpStr)-
Pos(':',TmpStr));
RightPos:=StrToInt(Copy(TmpStr,1,Pos(':',TmpStr)-1));
BottomPos:=StrToInt(Copy(TmpStr,Pos(':',TmpStr
)+1,Length(TmpStr)-Pos(':',TmpStr)));
ScreenCap(LeftPos,TopPos,RightPos,BottomPos); {
截取屏幕 }
end;
if LeftSize>BufSize then SendSize:=BufSize
else SendSize:=LeftSize;
BmpStream.ReadBuffer(Buf,SendSize);
LeftSize:=LeftSize-SendSize;
if LeftSize=0 then BmpStream.Clear;{ 清空流 }
CUDP.RemoteHost:=FromIP; { FromIP为主控机IP地址 }
CUDP.SendBuffer(Buf,SendSize); { 将数据发到主控机的2222口 }
end;
end;

其中ScreenCap是自定义函数，截取屏幕指定区域，
代码如下：
procedure TClient.ScreenCap(LeftPos,TopPos,
RightPos,BottomPos:integer);
var
RectWidth,RectHeight:integer;
SourceDC,DestDC,Bhandle:integer;
Bitmap:TBitmap;
begin
RectWidth:=RightPos-LeftPos;
RectHeight:=BottomPos-TopPos;
SourceDC:=CreateDC('DISPLAY','','',nil);
DestDC:=CreateCompatibleDC(SourceDC);
Bhandle:=CreateCompatibleBitmap(SourceDC,
RectWidth,RectHeight);
SelectObject(DestDC,Bhandle);
BitBlt(DestDC,0,0,RectWidth,RectHeight,SourceDC,
LeftPos,TopPos,SRCCOPY);
Bitmap:=TBitmap.Create;
Bitmap.Handle:=BHandle;
BitMap.SaveToStream(BmpStream);
BmpStream.Position:=0;
LeftSize:=BmpStream.Size;
Bitmap.Free;
DeleteDC(DestDC);
ReleaseDC(Bhandle,SourceDC);
end;
存为“C:VClientClnUnit.pas”和“C:VClientVClient.dpr”，
并编译。



　　----第二步，编制VServer.exe文件。新建Delphi工程，将窗体
的Name属性设为“Server”。加入TNMUDP控件，Name属性设为
“SUDP”；LocalPort属性设为“2222”，让控件SUDP监视主控机的
2222端口，当有数据发送到该口时，触发控件SUDP的OnDataReceived
事件；RemotePort属性设为“1111”，当控件SUDP发送数据时，将数
据发到受控机的1111口。加入控件Image1，Align属性设为
“alClient”；加入控件Button1，Caption属性设为“截屏”；加入
控件Label1，Caption属性设为“左：上：右：下”；加入控件Edit1，
Text属性设为“0:0:100:100”；加入控件Label2，Caption属性设为
“受控机IP地址”；加入控件Edit2，Text属性设为“127.0.0.1”；

在implementation后面加入变量定义
const BufSize=2048;
var
RsltStream,TmpStream:TMemoryStream;

为Server的OnCreate事件添加代码：
procedure TServer.FormCreate(Sender: TObject);
begin
RsltStream:=TMemoryStream.Create;
TmpStream:=TMemoryStream.Create;
end;

为Client的OnDestroy事件添加代码：
procedure TServer.FormDestroy(Sender: TObject);
begin
RsltStream.Free;
TmpStream.Free;
end;

为控件Button1的OnClick事件添加代码：
procedure TServer.Button1Click(Sender: TObject);
var ReqCode:array［0..29］ of char;ReqCodeStr:string;
begin
ReqCodeStr:='show'+Edit1.Text;
StrpCopy(ReqCode,ReqCodeStr);
TmpStream.Clear;
RsltStream.Clear;
SUDP.RemoteHost:=Edit2.Text;
SUDP.SendBuffer(ReqCode,30);
end;

为控件SUDP的OnDataReceived事件添加代码：
procedure TServer.SUDPDataReceived(Sender: TComponent;
NumberBytes: Integer; FromIP: String);
var ReqCode:array［0..29］ of char;ReqCodeStr:string;
begin
ReqCodeStr:='show'+Edit1.text;
StrpCopy(ReqCode,ReqCodeStr);
SUDP.ReadStream(TmpStream);
RsltStream.CopyFrom(TmpStream,NumberBytes);
if NumberBytes< BufSize then { 数据已读完 }
begin
RsltStream.Position:=0;
Image1.Picture.Bitmap.LoadFromStream(RsltStream);
TmpStream.Clear;
RsltStream.Clear;
end
else
begin
TmpStream.Clear;
ReqCode:='show';
SUDP.RemoteHost:=Edit2.Text;
SUDP.SendBuffer(ReqCode,30);
end;
end;

存为“C:VServerSvrUnit.pas”和 “C:VServerVServer.dpr”，并
编译。

----四、测试。

　　---- 1、本地机测试：在本地机同时运行Vserver.exe和
VClient.exe，利用程序的默认设置，即可实现截屏。查看“控制面板”
-“网络”-“TCP/IP”-“IP地址”，将程序的“客户IP地址”设为该
地址，同样正常运行。

　　---- 2、远程测试：选一台受控机，运行VClient.exe；另选一
台主控机，运行VServer.exe，将“受控机IP地址”即Edit2的内容设
为受控机的IP地址，“截屏”即可。以上简要介绍了远程屏幕抓取的
实现方法，至于在主控机上一屏同时监视多个受控机，读者可自行完
善。以上程序，在Windows98对等网、Delphi 4.0下调试通过。

--
--
　("`-''-/").___..--''"`-._
　 `6_ 6　)　 `-.　(　　 ).`-.__.`)　
　 (_Y_.)'　._　 )　`._ `. ``-..-'　
　　`--'_..-_/　/--'_.' ,'　　　　　　
(ll).-''　(((!.'　((!.-'　

※ 来源:．网易虚拟社区北京站 http://bj.netease.com．[FROM: 203.93.7.45]

给你贴一个通讯单元，很好用
// 功能模块：uSocketCommon.PAS
// 功能描述：下面是客户端和服务器端都要用到的公共单元uSocketCommon.PAS。
// 该单元是客户端应用程序和服务器端应用程序的核心部分，应用
// 程序中的常量、类型、过程、函数等都在本单元中声明。
// 程序员： Jan
// 创建日期：2002/04/27
unit uSocketCommon;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, StdCtrls, ScktComp, ComCtrls;

const
{ 下面是一组应用程序中用到的字符串常量 }
sConnectedOK = '建立连接';
sConnecting = '正在连接...';
sDisconnectedOK = '断开连接';
sSaving = '正在发送...';
sLoading = '正在接收...';
sConnectError = '连接失败！请检查相关设置';
sMessageBoxCaption = '消息';

sPercentFmt = '已经完成 %D%%'; { 用于显示数据传输完成的百分比 }

{ 下面是动词列表：
前缀是vc的动词表由客户端发出；前缀是vs的动词由服务器端发出。 }

vcNone = 8000; { 无效的动词 }
vsNone = 8000; { 无效的动词 }

vcCancel = 9001; { 取消操作 }
vsEchoCancel = 9002; { 响应取消 }
vcFail = 9003; { 操作失败 }
vsEchoFail = 9004; { 响应失败 }
vsFail = 9005; { 操作失败 }

vcSave = 1001; { 请求发送，即保存到服务器中 }
vsReadyToSave = 1002; { 接收和保存文件准备就绪 }
vcSaveInfo = 1003; { 要保存文件的信息 }
vsSaveInfoOK = 1004; { 正确收到保存文件的信息 }
vcFirstBuf = 1005; { 发送第一个包 }
vsFirstBufOK = 1006; { 正确收到第一个包 }
vcCommonBuf = 1007; { 发送中间的包 }
vsCommonBufOK = 1008; { 正确收到中间的包 }
vcLastBuf = 1009; { 发送最后一个包 }
vsSaveOK = 1010; { 正确接收完毕即保存成功 }

vcLoad = 2001; { 请求接收，即从服务器装入 }
vsReadyToLoad = 2002; { 向客户端发送文件准备就绪 }
vcLoadInfo = 2003; { 需要接收文件的信息-文件名 }
vsLoadInfoOK = 2004; { 正确收到并返回文件大小 }
vcReadyToLoad = 2005; { 接收文件准备就绪 }
vsFirstBuf = 2006; { 发送第一个包 }
vcFirstBufOK = 2007; { 正确收到第一个包 }
vsCommonBuf = 2008; { 发送中间的包 }
vcCommonBufOK = 2009; { 正确收到中间的包 }
vsLastBuf = 2010; { 发送最后一个包 }
vcLoadOK = 2011; { 正确接收完毕即接收成功 }
vsLoadOK = 2012; { 接收成功 }

ServerSocketPort = $DACB; { 端口号，可任意设置，尽可能不要与其它端口号重复 }

DataLen = 512; { 数据包的最大尺寸是0.5k字节 这个值要注意，考虑网络状况差要设得小一点，在网络状况好的环境可适当设大change by wjm 2002.07.03}
LeadLen = 20; { 引导包的固定尺寸是20字节 }
{ 引导包中包括 16 个字节的身份识别代码和 4 个字节动词代码 }
SendLen = LeadLen + DataLen; { 发送包或接收包的最到尺寸是 (4096 + 20) 字节 }

type

TDataBuf = array[0..DataLen - 1] of Char; { 数据包缓存 }
TLeadBuf = array[0..LeadLen - 1] of Char; { 引导包缓存 }
TSendBuf = array[0..SendLen - 1] of Char; { 发送包或接收包缓存 }

TFileOfChar = file of Char; { 字符文件，用于接收方保存文件 }

TSocketMode = (smSave, smLoad, smNone); { 用于表示Socket当前的状态 }

TSocketData = record { 用于保存与当前Socket相关的信息 }
OnLine: Boolean; { 连接状态 }
Mode: TSocketMode; { 工作状态 }
SrcFileName: string; { 源文件名 }
DstFileName: string; { 目标文件名 }
FS: TFileStream; { 文件流 }
FSEnabled: Boolean; { 文件流状态 }
F: TFileOfChar; { 文件 }
FEnabled: Boolean; { 文件状态 }
FileSize: Integer; { 文件尺寸 }
LeftSize: Integer; { 剩余尺寸 }
ProgressBar: TProgressBar; { 进度条 }
ALabel: TLabel; { 进度标签 }
end;

PSocketData = ^TSocketData; { 类型指针，类型为TSocketData类型 }

TSocketVerb = Integer; { 动词类型 }

{ 根据动词确定相应的文本用于登记日志 }
function VerbToString(AVerb: TSocketVerb): string;

{ 判定动词是否含有终止意图 }
function IsTerminateVerb(AVerb: TSocketVerb): Boolean;

{ 报告错误 }
procedure ShowError(AHandle: THandle; S: string);

{ 传输日志 }
procedure Log(S: string; AMemo: TMemo);

{ 重置相关数据 }
procedure ResetSocketData(var P: PSocketData);

{ 新建Socket的相关数据，返回指针 }
function NewSocketData: PSocketData;

{ 将得到的包分解成为引导包和数据包 }
procedure ExtractBuf(Buf: TSendBuf; BufSize: Integer; var LBuf: TLeadBuf; var DBuf: TDataBuf);

{ 分解引导包得到引导包中包含的动词 }
function ExtractVerb(LBuf: TLeadBuf): TSocketVerb;

{ 根据指定的动词初始化需要发送的包 }
procedure MakeVerbBuf(AVerb: TSocketVerb; var Buf: TSendBuf;
var SendSize: Integer);

{ 将数据包写入要发送的包中 }
procedure MakeSendBuf(DataBuf: TDataBuf; Count: Integer;
var SendBuf: TSendBuf; var SendSize: Integer);

{ 服务器端响应和处理客户端动词，这里的处理是服务器端程序的核心部分 }
procedure ServerEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AServerSocket: TCustomWinSocket);

{ 客户端响应和处理服务器端动词，这里的处理是客户端程序的核心部分 }
procedure ClientEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AClientSocket: TClientSocket);

implementation
uses uCFunction, uClientF;
const
IDString = 'SOCKET_TEST_DEMO'; { 引导包中的身份识别串，16个字符,可用于客户端身份验证 }
LogTimeFormat = 'YYYY-MM-DD HH:MM:SS '; { 用于登记传输日志的时间格式 }

DataSubDir = 'ReceiveData'; { 服务器端接收文件保存到应用程序所在目录的子目录Data中 }
TempSubDir = 'ReceiveData'; { 客户端接收文件保存到应用程序所在目录的子目录Temp中 }

var
DataDir: string; { 服务器端保存文件的路径 }
TempDir: string; { 客户端保存文件的路径 }

{ 判定动词是否含有终止操作的意图 }

function IsTerminateVerb(AVerb: TSocketVerb): Boolean;
begin
Result := (AVerb = vcNone) or
(AVerb = vsNone) or
(AVerb = vcCancel) or
(AVerb = vsEchoCancel) or
(AVerb = vcFail) or
(AVerb = vsEchoFail) or
(AVerb = vsFail) or
(AVerb = vsSaveOK) or
(AVerb = vcLoadOK) or
(AVerb = vsLoadOK);
end;

{ 报告错误 }

procedure ShowError(AHandle: THandle; S: string);
begin
MessageBox(AHandle, PChar(S),
sMessageBoxCaption, MB_OK + MB_ICONEXCLAMATION);
end;

{ 服务器端登记数据传输日志 }

procedure Log(S: string; AMemo: TMemo);
begin
AMemo.Lines.Append(FormatDateTime(LogTimeFormat, Now) + S);
end;

{ 重置与Socket相关的数据 }

procedure ResetSocketData(var P: PSocketData);
begin
with P^ do try
Mode := smNone;
SrcFileName := '';
DstFileName := '';
if FSEnabled then try FS.Free; except end;
FSEnabled := False;
if FEnabled then try CloseFile(F); except end;
FEnabled := False;
FileSize := 0;
LeftSize := 0;
except
end;
end;

{ 新建一个数据结构，用于存放相关Socket的有关信息 }

function NewSocketData: PSocketData;
var
P: PSocketData;
begin
New(P);
with P^ do begin
Mode := smNone;
SrcFileName := '';
DstFileName := '';
FSEnabled := False;
FEnabled := False;
FileSize := 0;
LeftSize := 0;
P^.OnLine := False;
end;
Result := P;
end;


{ 分解收到的包，得到引导包和数据包 }

procedure ExtractBuf(Buf: TSendBuf; BufSize: Integer;
var LBuf: TLeadBuf; var DBuf: TDataBuf);
var
X: Integer;
begin
for X := 0 to LeadLen - 1 do LBuf[X] := Buf[X];
for X := LeadLen to BufSize - 1 do DBuf[X - LeadLen] := Buf[X];
end;

{ 分解引导包，得到动词 }

function ExtractVerb(LBuf: TLeadBuf): TSocketVerb;
var
HeadS: string[16];
VerbS: string[4];
X: Integer;
AVerb: TSocketVerb;
begin
HeadS := '';
for X := 0 to 15 do HeadS := HeadS + LBuf[X];
VerbS := '';
for X := 16 to LeadLen - 1 do VerbS := VerbS + LBuf[X];
if HeadS = IDString then
try { 身份识别串合法时才检查动词 }
AVerb := StrToInt(VerbS);
except
AVerb := vcNone; { 解析动词失败，则认为是无效动词 }
end
else
begin
AVerb := vcNone; { 身份非法则认为是无效动词 }
end;
Result := AVerb;
end;

{ 根据动词对将发送的包进行引导包部分的初始化 }

procedure MakeVerbBuf(AVerb: TSocketVerb; var Buf: TSendBuf;
var SendSize: Integer);
var
S: string;
X: Integer;
begin
S := IDString + IntToStr(AVerb);
if Length(S) = LeadLen then begin
for X := 1 to LeadLen do
Buf[X - 1] := S[X];
end;
SendSize := LeadLen;
end;

{ 将数据包写入将发送的包 }

procedure MakeSendBuf(DataBuf: TDataBuf; Count: Integer;
var SendBuf: TSendBuf; var SendSize: Integer);
var
X: Integer;
begin
for X := 0 to Count - 1 do
SendBuf[LeadLen + X] := DataBuf[X];
SendSize := LeadLen + Count;
end;

{ 根据Socket相关的信息建立保存文件信息的数据包 }

procedure MakeSaveInfoBuf(P: PSocketData; var SendBuf: TSendBuf;
var SendSize: Integer);
var
S: string;
X, Len: Integer;
begin
MakeVerbBuf(vcSaveInfo, SendBuf, SendSize);
S := P^.SrcFileName + '|' +
P^.DstFileName + '|' +
IntToStr(P^.FileSize) + '|';
Len := Length(S);
for X := 1 to Len do
SendBuf[LeadLen + X - 1] := S[X];
SendSize := LeadLen + Len;
end;

{ 根据客户端Socket的相关信息建立下载文件信息的数据包，该包不含文件大小信息 }

procedure MakeClientLoadInfoBuf(P: PSocketData; var SendBuf: TSendBuf;
var SendSize: Integer);
var
S: string;
X, Len: Integer;
begin
MakeVerbBuf(vcLoadInfo, SendBuf, SendSize);
S := P^.SrcFileName + '|' + P^.DstFileName + '|0|';
Len := Length(S);
for X := 1 to Len do
SendBuf[LeadLen + X - 1] := S[X];
SendSize := LeadLen + Len;
end;

{ 根据服务器端Socket的相关信息建立将送出文件信息的数据包，包括文件大小信息 }

procedure MakeServerLoadInfoBuf(P: PSocketData; var SendBuf: TSendBuf;
var SendSize: Integer);
var
S: string;
X, Len: Integer;
begin
MakeVerbBuf(vsLoadInfoOK, SendBuf, SendSize);
S := P^.SrcFileName + '|' +
P^.DstFileName + '|' +
IntToStr(P^.FileSize) + '|';
Len := Length(S);
for X := 1 to Len do
SendBuf[LeadLen + X - 1] := S[X];
SendSize := LeadLen + Len;
end;

{ 分解数据包，得到将保存的文件的信息，存入向相关的Socket的数据中 }

procedure ExtractSaveInfo(DataBuf: TDataBuf; var P: PSocketData);
var
S, ASrcFileName, ADstFileName, AFileSize: string;
ASize: Integer;
begin
S := DataBuf;
try
ASrcFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
ADstFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
AFileSize := Copy(S, 1, Pos('|', S) - 1);
ASize := StrToInt(AFileSize);
P^.SrcFileName := ASrcFileName;
P^.DstFileName := ADstFileName;
P^.FileSize := ASize;
except
end;
end;

{ 分解数据包，得到将要下载的文件信息，并存入相关的Socket数据中 }

procedure ExtractLoadInfo(DataBuf: TDataBuf; var P: PSocketData);
var
S, ASrcFileName, ADstFileName, AFileSize: string;
ASize: Integer;
begin
S := DataBuf;
try
ASrcFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
ADstFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
AFileSize := Copy(S, 1, Pos('|', S) - 1);
ASize := StrToInt(AFileSize);
P^.SrcFileName := ASrcFileName;
P^.DstFileName := ADstFileName;
P^.FileSize := ASize;
except
end;
end;

{ 根据传输的相关信息更新进度显示 }

procedure UpdateProgress(P: PSocketData);
var
R: Real;
N: Integer;
begin
if P^.ProgressBar.Max <= 0 then P^.ProgressBar.Max := 1; { 防止 0 作除数 }
R := P^.ProgressBar.Position / P^.ProgressBar.Max;
R := R * 100;
N := Round(R);
P^.ALabel.Caption := Format(sPercentFmt, [N]); { 进度百分比 }
end;

{ 服务器端响应和处理客户端动词}

procedure ServerEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AServerSocket: TCustomWinSocket);
{ 参数 AVerb 是根据客户端数据包解析得到的动词；
参数 DataBuf 是得到的客户端的数据包；
参数 DL 是数据包的尺寸；
变量参数 SendBuf 用于返回响应的包；
变量参数 SendSize 用于返回响应包的尺寸；
对象参数 AServerSocket 用于表明处理当前响应的Socket。
}
var
P: PSocketData; { 用于访问Socket中的相关数据 }
ResL, L: Integer; { 局部变量 }
DBuf: TDataBuf; { 数据包 }
EchoVerb: TSocketVerb; { 响应动词 }
begin
P := AServerSocket.Data; { 指向Socket的数据 }
SendSize := 0;
if P <> nil then case AVerb of
{ 以下是异常情况下的动词响应 }
vcNone:
SendSize := 0; { 如果是无效动词，则不响应 }
vcCancel:
MakeVerbBuf(vsEchoCancel, SendBuf, SendSize); { 响应取消操作 }
vcFail:
MakeVerbBuf(vsEchoFail, SendBuf, SendSize); { 响应上传失败 }

{ 以下是服务器端接收文件时对客户端动词的响应 }
vcSave:
MakeVerbBuf(vsReadyToSave, SendBuf, SendSize); { 响应上传就绪 }
vcSaveInfo:
begin { 解析保存文件的信息，响应解析成功 }
ExtractSaveInfo(DataBuf, P);
MakeVerbBuf(vsSaveInfoOK, SendBuf, SendSize);
end;
vcFirstBuf, vcCommonBuf:
begin { 响应收到包成功 }
EchoVerb := vsFail;
if ((AVerb = vcFirstBuf) and (not P^.FEnabled)) or
((AVerb = vcCommonBuf) and (P^.FEnabled)) then
try
if AVerb = vcFirstBuf then
begin
{ 如果是第一个包则用Rewrite方式打开文件 }
P^.DstFileName := DataDir + '/' + ExtractFileName(P^.DstFileName);
AssignFile(P^.F, P^.DstFileName);
Rewrite(P^.F);
P^.FEnabled := True;
EchoVerb := vsFirstBufOK; { 响应收到第一个包 }
end
else
begin
EchoVerb := vsCommonBufOK; { 响应收到中间的包 }
end;
BlockWrite(P^.F, DataBuf, DL, ResL); { 数据写入文件 }
if ResL <> DL then EchoVerb := vsFail; { 写失败则响应失败 }
except
EchoVerb := vsFail; { 操作引发异常则响应失败 }
end;
MakeVerbBuf(EchoVerb, SendBuf, SendSize); { 构造响应包 }
end;
vcLastBuf:
begin { 收到最后一个包，成功处理后响应保存成功 }
EchoVerb := vsFail;
if P^.FEnabled then try
BlockWrite(P^.F, DataBuf, DL, ResL);
CloseFile(P^.F); { 关闭文件 }
P^.FEnabled := False;
EchoVerb := vsSaveOK;
except
EchoVerb := vsFail;
end;
MakeVerbBuf(EchoVerb, SendBuf, SendSize);
//更句用于写大文件,这步有待改进
RenameFileExtend(P^.DstFileName, 'zip');
end;
{ 以下是服务器端发送文件时对客户端动词的响应 }
vcLoad:
MakeVerbBuf(vsReadyToLoad, SendBuf, SendSize); { 向客户端发送就绪 }
vcLoadInfo:
begin { 解析文件名，创建文件流，响应文件大小 }
ExtractLoadInfo(DataBuf, P);
if FileExists(P^.SrcFileName) then try { 检查文件是否存在 }
P^.SrcFileName :=
DataDir + '/' + ExtractFileName(P^.SrcFileName);
P^.FS := TFileStream.Create(P^.SrcFileName, fmOpenRead);
P^.FSEnabled := True;
P^.FileSize := P^.FS.Size;
P^.Mode := smLoad;
P^.LeftSize := P^.FS.Size;
MakeVerbBuf(vsLoadInfoOK, SendBuf, SendSize);
MakeServerLoadInfoBuf(P, SendBuf, SendSize);
except
MakeVerbBuf(vsFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vsFail, SendBuf, SendSize);
end;
end;
vcReadyToLoad:
begin { 客户端就绪则发送第一个包 }
if P^.FSEnabled then try
case P^.LeftSize of
0: L := 0;
1..DataLen: L := P^.LeftSize;
else
L := DataLen;
end;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L; { 更新剩余的数据大小 }
MakeVerbBuf(vsFirstBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
except
MakeVerbBuf(vsFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vsFail, SendBuf, SendSize);
end;
end;
vcFirstBufOK,
vcCommonBufOK:
begin { 客户端正确收到，则继续发送剩余的包 }
if P^.FSEnabled then
try
if P^.LeftSize > DataLen then
L := DataLen
else
L := P^.LeftSize;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L;
if P^.LeftSize = 0 then
MakeVerbBuf(vsLastBuf, SendBuf, SendSize)
else
MakeVerbBuf(vsCommonBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
except
MakeVerbBuf(vsFail, SendBuf, SendSize);
end
else
begin
MakeVerbBuf(vsFail, SendBuf, SendSize);
end;
end;
vcLoadOK: MakeVerbBuf(vsLoadOK, SendBuf, SendSize); { 发送成功 }
else
SendSize := 0; { 除上述所有情况之外，则不响应 }
end;
end;

{ 客户端响应并处理服务器端的动词 }

procedure ClientEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AClientSocket: TClientSocket);
{ 参数 AVerb 是根据服务器端数据包解析得到的动词；
参数 DataBuf 是得到的服务器端的数据包；
参数 DL 是数据包的尺寸；
变量参数 SendBuf 用于返回响应的包；
变量参数 SendSize 用于返回响应包的尺寸；
对象参数 AClientSocket 用于表明处理当前响应的Socket。

考虑到下面的响应处理与服务器端的响应处理比较相似，所以注释从简。
}
var
P: PSocketData;
DBuf: TDataBuf;
ResL, L: Integer;
EchoVerb: TSocketVerb;
begin
SendSize := 0;
P := AClientSocket.Socket.Data;
if (P <> nil) and (P^.OnLine) then
case AVerb of
vsNone,
vsEchoCancel,
vsEchoFail,
vsFail:
SendSize := 0;
vsReadyToSave:
begin
P^.FS := TFileStream.Create(P^.SrcFileName, fmOpenRead);
P^.Mode := smSave;
P^.FSEnabled := True;
P^.FileSize := P^.FS.Size;
P^.LeftSize := P^.FS.Size;
P^.ProgressBar.Min := 0; { 初始化进度条数据 }
P^.ProgressBar.Max := P^.FS.Size;
P^.ProgressBar.Position := 0;
MakeSaveInfoBuf(P, SendBuf, SendSize);
end;
vsSaveInfoOK:
begin
if P^.FSEnabled then try
case P^.LeftSize of
0: L := 0;
1..DataLen: L := P^.LeftSize;
else
L := DataLen;
end;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L;
MakeVerbBuf(vcFirstBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
P^.ProgressBar.Position := P^.ProgressBar.Position + L;
UpdateProgress(P); { 更新进度显示 }
except
MakeVerbBuf(vcFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vcFail, SendBuf, SendSize);
end;
end;
vsFirstBufOK,
vsCommonBufOK:
begin
if P^.FSEnabled then
try
if P^.LeftSize > DataLen then
L := DataLen
else
L := P^.LeftSize;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L;
if P^.LeftSize = 0 then
MakeVerbBuf(vcLastBuf, SendBuf, SendSize)
else
MakeVerbBuf(vcCommonBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
P^.ProgressBar.Position := P^.ProgressBar.Position + L;
UpdateProgress(P); { 更新进度显示 }
except
MakeVerbBuf(vcFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vcFail, SendBuf, SendSize);
end;
end;
vsSaveOK:
SendSize := 0;
vsReadyToLoad:
MakeClientLoadInfoBuf(P, SendBuf, SendSize);
vsLoadInfoOK:
begin
ExtractSaveInfo(DataBuf, P);
MakeVerbBuf(vcReadyToLoad, SendBuf, SendSize);
end;
vsFirstBuf,
vsCommonBuf:
begin
if ((AVerb = vsFirstBuf) and (not P^.FEnabled)) or
((AVerb = vsCommonBuf) and (P^.FEnabled)) then
try
if AVerb = vsFirstBuf then
begin
P^.DstFileName :=
TempDir + '/' + ExtractFileName(P^.DstFileName);
AssignFile(P^.F, P^.DstFileName);
Rewrite(P^.F);
P^.FEnabled := True;
P^.ProgressBar.Min := 0;
P^.ProgressBar.Max := P^.FileSize;
P^.ProgressBar.Position := 0;
EchoVerb := vcFirstBufOK;
end
else
begin
EchoVerb := vcCommonBufOK;
end;
BlockWrite(P^.F, DataBuf, DL, ResL);
if ResL <> DL then
MakeVerbBuf(vcFail, SendBuf, SendSize)
else
MakeVerbBuf(EchoVerb, SendBuf, SendSize);
P^.ProgressBar.Position := P^.ProgressBar.Position + DL;
UpdateProgress(P);
except
MakeVerbBuf(vcFail, SendBuf, SendSize)
end
else
begin
MakeVerbBuf(vcFail, SendBuf, SendSize)
end;
end;
vsLastBuf:
begin
EchoVerb := vcFail;
if P^.FEnabled then try
BlockWrite(P^.F, DataBuf, DL, ResL);
CloseFile(P^.F);
P^.FEnabled := False;
EchoVerb := vcLoadOK;
P^.ProgressBar.Position := P^.ProgressBar.Position + DL;
UpdateProgress(P);
except
EchoVerb := vcFail;
end;
MakeVerbBuf(EchoVerb, SendBuf, SendSize)
end;
vsLoadOK:
begin
SendSize := 0;
end;
else
SendSize := 0;
end;
end;

{ 根据动词确定相应的文本用于登记日志 }

function VerbToString(AVerb: TSocketVerb): string;
var
S: string;
begin
case AVerb of
vcSave: S := '开始接收';
vcLastBuf: S := '接收成功';
vcLoad: S := '开始发送';
vcLoadOK: S := '发送成功';
vcCancel: S := '取消操作';
vcFail: S := '操作失败';
vcNone: S := '收到非法数据';
else
S := '';
end;
Result := S;
end;

initialization
{ 检查相关目录是否存在，如果不存在则建立，以防止文件操作失败。}
DataDir := ExtractFilePath(Application.ExeName) + DataSubDir;
TempDir := ExtractFilePath(Application.ExeName) + TempSubDir;
if not DirectoryExists(DataDir) then ForceDirectories(DataDir);
if not DirectoryExists(TempDir) then ForceDirectories(TempDir);

end.

UP

up

very good

服务端

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ExtDlgs,Winsock, NMSTRM, Psock, ComCtrls;

type
TForm1 = class(TForm)
Panel1: TPanel;
Edit1: TEdit;
Label1: TLabel;
Button1: TButton;
NMStrmServ1: TNMStrmServ;
NMStrm1: TNMStrm;
StatusBar1: TStatusBar;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure NMStrmServ1MSG(Sender: TComponent; const sFrom: String;
strm: TStream);
procedure NMStrm1MessageSent(Sender: TObject);
procedure NMStrm1Connect(Sender: TObject);
procedure NMStrm1Disconnect(Sender: TObject);
procedure NMStrm1HostResolved(Sender: TComponent);
procedure NMStrm1Status(Sender: TComponent; Status: String);
procedure NMStrm1PacketSent(Sender: TObject);
procedure NMStrm1InvalidHost(var Handled: Boolean);
procedure NMStrm1ConnectionFailed(Sender: TObject);
procedure NMStrmServ1ClientContact(Sender: TObject);
procedure NMStrmServ1Status(Sender: TComponent; Status: String);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}


function GetLocalIP:String;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of char;
I: Integer;
GInitData: TWSADATA;
begin
WSAStartup($101, GInitData);
try
Result:='';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^ <> nil do
begin
result:=StrPas(inet_ntoa(pptr^^));
Inc(I);
end;
finally
WSACleanup;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
edit1.Text:=GetLocalIP;
end;

procedure TForm1.NMStrmServ1MSG(Sender: TComponent; const sFrom: String;
strm: TStream);
var
myfstream:Tfilestream;
begin
myfstream:=tfilestream.Create(formatdatetime('yyyymmddhhnnss',now)+'.jpg',fmcreate);
try
myfstream.CopyFrom(strm,strm.size);
finally
myfstream.Free;
end;
end;

procedure TForm1.NMStrm1MessageSent(Sender: TObject);
begin
showmessage('stream sent');
end;

procedure TForm1.NMStrm1Connect(Sender: TObject);
begin
statusbar1.SimpleText:='已连接';
end;

procedure TForm1.NMStrm1Disconnect(Sender: TObject);
begin
if statusbar1<>nil then
statusbar1.SimpleText:='已断开';
end;

procedure TForm1.NMStrm1HostResolved(Sender: TComponent);
begin
statusbar1.SimpleText:='host resolved';
end;

procedure TForm1.NMStrm1Status(Sender: TComponent; Status: String);
begin
if statusbar1<>nil then
statusbar1.SimpleText:=status;
end;

procedure TForm1.NMStrm1PacketSent(Sender: TObject);
begin
statusbar1.SimpleText:=inttostr(nmstrm1.BytesSent)+'of'+inttostr(nmstrm1.BytesTotal)+'sent';
end;

procedure TForm1.NMStrm1InvalidHost(var Handled: Boolean);
var
tmpstr:string;
begin
if inputquery('invalid host!','specify a new host:',tmpstr) then
begin
nmstrm1.Host:=tmpstr;
handled:=true;
end;
end;

procedure TForm1.NMStrm1ConnectionFailed(Sender: TObject);
begin
showmessage('连接失败');
end;

procedure TForm1.NMStrmServ1ClientContact(Sender: TObject);
begin
nmstrmserv1.ReportLevel:=status_basic;
nmstrmserv1.TimeOut:=90000;
statusbar1.SimpleText:='客户端连接';
end;

procedure TForm1.NMStrmServ1Status(Sender: TComponent; Status: String);
begin
if statusbar1<>nil then
statusbar1.SimpleText:=status;
end;

end.

客户端

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ExtDlgs, NMSTRM, Psock, ComCtrls;

type
TForm1 = class(TForm)
Panel1: TPanel;
Edit1: TEdit;
Label1: TLabel;
Button1: TButton;
NMStrmServ1: TNMStrmServ;
NMStrm1: TNMStrm;
StatusBar1: TStatusBar;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure NMStrmServ1MSG(Sender: TComponent; const sFrom: String;
strm: TStream);
procedure NMStrm1MessageSent(Sender: TObject);
procedure NMStrm1Connect(Sender: TObject);
procedure NMStrm1Disconnect(Sender: TObject);
procedure NMStrm1HostResolved(Sender: TComponent);
procedure NMStrm1Status(Sender: TComponent; Status: String);
procedure NMStrm1PacketSent(Sender: TObject);
procedure NMStrm1InvalidHost(var Handled: Boolean);
procedure NMStrm1ConnectionFailed(Sender: TObject);
procedure NMStrmServ1ClientContact(Sender: TObject);
procedure NMStrmServ1Status(Sender: TComponent; Status: String);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
myfstream:tfilestream;
begin
if form1.OpenDialog1.Execute then
begin
form1.NMStrm1.Host:=edit1.Text;
myfstream:=tFilestream.Create(form1.OpenDialog1.FileName,fmopenread);
try
form1.NMStrm1.PostIt(myfstream);
finally
myfstream.Free;
end;
end;

end;

procedure TForm1.NMStrmServ1MSG(Sender: TComponent; const sFrom: String;
strm: TStream);
var
myfstream:Tfilestream;
begin
myfstream:=tfilestream.Create(formatdatetime('yyyymmddhhnnss',now)+'.mpg',fmcreate);

try
myfstream.CopyFrom(strm,strm.size);
finally
myfstream.Free;
end;
end;

procedure TForm1.NMStrm1MessageSent(Sender: TObject);
begin
showmessage('stream sent');
end;

procedure TForm1.NMStrm1Connect(Sender: TObject);
begin
statusbar1.SimpleText:='已连接';
end;

procedure TForm1.NMStrm1Disconnect(Sender: TObject);
begin
if statusbar1<>nil then
statusbar1.SimpleText:='已断开';
end;

procedure TForm1.NMStrm1HostResolved(Sender: TComponent);
begin
statusbar1.SimpleText:='host resolved';
end;

procedure TForm1.NMStrm1Status(Sender: TComponent; Status: String);
begin
if statusbar1<>nil then
statusbar1.SimpleText:=status;
end;

procedure TForm1.NMStrm1PacketSent(Sender: TObject);
begin
statusbar1.SimpleText:=inttostr(nmstrm1.BytesSent)+'of'+inttostr(nmstrm1.BytesTotal)+'sent';
end;

procedure TForm1.NMStrm1InvalidHost(var Handled: Boolean);
var
tmpstr:string;
begin
if inputquery('invalid host!','specify a new host:',tmpstr) then
begin
nmstrm1.Host:=tmpstr;
handled:=true;
end;
end;

procedure TForm1.NMStrm1ConnectionFailed(Sender: TObject);
begin
showmessage('连接失败');
end;

procedure TForm1.NMStrmServ1ClientContact(Sender: TObject);
begin
nmstrmserv1.ReportLevel:=status_basic;
nmstrmserv1.TimeOut:=90000;
statusbar1.SimpleText:='客户端连接';
end;

procedure TForm1.NMStrmServ1Status(Sender: TComponent; Status: String);
begin
if statusbar1<>nil then
statusbar1.SimpleText:=status;
end;

end.

多人接受答案了。