VB6 文件传输互发代码

********************版权信息********************
'*隶属工程: FileTran1
'*模块名称: frmMain
'*模块描述: 发送文件
'*成员个数: 11
'*代码行数: 101
'*声明行数: 16
'*创建时间: 2006-02-21 14:22:29(创建人:MysticBoy)
'*修改时间: 2006-02-21 14:22:29(修改人:MysticBoy)
'*代码说明: 该模块负责发送文件。
'* 您需要向窗体内添加一个名为ws的winsock控件。
'*版权说明: 版权所有(c) ?-2006 Mysticsoft.
'* 保留所有权
'***********************************************
Dim cState As String '当前状态
Dim cmd As String '传输协议的命令
Dim e As ErrObject ' 错误对象
'********************成员[Command2_Click]说明信息********************
'*代码编辑: 2006-02-21 14:49:04
'*成员类型: 对象[Command2]的[Click]事件
'*HelpCtID: 0
'*成员描述:
'*功能说明: 测试发送一个文件。
'********************************************************************
Private Sub Command2_Click()
SendFile "E:\影视&音乐\韩国辣妹4th Why\Killer(boby vox).mpg", "127.0.0.1"
'发送文件 'E:\影视&音乐\韩国辣妹4th Why\Killer(boby vox).mpg'
MsgBox "OK"
End Sub

'********************成员[SendFile]说明信息********************
'*代码编辑: 2006-02-21 14:49:04
'*成员类型: 公有方法
'*HelpCtID: 0
'*成员描述: 发送文件
'*输入参数: 参数名称 说明
'* FileName 要发送的完整文件名及其路径
'* RemoteHost 接受文件的主机
'* RemotePort [此参数可选] 接受文件的主机侦听的端口。
'*功能说明: <在此键入说明>
'**************************************************************
Public Function SendFile(FileName As String, RemoteHost As String, Optional RemotePort As Long = 1123) As Boolean
If ws.State <> 0 Then ws.Close '如果状态不为0说明正在使用,为发送当前文件,强制关闭,避免错误
ws.Connect RemoteHost, RemotePort '连接到远程主机,该主机接受文件.
DoEvents '释放CPU时间
If Waiting("ok") = False Then '等待接受机回应.如果连接,在连接事件中设置状态'ok"
SendFile = False '如果等待超时，那么返回，并退出
Exit Function
Else
'连接成功。这里您可以提示用户连接成功
End If
ws.SendData "file" '请求发送文件
DoEvents '这对于VB6来说，这是发送数据后，程序必须做的，如果不释放，真正的发送将在CPU空闲时
If Waiting("filename") = False Then '等待接受机要求文件名
SendFile = False '如果等待失败，退出
Exit Function
End If
'服务器要求文件名
''''''''
Dim Fnx() As String
Fnx = Split(FileName, "\") '按照路径分隔符，分割路径
Dim Fnam As String
Fnam = Fnx(UBound(Fnx)) '然后取数组中最后一个索引的值，该值即文件名
ws.SendData Fnam '发送文件名 。
DoEvents '这对于VB6来说，这是发送数据后，程序必须做的，如果不释放，真正的发送将在CPU空闲时
If Waiting("filedata") = False Then '等待接受机请求文件数据的命令
SendFile = False '如果等待失败，退出 。
Exit Function
End If

Dim fn As Long
Dim cFileName As String
fn = FreeFile '为打开要发送的文件准备一个有效的文件句柄
Dim bArys() As Byte '为要发送的文件准备内存。
ReDim bArys(FileLen(FileName) - 1) '按文件大小准备内存，注意：这里必须减一
Open FileName For Binary As #fn
Get #fn, , bArys '读取文件到数组中
Close #fn
ws.SendData bArys '发送该数组。
DoEvents '这对于VB6来说，这是发送数据后，程序必须做的，如果不释放，真正的发送将在CPU空闲时
cState = "sendok" '然后设置状态为发送完成。
DoEvents '释放CPU事件。以便开始发送。
Waiting "end" '等待发送结束。
End Function

'********************成员[Waiting]说明信息********************
'*代码编辑: 2006-02-21 14:49:00
'*成员类型: 公有方法
'*HelpCtID: 0
'*成员描述:
'*输入参数: 参数名称 说明
'* txt 要等待的状态文本内容。
'* tmout [此参数可选] 超时
'*功能说明: <在此键入说明>
'*************************************************************
Function Waiting(txt As String, Optional tmout As Long = 30) As Boolean
Dim sn As Single
sn = Timer
Do Until cState = txt '一直等到状态为指定字符串时退出循环
If tmout > 0 Then '如果设置的超时大于0
If Timer - sn > tmout Then '开始等待的时间到目前为止的时间长超过超时时间时
Waiting = False '等待失败。
Exit Function '退出函数
End If
End If
DoEvents '释放cpu，因为我们不能霸道 ，因为这是个多任务的平台。
Loop
Waiting = True '等待成功时返回 。
End Function


'********************成员[ws_Connect]说明信息********************
'*代码编辑: 2006-02-21 14:49:04
'*成员类型: 对象[ws]的[Connect]事件
'*HelpCtID: 0
'*成员描述: '如果连接成功设置状态为"ok"
'*功能说明: '如果连接成功设置状态为"ok"
'****************************************************************
Private Sub ws_Connect()
cState = "ok" '如果连接成功设置状态为"ok"
End Sub

'********************成员[ws_DataArrival]说明信息********************
'*代码编辑: 2006-02-21 14:49:04
'*成员类型: 对象[ws]的[DataArrival]事件
'*HelpCtID: 0
'*成员描述: 接受
'*输入参数: 参数名称 说明
'* bytesTotal 接受到的数据大小
'*功能说明:
'********************************************************************
Private Sub ws_DataArrival(ByVal bytesTotal As Long)
Dim dat As String
ws.GetData dat, , bytesTotal
cState = dat '接受到数据后立即设置状态信息。以便Waiting结束等待
End Sub

'********************成员[ws_Error]说明信息********************
'*代码编辑: 2006-02-21 14:49:04
'*成员类型: 对象[ws]的[Error]事件
'*HelpCtID: 0
'*成员描述:
'*输入参数: 参数名称 说明
'* Number '错误代码
'* Description '错误描述
'* Scode '错误的源代码标记
'* Source'错误来源
'* HelpFile'帮助文件
'* HelpContext'帮助内容
'* CancelDisplay'是否显示
'*功能说明:
'**************************************************************
Private Sub ws_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
e.Number = Number '如果发生意外错误。则结束自己或作其它处理，
e.Description = Description '这里请按照你的需要来修改
Unload Me
End Sub

'********************成员[ws_SendComplete]说明信息********************
'*代码编辑: 2006-02-21 14:49:04
'*成员类型: 对象[ws]的[SendComplete]事件
'*HelpCtID: 0
'*成员描述:
'*功能说明:
'*********************************************************************
Private Sub ws_SendComplete()
If cState = "sendok" Then '如果是数据发送完成
ws.Close '关闭连接
cState = "end" '设置状态为结束。以便sendfile函数结束。
End If
End Sub

'********************成员[ws_Close]说明信息********************
'*代码编辑: 2006-02-21 14:49:05
'*成员类型: 对象[ws]的[Close]事件
'*HelpCtID: 0
'*成员描述:
'*功能说明:
'**************************************************************
Private Sub ws_Close()
ws.Close '如果接受端断开，则关闭连接
End Sub


VB6文件接收端

'********************版权信息********************
'*隶属工程: FileTran
'*模块名称: frmMain
'*模块描述: 该模块为VB6下的文件传输的服务端
'*成员个数: 8
'*代码行数: 121
'*声明行数: 23
'*创建时间: 2006-02-21 13:43:28(创建人:MysticBoy)
'*修改时间: 2006-02-21 14:21:19(修改人:MysticBoy)
'*代码说明: 该代码无任何使用限制， 作者没有说明或暗示
'* 该代码是完全可靠的，使用该代码造成的任何
'* 损失，作者不负任和责任！
'* ***************注意******************
'* 您需要添加连个winsock控件
'* 一个命名为WS LocalPort =1123
'* 另为一个命名为fws Index=0
'*版权说明: 版权所有(c) ?-2006 Mysticsoft.
'* 保留所有权
'***********************************************
Dim n As Long
Dim nType(32767) As Long '接受步骤。
Dim ntl(32767) As Long '当前winsock接受到的文件的总字节数，
Dim FileName(32767) As String '当前索引的winsock接受的文件名称。
'********************成员[Form_Load]说明信息********************
'*代码编辑: 2006-02-21 14:04:47
'*成员类型: 对象[Form]的[Load]事件
'*HelpCtID: 0
'*成员描述: 启动时开始侦听连接
'*功能说明:无
'***************************************************************
Private Sub Form_Load()
WS.Listen
End Sub


'********************成员[fws_DataArrival]说明信息********************
'*代码编辑: 2006-02-21 14:04:47
'*成员类型: 对象[fws]的[DataArrival]事件
'*HelpCtID: 0
'*成员描述: 数据到达时发生，这里接受文件以及相关传输协议。
'*输入参数: 参数名称 说明
'* Index 该WinSock在控件数组中的索引
'* bytesTotal 当前缓冲区中接收到的数据大小
'*功能说明:
'*********************************************************************
Private Sub fws_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim cmd As String
Dim ary() As Byte
ReDim ary(bytesTotal) '按照收到的数据大小分配空间
If bytesTotal > 0 Then
Select Case nType(Index)
Case 0
fws(Index).GetData cmd, , bytesTotal
Select Case cmd
Case "file" '当到命令file时
fws(Index).SendData "filename" '发送filename索要发送的文件名称。
nType(Index) = 1 '该索引的winsock转到下一步骤。
DoEvents
End Select
Case 1 '当步骤为1时
fws(Index).GetData cmd, , bytesTotal
FileName(Index) = cmd '读取到的数据为文件名
fws(Index).SendData "filedata" '然后要求发送端发送文件数据
nType(Index) = 2 '设置当前索引的winsock到下一步
ntl(Index) = 1 '接收到的文件从1字节开始写入
Case 2
Dim fn As Long
fn = FreeFile '获取一个有效的文件句柄
fws(Index).GetData ary, maxlen:=bytesTotal '读取缓冲区
Open App.Path + "\" & FileName(Index) For Binary As #fn'文件保存在程序当前路径
Put #fn, ntl(Index), ary '打开文件在当前索引的winsock传输的位置写入收到的字节
Close #fn '关闭,等下一个数据到来时再写入.
ntl(Index) = ntl(Index) + bytesTotal '加上本次收到的内容大小.
Case Else

End Select
End If
End Sub

'********************成员[WS_ConnectionRequest]说明信息********************
'*代码编辑: 2006-02-21 14:04:47
'*成员类型: 对象[WS]的[ConnectionRequest]事件
'*HelpCtID: 0
'*成员描述:
'*输入参数: 参数名称 说明
'* requestID 请求标识
'*功能说明:
'**************************************************************************
Private Sub WS_ConnectionRequest(ByVal requestID As Long)
Dim x As Long
n = n + 1
fws(n).Accept requestID
If n = 37267 Then '如果当前使用过的连接总数超过限制
For x = 0 To 37267 '然后从中搜索有没有可用的.
If FileName(x) = "" Then '如果有文件名为空的.那么就使用它
n = x '找到后直接退出
Exit For
End If
Next
End If
Load fws(n) '加载一个对象并接受其请求'
End Sub

'********************成员[fws_Close]说明信息********************
'*代码编辑: 2006-02-21 14:04:48
'*成员类型: 对象[fws]的[Close]事件
'*HelpCtID: 0
'*成员描述:
'*输入参数: 参数名称 说明
'* Index 该WinSock在控件数组中的索引
'*功能说明:如果该一个winsock收到了服务器方面的关闭事件，关闭该
'* winsock，并清除其中的相关的信息。
'***************************************************************
Private Sub fws_Close(Index As Integer)
fws(Index).Close '接受到关闭事件后关闭该连接
Me.Caption = FileName(Index) & "接受完毕: " & Index '显示接受完成
ntl(Index) = 1 '字节位置情为1
FileName(Index) = "" '文件名置空，为以后使用作准备
nType(Index) = 0 '步骤设置为0
Unload fws(Index) '卸载当前winsock，释放其占用资源
End Sub

转载于:https://www.cnblogs.com/jamin/articles/1212021.html