Private Sub sckFser_ConnectionRequest(ByVal requestID As Long)
' Text1 = requestID
'On Error GoTo IDERROR If sckFser.State <> sckClosed Then sckFser.Close sckFser.Accept requestID
'IDERROR: 'MsgBox Err.Description, vbCritical
End Sub
Private Sub sckFser_DataArrival(ByVal bytesTotal As Long) Dim strData As String Dim sData As String Dim lRet As Long Dim DataByte() As Byte Dim SendFileLen
sckFser.GetData DataByte
strData = StrConv(DataByte, vbUnicode) MsgBox ""
If Is_FILESEND = True Then 'Is_FILESEND是个全局变量 Put #myFreeFile, , DataByte SendFileLen = SendFileLen - UBound(DataByte) - 1
If SendFileLen <= 0 Then Close #myFreeFile myFreeFile = 0 Is_FILESEND = False End If Else Text1.Text = strData If InStr(1, strData, "|FILESEND|") <> 0 Then
Dim sFileName As String Dim k As Integer Is_FILESEND = True k = InStr(11, strData, "|") sFileName = Mid$(strData, 11, k - 11)
myFreeFile = FreeFile Open sFileName For Binary As myFreeFile
End If
'......... '其他程序
End If End Sub
这是客户端的发送代码，部分（它这个太复杂了，谁有服务器，传到服务器上去就好了） Sub SendFileToServer(xFileName As String, destination As String) Dim Buffer As String Dim BufferSize As Integer Dim Fiz As File Dim pinche As ListItem Dim FizObj As Scripting.FileSystemObject Dim fileLength As Long, SuperBuffer As Long Dim PercentDone As Long, b As Integer
Set FizObj = CreateObject("Scripting.FileSystemObject") Set Fiz = FizObj.GetFile(xFileName)
BufferSize = 2048
i = FreeFile 'Find free file Open xFileName For Binary Access Read As #i 'open the file to read Debug.Print "--------Opening " + xFileName fileLength = LOF(i)
If LOF(i) <> 0 Then Do While StartSending <> True: DoEvents If CancelUpload = True Then Exit Sub Loop
Do While Not EOF(i): DoEvents If CancelUpload = True Then Exit Sub If fileLength - Loc(i) < BufferSize Then Let BufferSize = fileLength - Loc(i) If BufferSize = 0 Then GoTo done End If
Buffer = Space(BufferSize)
Get #i, , Buffer If Loc(i) > 3536851 Then Debug.Print Loc(i) End If WaitForServerRecieve = True frmUpload.Winsock.SendData Buffer Do While WaitForServerRecieve = True: DoEvents If CancelUpload = True Then Exit Sub Loop 'wait for server to recieve packet
frmUpload.BytesSent = FormatFileSize(SuperBuffer) + " of " + FormatFileSize(fileLength) + " sent" If SuperBuffer = 0 Then GoTo skipPercent 'Don't want division by zero
PercentDone = SuperBuffer / fileLength * 100 On Error Resume Next frmUpload.Progress.Value = PercentDone On Error GoTo 0 DoEvents skipPercent:
Loop End If done: Close #i Debug.Print "--------Closing " + xFileName
StartSending = False End Sub
这是服务器端主要的接收代码！ Private Sub UP_DataArrival(Index As Integer, ByVal bytesTotal As Long) Dim data As String, FileSize As Long, Percent As Long
'On Error GoTo ErrorHandle
Call UP(Index).GetData(data, , bytesTotal)
If Left(data, 5) = "FILE=" Then 'Received file upload confirmation from 'client... separate data, and set variables
' temp$ = Right(Data, Len(Data) - 5) ' slash = FindReverse(temp$, "\") ' ParentFolder$ = Left(temp$, slash) ' 'Debug.Print Data ' If Exists(ParentFolder$) = False Then ' MkDir (ParentFolder$) ' End If
Dim folders2create As New Collection Dim objFso As New FileSystemObject data = Right(data, Len(data) - 5)
FileTransferAdd fileName, FileSize1, UP(Index).RemoteHostIP, "" 'Add item to list for file transfers
pf = objFso.GetParentFolderName(fileName) Do While pf <> "": DoEvents If objFso.FolderExists(pf) = False Then folders2create.Add pf End If pf = objFso.GetParentFolderName(pf) Loop
'Create folders (if needed) On Error Resume Next For X = folders2create.Count To 1 Step -1 MkDir folders2create.Item(X) Next X
Set folders2create = Nothing 'Delete the file If Exists(fileName) Then Kill fileName
'Open the file so that packets received can be directly 'written to the already open disk file fileNum = FreeFile() i = FreeFile Open fileName For Binary Access Write As #fileNum
If FileSize1 = 0 Then 'If the file size is 0 bytes, just close the file 'and tell the client it's done receiving the file Close #fileNum Call frmMain.UP(Index).SendData("FILEDONE") sOutput "Received '" & fileName & "' (" & FileSize1 & " bytes) from IP '" & UP(Index).RemoteHostIP & "'" Exit Sub End If
'Inform the client that it can start sending 'data packets (the default is 2048 bytes) Call frmMain.UP(Index).SendData("BEGIN") Exit Sub End If
'Inform the client that the packet was received sucessfully Put #fileNum, , data DoEvents Debug.Print LOF(fileNum) frmMain.UP(Index).SendData ("OK")
'Write the incoming data directly to the disk file
'If the size of the disk file matches the size as told 'by the client, we are done receiving this file, so 'close it and inform the client that the file was 'received successfully If LOF(fileNum) = FileSize1 Then Close #fileNum Debug.Print "Closed file#: " & fileNum & " UP" Call frmMain.UP(Index).SendData("FILEDONE") sOutput "Received '" & fileName & "' (" & FileSize1 & " bytes) from IP '" & UP(Index).RemoteHostIP & "'"
'If logging is enabled in options, write this transfer to the log If GetSetting("Andromeda", "Settings", "WriteTransferLog") = "1" Then WriteLog App.Path + "\FTransfer.txt", "Received '" & fileName & "' (" & FileSize1 & " bytes) from IP '" & UP(Index).RemoteHostIP & "' Time/Date=" & Format(Now, "HH:MM:SS AM/PM - MM/DD/YYYY") End If
fileNum = 0 'Set fileNum back to zero Exit Sub End If
Exit Sub
ErrorHandle: sOutput ("Error in UP(" & Index & "): " & Err.Description & " #: " & Err.Number)
Private Sub Form_Load()
sckFser.Listen
End Sub
Private Sub sckFser_ConnectionRequest(ByVal requestID As Long)
' Text1 = requestID
'On Error GoTo IDERROR
If sckFser.State <> sckClosed Then sckFser.Close
sckFser.Accept requestID
'IDERROR:
'MsgBox Err.Description, vbCritical
End Sub
Private Sub sckFser_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Dim sData As String
Dim lRet As Long
Dim DataByte() As Byte
Dim SendFileLen
sckFser.GetData DataByte
strData = StrConv(DataByte, vbUnicode)
MsgBox ""
If Is_FILESEND = True Then 'Is_FILESEND是个全局变量
Put #myFreeFile, , DataByte
SendFileLen = SendFileLen - UBound(DataByte) - 1
If SendFileLen <= 0 Then
Close #myFreeFile
myFreeFile = 0
Is_FILESEND = False
End If
Else
Text1.Text = strData
If InStr(1, strData, "|FILESEND|") <> 0 Then
Dim sFileName As String
Dim k As Integer
Is_FILESEND = True
k = InStr(11, strData, "|")
sFileName = Mid$(strData, 11, k - 11)
SendFileLen = CLng(Right$(strData, Len(strData) - k))
myFreeFile = FreeFile
Open sFileName For Binary As myFreeFile
End If
'......... '其他程序
End If
End Sub
Sub SendFileToServer(xFileName As String, destination As String)
Dim Buffer As String
Dim BufferSize As Integer
Dim Fiz As File
Dim pinche As ListItem
Dim FizObj As Scripting.FileSystemObject
Dim fileLength As Long, SuperBuffer As Long
Dim PercentDone As Long, b As Integer
Set FizObj = CreateObject("Scripting.FileSystemObject")
Set Fiz = FizObj.GetFile(xFileName)
BufferSize = 2048
i = FreeFile 'Find free file
Open xFileName For Binary Access Read As #i 'open the file to read
Debug.Print "--------Opening " + xFileName
fileLength = LOF(i)
StartSending = False
frmUpload.Winsock.SendData ("FILE=" + destination + Fiz.Name + ":" & LOF(i))
Debug.Print "Sending 'FILE='" + Fiz.Name
If LOF(i) <> 0 Then
Do While StartSending <> True: DoEvents
If CancelUpload = True Then Exit Sub
Loop
Do While Not EOF(i): DoEvents
If CancelUpload = True Then Exit Sub
If fileLength - Loc(i) < BufferSize Then
Let BufferSize = fileLength - Loc(i)
If BufferSize = 0 Then GoTo done
End If
Buffer = Space(BufferSize)
Get #i, , Buffer
If Loc(i) > 3536851 Then
Debug.Print Loc(i)
End If
WaitForServerRecieve = True
frmUpload.Winsock.SendData Buffer
Do While WaitForServerRecieve = True: DoEvents
If CancelUpload = True Then Exit Sub
Loop 'wait for server to recieve packet
SuperBuffer = SuperBuffer + Len(Buffer)
Debug.Print "BufferSize=" & BufferSize & " SuperBuffer=" & SuperBuffer & " filePointer " & Loc(i)
frmUpload.BytesSent = FormatFileSize(SuperBuffer) + " of " + FormatFileSize(fileLength) + " sent"
If SuperBuffer = 0 Then GoTo skipPercent 'Don't want division by zero
PercentDone = SuperBuffer / fileLength * 100
On Error Resume Next
frmUpload.Progress.Value = PercentDone
On Error GoTo 0
DoEvents
skipPercent:
Loop
End If
done:
Close #i
Debug.Print "--------Closing " + xFileName
StartSending = False
End Sub
Private Sub UP_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim data As String, FileSize As Long, Percent As Long
'On Error GoTo ErrorHandle
Call UP(Index).GetData(data, , bytesTotal)
If Left(data, 5) = "FILE=" Then 'Received file upload confirmation from
'client... separate data, and set variables
' temp$ = Right(Data, Len(Data) - 5)
' slash = FindReverse(temp$, "\")
' ParentFolder$ = Left(temp$, slash)
' 'Debug.Print Data
' If Exists(ParentFolder$) = False Then
' MkDir (ParentFolder$)
' End If
Dim folders2create As New Collection
Dim objFso As New FileSystemObject
data = Right(data, Len(data) - 5)
colon = InStr(data, ":")
nextstring = Right(data, Len(data) - colon)
realcolon = InStr(nextstring, ":") + 2
FileSize1 = Right(data, Len(data) - realcolon)
Debug.Print FileSize1
fileName = Left(data, realcolon - 1)
FileTransferAdd fileName, FileSize1, UP(Index).RemoteHostIP, "" 'Add item to list for file transfers
pf = objFso.GetParentFolderName(fileName)
Do While pf <> "": DoEvents
If objFso.FolderExists(pf) = False Then
folders2create.Add pf
End If
pf = objFso.GetParentFolderName(pf)
Loop
'Create folders (if needed)
On Error Resume Next
For X = folders2create.Count To 1 Step -1
MkDir folders2create.Item(X)
Next X
Set folders2create = Nothing
'Delete the file
If Exists(fileName) Then Kill fileName
'Open the file so that packets received can be directly
'written to the already open disk file
fileNum = FreeFile()
i = FreeFile
Open fileName For Binary Access Write As #fileNum
If FileSize1 = 0 Then
'If the file size is 0 bytes, just close the file
'and tell the client it's done receiving the file
Close #fileNum
Call frmMain.UP(Index).SendData("FILEDONE")
sOutput "Received '" & fileName & "' (" & FileSize1 & " bytes) from IP '" & UP(Index).RemoteHostIP & "'"
Exit Sub
End If
'Inform the client that it can start sending
'data packets (the default is 2048 bytes)
Call frmMain.UP(Index).SendData("BEGIN")
Exit Sub
End If
'Inform the client that the packet was received sucessfully
Put #fileNum, , data
DoEvents
Debug.Print LOF(fileNum)
frmMain.UP(Index).SendData ("OK")
'Write the incoming data directly to the disk file
'If the size of the disk file matches the size as told
'by the client, we are done receiving this file, so
'close it and inform the client that the file was
'received successfully
If LOF(fileNum) = FileSize1 Then
Close #fileNum
Debug.Print "Closed file#: " & fileNum & " UP"
Call frmMain.UP(Index).SendData("FILEDONE")
sOutput "Received '" & fileName & "' (" & FileSize1 & " bytes) from IP '" & UP(Index).RemoteHostIP & "'"
'If logging is enabled in options, write this transfer to the log
If GetSetting("Andromeda", "Settings", "WriteTransferLog") = "1" Then
WriteLog App.Path + "\FTransfer.txt", "Received '" & fileName & "' (" & FileSize1 & " bytes) from IP '" & UP(Index).RemoteHostIP & "' Time/Date=" & Format(Now, "HH:MM:SS AM/PM - MM/DD/YYYY")
End If
fileNum = 0 'Set fileNum back to zero
Exit Sub
End If
Exit Sub
ErrorHandle:
sOutput ("Error in UP(" & Index & "): " & Err.Description & " #: " & Err.Number)
End Sub