能传TXT,bat文件,不能传EXE,压缩文件,还有WORD文档,可能还有很多不能传送的文件,不知道这是为什么?程序如下:服务端程序:
Dim dstpath As String '目标路径
Dim bytesrec As Long '文件字节数
Dim fl As Integer '文件句柄Private Sub Form_Load()
'初始化设置
wskServer(0).Protocol = sckTCPProtocol
wskServer(0).LocalPort = 1001
wskServer(0).Listen
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'在关闭前删除所有的winsock控件
For cn = 0 To wskServer.Count - 1
wskServer(cn).Close
Next
End SubPrivate Sub wskServer_Close(Index As Integer)
'第index个winsock控件关闭时显示相应的消息
lblInfo.Caption = "connection close..."
End Sub
'动态增加winsock控件数组的大小
Private Sub wskServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Load wskServer(Index + 1)
wskServer(Index + 1).Accept requestID
lblInfo.Caption = "connetction estabilished.."
End SubPrivate Sub wskServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim recbuffer As String
Dim ret As Integer
On Error GoTo glocal
wskServer(Index).GetData recbuffer
Select Case Left(recbuffer, 8)
Case "msg_eof_" '信息结束
Close #fl '关闭文件
lblInfo.Caption = "file received.."
Case "msg_dst_" '目标路径
dstpath = Right(recbuffer, Len(recbuffer) - 8)
fl = FreeFile '新建文件句柄
'overwrite file
On Error Resume Next
If Len(Dir(dstpath)) > 0 Then
'询问是否覆盖
ret = MsgBox("file already exist!" & vbCrLf & "you wont overwrite it??", vbQuestion + vbYesNo, "tftserver message")
If ret = vbYes Then
Kill dstpath
Else
Unload Me
End If
End If
'打开文件
Open dstpath For Binary As #fl
'显示路径
lbFileReceived.Caption = dstpath
'返回客户端 信息ok
wskServer(Index).SendData "msg_oks"
Case Else
bytesrec = bytesrec + Len(recbuffer)
'写入
Put #fl, , recbuffer
lbBytesReceived.Caption = "bytes received:" & bytesrec
'继续
wskServer(Index).SendData "msg_rec"
End Select
Exit Sub
glocal:
MsgBox Err.Description
Unload Me
End SubPrivate Sub wskServer_Error(Index As Integer, 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)
If Number <> 0 Then
MsgBox Number
End Sub客户端程序:
Dim srcpath As String '源路径
Dim dstpath As String '目标路径
Dim isreceived As Boolean '接受完毕为TRUE
Private Sub Text1_Change()
dstpath = Text1.Text
End SubPrivate Sub wskclient_Close()
lblInfo.Caption = "not connected.."
wskclient.Close
End SubPrivate Sub wskclient_Connect()
lblInfo.Caption = "i'm connected"
End SubPrivate Sub wskclient_DataArrival(ByVal bytesTotal As Long)
Dim recbuffer As String
wskclient.GetData recbuffer
Select Case Left(recbuffer, 7)
Case "msg_rec" 'Block Received
isreceived = True
Case "msg_oks" 'ok you can begin to send file
sendfile
End Select
End SubPrivate Sub wskclient_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)
If Number <> 0 Then
lblInfo.Caption = "not connected"
End Sub
'sendfile函数用于分块发送文件
Private Sub sendfile()
Dim buffile As String '文件内容
Dim lnfile As Long '长度
Dim nloop As Long '文件内容分的块数
Dim nremain As Long '最后剩下的大小
Dim cn As Long
On Error GoTo glocal:
lnfile = FileLen(srcpath)
If lnfile > 8192 Then
'如果文件大于8K
'则分块传输
nloop = Fix(lnfile / 8192)
nremain = lnfile Mod 8192
Else
nloop = 0
nremain = lnfile
End If
If lnfile = 0 Then
'文件大小为0
MsgBox "invalid source file", vbCritical, "client message"
Exit Sub
End If
Open srcpath For Binary As #1
'打开源文件
If nloop > 0 Then
For cn = 1 To nloop
buffile = String(8192, " ")
Get #1, , buffile '获取文件内容
'发送文件块内容
wskclient.SendData buffile
isreceived = False
lbbytesend.Caption = "Bytes Sent:" & cn * 8192 & "of" & lnfile
lbbytesend.Refresh
While isreceived = False
DoEvents
Wend
Next
' 传输剩下的
If nremain > 0 Then
buffile = String(nremain, " ")
Get #1, , buffile
wskclient.SendData buffile
isreceived = False
lbbytesend.Caption = "Bytes Sent:" & lnfile & "of" & lnfile
lbbytesend.Refresh
While isreceived = False
DoEvents
Wend
End If
Else
buffile = String(nremain, " ")
Get #1, , buffile
wskclient.SendData buffile
isreceived = False
While isreceived = False
DoEvents
Wend
End If
'发送结束符号
wskclient.SendData "msg_eof_" 'end of file tag
'关闭文件
Close #1
Exit Subglocal:
MsgBox Err.DescriptionEnd Sub
Private Sub Command2_Click()
'发送文件
On Error GoTo glocal
If srcpath = "" Then
MsgBox "select file to transfer", vbInformation, "TFTPClient Message"
Exit Sub
End If
lbfilesend.Caption = srcpath
'send to server the remote path
wskclient.SendData "msg_dst_" & dstpath
Exit Sub
glocal:
MsgBox Err.Description
Resume Next
End Sub
Private Sub Command1_Click()
'连接服务器
On Error Resume Next
wskclient.Connect "10.1.19.225", 1001
If Err <> 0 Then
wskclient.Close
End If
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
'驱动器变化
Private Sub Drive1_Change()
Dir1.Path = Left(Drive1.Drive, 2) & "\"
End Sub
'文件点击
Private Sub file1_click()
srcpath = File1.Path
If Right(srcpath, 1) <> "\" Then
srcpath = srcpath & "\"
End If
srcpath = srcpath & File1.FileName
lbfilesend.Caption = srcpath
End Sub
小弟刚学,请帮忙指点下,谢谢!
Dim dstpath As String '目标路径
Dim bytesrec As Long '文件字节数
Dim fl As Integer '文件句柄Private Sub Form_Load()
'初始化设置
wskServer(0).Protocol = sckTCPProtocol
wskServer(0).LocalPort = 1001
wskServer(0).Listen
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'在关闭前删除所有的winsock控件
For cn = 0 To wskServer.Count - 1
wskServer(cn).Close
Next
End SubPrivate Sub wskServer_Close(Index As Integer)
'第index个winsock控件关闭时显示相应的消息
lblInfo.Caption = "connection close..."
End Sub
'动态增加winsock控件数组的大小
Private Sub wskServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Load wskServer(Index + 1)
wskServer(Index + 1).Accept requestID
lblInfo.Caption = "connetction estabilished.."
End SubPrivate Sub wskServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim recbuffer As String
Dim ret As Integer
On Error GoTo glocal
wskServer(Index).GetData recbuffer
Select Case Left(recbuffer, 8)
Case "msg_eof_" '信息结束
Close #fl '关闭文件
lblInfo.Caption = "file received.."
Case "msg_dst_" '目标路径
dstpath = Right(recbuffer, Len(recbuffer) - 8)
fl = FreeFile '新建文件句柄
'overwrite file
On Error Resume Next
If Len(Dir(dstpath)) > 0 Then
'询问是否覆盖
ret = MsgBox("file already exist!" & vbCrLf & "you wont overwrite it??", vbQuestion + vbYesNo, "tftserver message")
If ret = vbYes Then
Kill dstpath
Else
Unload Me
End If
End If
'打开文件
Open dstpath For Binary As #fl
'显示路径
lbFileReceived.Caption = dstpath
'返回客户端 信息ok
wskServer(Index).SendData "msg_oks"
Case Else
bytesrec = bytesrec + Len(recbuffer)
'写入
Put #fl, , recbuffer
lbBytesReceived.Caption = "bytes received:" & bytesrec
'继续
wskServer(Index).SendData "msg_rec"
End Select
Exit Sub
glocal:
MsgBox Err.Description
Unload Me
End SubPrivate Sub wskServer_Error(Index As Integer, 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)
If Number <> 0 Then
MsgBox Number
End Sub客户端程序:
Dim srcpath As String '源路径
Dim dstpath As String '目标路径
Dim isreceived As Boolean '接受完毕为TRUE
Private Sub Text1_Change()
dstpath = Text1.Text
End SubPrivate Sub wskclient_Close()
lblInfo.Caption = "not connected.."
wskclient.Close
End SubPrivate Sub wskclient_Connect()
lblInfo.Caption = "i'm connected"
End SubPrivate Sub wskclient_DataArrival(ByVal bytesTotal As Long)
Dim recbuffer As String
wskclient.GetData recbuffer
Select Case Left(recbuffer, 7)
Case "msg_rec" 'Block Received
isreceived = True
Case "msg_oks" 'ok you can begin to send file
sendfile
End Select
End SubPrivate Sub wskclient_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)
If Number <> 0 Then
lblInfo.Caption = "not connected"
End Sub
'sendfile函数用于分块发送文件
Private Sub sendfile()
Dim buffile As String '文件内容
Dim lnfile As Long '长度
Dim nloop As Long '文件内容分的块数
Dim nremain As Long '最后剩下的大小
Dim cn As Long
On Error GoTo glocal:
lnfile = FileLen(srcpath)
If lnfile > 8192 Then
'如果文件大于8K
'则分块传输
nloop = Fix(lnfile / 8192)
nremain = lnfile Mod 8192
Else
nloop = 0
nremain = lnfile
End If
If lnfile = 0 Then
'文件大小为0
MsgBox "invalid source file", vbCritical, "client message"
Exit Sub
End If
Open srcpath For Binary As #1
'打开源文件
If nloop > 0 Then
For cn = 1 To nloop
buffile = String(8192, " ")
Get #1, , buffile '获取文件内容
'发送文件块内容
wskclient.SendData buffile
isreceived = False
lbbytesend.Caption = "Bytes Sent:" & cn * 8192 & "of" & lnfile
lbbytesend.Refresh
While isreceived = False
DoEvents
Wend
Next
' 传输剩下的
If nremain > 0 Then
buffile = String(nremain, " ")
Get #1, , buffile
wskclient.SendData buffile
isreceived = False
lbbytesend.Caption = "Bytes Sent:" & lnfile & "of" & lnfile
lbbytesend.Refresh
While isreceived = False
DoEvents
Wend
End If
Else
buffile = String(nremain, " ")
Get #1, , buffile
wskclient.SendData buffile
isreceived = False
While isreceived = False
DoEvents
Wend
End If
'发送结束符号
wskclient.SendData "msg_eof_" 'end of file tag
'关闭文件
Close #1
Exit Subglocal:
MsgBox Err.DescriptionEnd Sub
Private Sub Command2_Click()
'发送文件
On Error GoTo glocal
If srcpath = "" Then
MsgBox "select file to transfer", vbInformation, "TFTPClient Message"
Exit Sub
End If
lbfilesend.Caption = srcpath
'send to server the remote path
wskclient.SendData "msg_dst_" & dstpath
Exit Sub
glocal:
MsgBox Err.Description
Resume Next
End Sub
Private Sub Command1_Click()
'连接服务器
On Error Resume Next
wskclient.Connect "10.1.19.225", 1001
If Err <> 0 Then
wskclient.Close
End If
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
'驱动器变化
Private Sub Drive1_Change()
Dir1.Path = Left(Drive1.Drive, 2) & "\"
End Sub
'文件点击
Private Sub file1_click()
srcpath = File1.Path
If Right(srcpath, 1) <> "\" Then
srcpath = srcpath & "\"
End If
srcpath = srcpath & File1.FileName
lbfilesend.Caption = srcpath
End Sub
小弟刚学,请帮忙指点下,谢谢!
我初步瞄了一下,发现你打开文件用binary,然后存放的buff用的是string,相当的有问题.
建议你把buff改成byte数组试看看