VB6;VB2005 文件传输互发代码。

Visual Basic 6.0 文件发送端

'********************版权信息********************
'*隶属工程: 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(MysticBoy)
'*成员类型: 对象[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(MysticBoy)
'*成员类型: 公有方法
'*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(MysticBoy)
'*成员类型: 公有方法
'*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(MysticBoy)
'*成员类型: 对象[ws]的[Connect]事件
'*HelpCtID: 0
'*成员描述: '如果连接成功设置状态为"ok"
'*功能说明: '如果连接成功设置状态为"ok"
'****************************************************************
Private Sub ws_Connect()
cState = "ok" '如果连接成功设置状态为"ok"
End Sub

'********************成员[ws_DataArrival]说明信息********************
'*代码编辑: 2006-02-21 14:49:04(MysticBoy)
'*成员类型: 对象[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(MysticBoy)
'*成员类型: 对象[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(MysticBoy)
'*成员类型: 对象[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(MysticBoy)
'*成员类型: 对象[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(MysticBoy)
'*成员类型: 对象[Form]的[Load]事件
'*HelpCtID: 0
'*成员描述: 启动时开始侦听连接
'*功能说明:无
'***************************************************************
Private Sub Form_Load()
WS.Listen
End Sub


'********************成员[fws_DataArrival]说明信息********************
'*代码编辑: 2006-02-21 14:04:47(MysticBoy)
'*成员类型: 对象[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(MysticBoy)
'*成员类型: 对象[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(MysticBoy)
'*成员类型: 对象[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

 

VB2005中文件传输类,包括发送和接受

Imports System.IO
Imports System.Net
Imports System.Net.Sockets
Imports System.Text
Imports Microsoft.VisualBasic


''' <summary>
''' 本代码由MysticBoy 于 2006-01-26编写,2-20编写一下说明以及注释 。
''' 文件传输测试窗体,你需要添加两个按钮。不要重命名直接使用默认名称。如果需要
''' 您需要修改一下的代码。
''' </summary>
''' <remarks></remarks>
Public Class frmTran
    Dim WithEvents mtl As New FileTransmit

    ''' <summary>
    ''' 按钮1的单击时间内为启动接受
    ''' </summary>
    ''' <param name="sender"></param>
    ''' <param name="e"></param>
    ''' <remarks></remarks>
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Debug.Print(mtl.ReceiveFile(My.Application.Info.DirectoryPath)) '按钮一 ,这里准备接受文件
        '保存路径为当前程序目录
    End Sub
    ''' <summary>
    ''' 文件传输类的传输过程事件
    ''' </summary>
    ''' <param name="size">已经传输的大小</param>
    ''' <remarks></remarks>
    Private Sub mtl_Progress(ByVal size As Long) Handles mtl.Progress
        Me.Text = size '显示文件传输类的消息
        My.Application.DoEvents() '释放CPU时间
    End Sub

    ''' <summary>
    ''' 按钮二为发送一个文件。
    ''' </summary>
    ''' <param name="sender"></param>
    ''' <param name="e"></param>
    ''' <remarks></remarks>
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        MsgBox(mtl.SendFile("127.0.0.1", 1123, "E:/影视&音乐/韩国辣妹4th Why/Killer(boby vox).mpg"))
        '我们发送一个文件到 127.0.0.1 的 1123端口。
    End Sub


End Class

''' <summary>
''' 文件传输类,包括发送和接收。
''' </summary>
''' <remarks></remarks>
Class FileTransmit

    ''' <summary>
    ''' 发送文件
    ''' </summary>
    ''' <param name="RemoteHost">接受文件的主机地址</param>
    ''' <param name="RemotePort">接受文件的主机的端口</param>
    ''' <param name="FileName">要发送的文件的完整路径</param>
    ''' <param name="e">错误对象。发生错误时返回 </param>
    ''' <returns>如果发送成功返回真。</returns>
    ''' <remarks></remarks>
    Function SendFile(ByVal RemoteHost As String, ByVal RemotePort As Integer, ByVal FileName As String, Optional ByRef e As Exception = Nothing) As Boolean
        Try
            Dim client As New TcpClient(RemoteHost, RemotePort) '创建一客户端
            Dim stream As NetworkStream = client.GetStream() '获取流
            Dim data As Byte() = System.Text.Encoding.Default.GetBytes("file") '编码发送握手协议的命令通知主机接受文件
            stream.Write(data, 0, data.Length) '发送
            Dim cmd As String
            data = New Byte(10) {} '数组重新定义
            Dim bytes As Integer = stream.Read(data, 0, data.Length) '读取回应信息。等待。。。。
            cmd = System.Text.Encoding.Default.GetString(data, 0, bytes) '读取完后解码回应信息。
            If cmd = "filename" Then '如果服务器索要文件名。
                data = System.Text.Encoding.Default.GetBytes(My.Computer.FileSystem.GetFileInfo(FileName).Name)
                '编码文件名。不给路径。如:c:/111/333/222.txt 给出 222.txt
                stream.Write(data, 0, data.Length) '发送文件名
            Else '如果不是约定请求。返回。说明协议不正确。
                Return False
            End If
            data = New Byte(10) {} '数组重新定义
            bytes = stream.Read(data, 0, data.Length) '读取数据
            cmd = System.Text.Encoding.Default.GetString(data, 0, bytes) '解码响应信息
            If cmd = "filedata" Then '如果服务器要求文件数据。
                data = My.Computer.FileSystem.ReadAllBytes(FileName) '读取文件内容。
                stream.Write(data, 0, data.Length) '写入流。 发送。
            Else
                Return False  '协议不正确
            End If
            client.Close() '关闭
            Return True '成功。返回真
        Catch ex As Exception
            e = ex '返回错误信息
            Return False
        End Try
    End Function

 


    ''' <summary>
    ''' 接受过程,在该事件中您可以编写反映接受情况的代码
    ''' </summary>
    ''' <param name="size">已经接受了的文件大小。</param>
    ''' <remarks></remarks>
    Public Event Progress(ByVal size As Long)

    ''' <summary>
    ''' 接受文件
    ''' </summary>
    ''' <param name="Path">文件保存路径。</param>
    ''' <param name="LocalIPAddress">本机IP地址,在。NET中似乎是必须的。</param>
    ''' <param name="LocalPort">侦听端口</param>
    ''' <param name="Rename">如果文件存在是不是需要重名名原有文件</param>
    ''' <param name="e">异常对象,如果有错误可以使用该异常对象返回</param>
    ''' <returns>如果成功接受返回真</returns>
    ''' <remarks></remarks>
    Public Function ReceiveFile( _
                                 ByVal Path As String, _
                                 Optional ByVal LocalIPAddress As String = "127.0.0.1", _
                                 Optional ByVal LocalPort As Integer = 1123, _
                                 Optional ByVal Rename As Boolean = True, _
                                 Optional ByRef e As Exception = Nothing) As String
        Dim nType As Integer
        Dim FileName As String = Nothing
        Dim client As TcpClient
        Dim server As TcpListener
        server = Nothing
        Path = IIf(Right(Path, 1) = "/", Left(Path, Path.Length - 1), Path) '计算路径,防止多余的斜杠
        '如果路径后面带有"/",取出,以下文件路径计算中,包含了"/"
        Try
            Dim localAddr As IPAddress = IPAddress.Parse(LocalIPAddress) '指定本机IP地址
            '不支持DNS,仅支持字符串,ipv4使用点分隔ipv6使用冒号16进制
            server = New TcpListener(localAddr, LocalPort) '创建一个侦听对象
            server.Start() '启动侦听
            Dim bytes(65535) As Byte '接受缓冲大小65535字节,VB6中的winsock为 8191。同等环境传输速度不取决缓冲区大小
            Dim data As String = Nothing
            While True
                '如果有必要呢,你可以使用线程池来实现多个连接同步等待。
                '这需要把While中的代码放在一个sub 中,相关线程池的操作请参考MSDN
                '建议:最好使用线程池 ,至少我认为线程池是最好管理的。
                client = server.AcceptTcpClient() '等待客户连接
                data = Nothing
                Dim stream As NetworkStream = client.GetStream() '接通后获取数据流
                Dim i As Integer
                i = stream.Read(bytes, 0, bytes.Length) '读取到缓冲区,i返回读取的字节数目
                While i <> 0 '如果读取到的数据大小为0就退出循环
                    Dim cmd As String
                    If bytes.Length > 0 Then
                        Select Case nType
                            Case 0
                                cmd = System.Text.Encoding.Default.GetString(bytes, 0, i) '编码数据
                                '把接受到的数据编码为本机可识别字符。该方法有效支持本机区域设置。
                                Select Case cmd '为扩展此函数,这里使用select语句。
                                    Case "file" '如果接受到的命令是file .说明客户请求发送文件 。
                                        Dim msg As Byte() = System.Text.Encoding.ASCII.GetBytes("filename")
                                        stream.Write(msg, 0, msg.Length) '此时,向客户询问文件名。以便确认是什么文件
                                        nType = 1 '设置下一个操作类型为1,既取得文件名称
                                End Select
                            Case 1
                                FileName = System.Text.Encoding.Default.GetString(bytes, 0, i)
                                '把接受到的数据编码为本机可识别字符。该方法有效支持本机区域设置。
                                If My.Computer.FileSystem.FileExists(Path & "/" & FileName) = True Then
                                    If Rename = True Then '如果重命名为真,则在名字空间前加"renamed_"
                                        Try
                                            ' 对于重名名,可能这个方法并不是最好的,建议你写一个算法。或者干脆让用户来决定保存为什么文件。
                                            My.Computer.FileSystem.RenameFile(Path & "/" & FileName, "renamed_" & Now.Ticks & "_" & FileName)
                                        Catch ex As Exception
                                            e = ex
                                            Return Nothing '如果无法重命名。返回
                                        End Try

                                    Else '如果用户不重命名,则尝试删除。如果删除不成功。返回
                                        Try '如果该文件已存在,则删除该文件。
                                            My.Computer.FileSystem.GetFileInfo(Path & "/" & FileName).Delete()
                                        Catch ex As Exception
                                            e = ex '如果文件无法删除,返回
                                            Return Nothing
                                        End Try
                                    End If
                                End If
                                Dim msg As Byte() = System.Text.Encoding.ASCII.GetBytes("filedata")
                                '按照编译字符为数组
                                stream.Write(msg, 0, msg.Length) '写入流。同vb6中的 ws.senddata :doevents
                                nType = 2 '操作类型为2时,收到的数组写入文件中。
                            Case 2
                                ReDim Preserve bytes(i - 1) '定义i个字节,0到(i-1)为i个 
                                '使用重定义保留值缩小数组             
                                My.Computer.FileSystem.WriteAllBytes(Path & "/" & FileName, _
                                                                    bytes, True) '写入到文件中
                                RaiseEvent Progress(My.Computer.FileSystem.GetFileInfo _
                                                   (Path & "/" & FileName).Length)
                                '接受过程
                        End Select
                    End If
                    ReDim bytes(65535) '重定义,清除旧数据。该操作建议.
                    Try
                        i = stream.Read(bytes, 0, bytes.Length) '从缓冲区中读取数据
                    Catch ex As Exception
                        e = ex
                        Return Nothing
                    End Try

                End While
                nType = 0 '操作类型设置为空
                client.Close() '关闭客户端
                Exit While '退出无限制的等待
            End While
        Catch ex As SocketException
            e = ex
            Return Nothing
        Finally
            server.Stop() '服务停止
        End Try
        Return Path & "/" & FileName '返回文件具体路径,来表示文件接受成功。
    End Function

End Class

评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值