为了设计统一和用户操作方便，我们希望将服务端与客户端融合在一起，形成一个程序，这样用户理解起来，更加直观一点（其实这样做也是为了方便调试，大家可以在本机上测试，自己传文件给自己）。所以，我们在程序中需要使用两个 Winsock 控件，一个负责监听，一个负责发送，当发送端连接成功以后，便选择一个待发送的文件（可以是任意二进制文件），接着将文件名和文件字节长度发送给接收端，接收端收到这个消息以后，将文件名和文件长度解析出来，然后通知发送端可以开始发送文件；发送端读到这个消息之后，将文件流以字节的形式发送到接收端，接收端收到后，将二进制流回写，保存成文件即可。这里要注意两点，一个是由于 Winsock 每次最大传输 8K 的内容，所以需要将文件分解，每次传输固定数目的字节流，这样发送和接收时都可以根据这个数目来判断文件传输的进程，一旦字节流数目等于文件的大小，就需要关闭相应的文件句柄；另一点是由于我只使用一个 Winsock 控件接收，接收文本时需要注意要将 UNICODE 转码，解析成可识别的信息。
源代码
' 下面的代码既是服务器又是客户端
' 采用应答式发送方式
' 自动拆分文件，包括 2 进制
Option Explicit
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim mybyte() As Byte ' 发送方数组
Const filecomesMSG = "a file is coming " ' 有文件到来
Const RemoteIsReadyMSG = "sender is ready " ' 准备好了
Const FileisOverMSG = "the file is ended" ' 文件完毕
Const RemoteDenyMSG = "the user canceled" ' 用户取消
Const filecountMSG = "the file lengh is" ' 文件长度
Const RecevieIsReadyMSG = "Receiver is ready " ' 准备接收
Dim arrdata() As Byte ' 收到的信息
Dim filesave As Integer ' 保存文件的句柄
Dim filehandle As Integer ' 发送方文件的句柄
Dim FileSize As Double ' 文件的大小
Dim Sendbyte As Long
Dim Receivebyte As Long
Dim MyLocation As Double
Dim myMSG As String ' 消息
Dim FileisOver As Boolean ' 文件是否已经完毕
Const ReceivePort = 7905
Const BUFFER_SIZE = 5734
Private Sub cmdConnect_Click()
Timer2.Enabled = True
End Sub
Private Sub cmdsend_Click()
On Error GoTo errorhandle
With CommonDialog1
.CancelError = True
.DialogTitle = " 选择您要传送的文件 "
.Filter = "All Files (.)|."
.ShowOpen
End With
filehandle = FreeFile
Open CommonDialog1.FileName For Binary Access Read As #filehandle
cmdSend.Enabled = False
FileSize = CDbl(FileLen(CommonDialog1.FileName))
Label1.Caption = " 等待回应 >>>"
MsgBox (" 选择的文件大小为 " & LOF(filehandle) & " 字节 ")
If WinsockSend.State = sckConnected Then
WinsockSend.SendData filecomesMSG & CommonDialog1.FileName ' 发送发出文件信息
End If
Exit Sub
errorhandle:
cmdSend.Enabled = True
MsgBox (" 你没有选择一个文件！ ")
End Sub
Private Sub Form_Load()
WinsockReceive.LocalPort = ReceivePort
WinsockReceive.Listen
FileisOver = True
Label1.Caption = " 准备传输 >>>"
End Sub
Public Function SendChunk()
Dim mybytesize As Long
If WinsockSend.State <> sckConnected Then Exit Function
mybytesize = BUFFER_SIZE
If LOF(filehandle) - Loc(filehandle) < BUFFER_SIZE Then mybytesize = (LOF(filehandle) - Loc(filehandle))
ReDim mybyte(0 To mybytesize - 1)
Get #filehandle, , mybyte
WinsockSend.SendData mybyte
Sendbyte = Sendbyte + mybytesize
ProgressBar1.Value = Int((100 / FileSize) * Sendbyte)
If Sendbyte >= FileSize Then
FileisOver = True
WinsockSend.SendData FileisOverMSG
End If
End Function
Private Sub Timer2_Timer()
If WinsockSend.State = sckConnected Then
Timer2.Enabled = False
cmdConnect.Enabled = False
ElseIf WinsockSend.State <> 1 And WinsockSend.State <> 6 And WinsockSend.State <> 7 And WinsockSend.State <> 8 And WinsockSend.State <> 9 Then
WinsockSend.Connect txtHost.Text, ReceivePort
ElseIf WinsockSend.State = 8 Or WinsockSend.State = 9 Then
WinsockSend.Close
End If
End Sub
Private Sub WinsockReceive_ConnectionRequest(ByVal requestID As Long)
If WinsockReceive.State <> sckClosed Then WinsockReceive.Close
WinsockReceive.Accept requestID
End Sub
Private Sub WinsockReceive_DataArrival(ByVal bytesTotal As Long)
ReDim arrdata(0 To bytesTotal - 1)
WinsockReceive.GetData arrdata, vbByte + vbArray
myMSG = StrConv(arrdata, vbUnicode) ' 二进制转为字符串
Select Case Mid(myMSG, 1, 17)
Case filecomesMSG ' 这些消息发送方和接受方都可收到
' 显示保存对话框
On Error GoTo errorhandle
CommonDialog1.FileName = Mid(myMSG, 17, Len(myMSG))
CommonDialog1.DialogTitle = " 选择保存文件的路径 "
CommonDialog1.ShowSave
filesave = FreeFile
Receivebyte = 0
cmdSend.Enabled = False
WinsockReceive.SendData RecevieIsReadyMSG
Case FileisOverMSG
Close #filesave
MsgBox (" 文件传输成功！ ") ' 大家一起处理
cmdConnect.Enabled = True
cmdSend.Enabled = True
Label1.Caption = " 准备传输 >>>"
ProgressBar1.Value = 0
WinsockReceive.SendData FileisOverMSG
WinsockReceive.Close
WinsockReceive.Listen
Case filecountMSG
FileSize = Mid(myMSG, 18, Len(myMSG))
Open CommonDialog1.FileName For Binary Access Write As #filesave
WinsockReceive.SendData RemoteIsReadyMSG
Label1.Caption = " 文件准备传输！ "
FileisOver = False
Case Else
If Receivebyte < FileSize Then
Receivebyte = Receivebyte + bytesTotal
Put #filesave, , arrdata
WinsockReceive.SendData RemoteIsReadyMSG
ProgressBar1.Value = Int((100 / FileSize) * Receivebyte)
End If
End Select
Exit Sub
errorhandle:
WinsockReceive.SendData RemoteDenyMSG
cmdConnect.Enabled = True
End Sub
Private Sub WinsockSend_DataArrival(ByVal bytesTotal As Long)
WinsockSend.GetData myMSG
Select Case myMSG
Case RecevieIsReadyMSG
WinsockSend.SendData filecountMSG & FileSize
FileisOver = False
Sendbyte = 0
Case RemoteIsReadyMSG
' 如果文件还没有结束，继续传输
If Not FileisOver Then
Label1.Caption = " 文件正在被传输 >>>"
SendChunk
Else
WinsockSend.SendData FileisOverMSG
End If
Case FileisOverMSG
' 主机处理
Close #filehandle
MsgBox (" 文件传输成功！ ") ' 大家一起处理
WinsockSend.SendData FileisOverMSG
WinsockSend.Close
cmdConnect.Enabled = True
ProgressBar1.Value = 0
cmdSend.Enabled = True
Label1.Caption = " 准备传输 >>>"
Case RemoteDenyMSG
MsgBox (" 用户终止了传输！ ")
cmdSend.Enabled = True
Label1.Caption = " 准备传输 >>>"
Close #filehandle
End Select
Exit Sub
End Sub
本程序在 WinXPSP1+VB6 和 Win2000SP4+VB6 下面调试成功。