#####################################
'Server-Code
Public Function ReceiveDataFromSocket(lngSocket As Long)
Dim arrData(1 To MAX_BUFFER_LENGTH) As Byte
Dim lngBytesReceived As Long
Dim strData As String
Dim strTempData As String
Do
lngBytesReceived = recv(lngSocket, arrData(1), MAX_BUFFER_LENGTH, 0&)
If lngBytesReceived = 0 Then
'Nothing to do
ElseIf lngBytesReceived > 0 Then
If FilNumInput = 0 Then
FilNumInput = FreeFile
Open "C:\test.exe" For Binary Access Write As #FilNumInput
End If
strTempData = StrConv(arrData, vbUnicode)
strData = Left$(strTempData, lngBytesReceived)
Seek #FilNumInput, LOF(FilNumInput) + 1
Put #FilNumInput, , Left(arrData, lngBytesReceived)
frmServer.lstDataArrived.AddItem "Data received."
End If
If lngBytesReceived <> MAX_BUFFER_LENGTH Then
Close FilNumInput
frmServer.lstDataArrived.AddItem "File closed and upload finished."
bolFileOpen = False
FilNumInput = 0
Exit Do
End If
Loop
End Function
Public Function CheckSockets() As Long
'Checkt Sockets auf Read/Write/Error
Dim lngRetValue As Long
Dim fdRead As fd_set
Dim fdWrite As fd_set
Dim fdError As fd_set
'
lngSocketCount = 3
'
If plngStartedSocket <> 0 Then
fdRead.fd_array(1) = plngStartedSocket
fdWrite.fd_array(1) = plngStartedSocket
fdError.fd_array(1) = plngStartedSocket
fdRead.fd_count = 1
fdWrite.fd_count = 1
fdError.fd_count = 1
End If
If plngConnectedSocket <> 0 Then
fdRead.fd_array(2) = plngConnectedSocket
fdWrite.fd_array(2) = plngConnectedSocket
fdError.fd_array(2) = plngConnectedSocket
fdRead.fd_count = 2
fdWrite.fd_count = 2
fdError.fd_count = 2
End If
If plngListeningSocket <> 0 Then
If plngConnectedSocket > 0 Then
fdRead.fd_array(3) = plngListeningSocket
fdWrite.fd_array(3) = plngListeningSocket
fdError.fd_array(3) = plngListeningSocket
fdRead.fd_count = 3
fdWrite.fd_count = 3
fdError.fd_count = 3
ElseIf plngConnectedSocket = 0 Then
fdRead.fd_array(2) = plngListeningSocket
fdWrite.fd_array(2) = plngListeningSocket
fdError.fd_array(2) = plngListeningSocket
fdRead.fd_count = 2
fdWrite.fd_count = 2
fdError.fd_count = 2
End If
End If
'
lngRetValue = vbselect(0&, fdRead, fdWrite, fdError, 0&)
'
If lngRetValue = SOCKET_ERROR Then
ErrMsg (Err.LastDllError)
ElseIf lngRetValue > 0 Then
'
If fdWrite.fd_count > 0 Then
For i = 1 To fdWrite.fd_count
lngSocket = fdWrite.fd_array(i)
Next i
End If
'
If fdRead.fd_count > 0 Then
For i = 1 To fdRead.fd_count
lngSocket = fdRead.fd_array(i)
If lngSocket = plngListeningSocket Then
If pbolListeningSocketIsFree = True Then
AcceptSocket
End If
Else
ReceiveDataFromSocket fdRead.fd_array(i)
End If
Next i
ElseIf fdRead.fd_count = 0 And bolFileOpen = True Then
Close FilNumInput
bolFileOpen = False
FilNumInput = 0
End If
'
If fdError.fd_count > 0 Then
For i = 1 To fdError.fd_count
lngSocket = fdError.fd_array(i)
Next i
End If
'
End If
'
End Function
############################################
Client-Code
Public Sub FileTransfer(strInputFile As String, lngSocket As Long)
'liest die Datei ein und sendet sie an das Socket
Dim FilNumInput As Long
Dim FilNumOutPut As Long
Dim FileData As Byte
Dim lngFilePlace As Long
Dim i As Long
Dim lngProg As Double
Dim strOutPutFile As String
Dim lngProgListView As Double
FilNumInput = FreeFile
FilNumOutPut = FreeFile + 1
strOutPutFile = "C:\TestSmART." & Right(strInputFile, 3)
frmClient.ProBa.Value = 0
lngProgListView = 0
If strInputFile = "" Then
MsgBox "Please select a file first.", vbCritical, "Missing File"
Exit Sub
End If
Open strInputFile For Binary Access Read As FilNumInput
If LOF(FilNumInput) > 0 Then lngProg = 100 / LOF(FilNumInput)
Open strOutPutFile For Binary Access Write As FilNumOutPut
Do Until EOF(FilNumInput)
Get FilNumInput, , FileData
'DoEvents
If frmClient.ProBa.Value + lngProg <= 100 Then
frmClient.ProBa.Value = frmClient.ProBa.Value + lngProg
frmClient.lvSockets.SelectedItem.SubItems(3) = Format(lngProgListView, "#,##0.0")
lngProgListView = lngProgListView + lngProg
End If
SendDataToSocket lngSocket, FileData
Put FilNumOutPut, , FileData
Loop
frmClient.lvSockets.SelectedItem.SubItems(3) = Format(100, "#,##0")
ShowUploadFinish
Close FilNumOutPut
Close FilNumInput
End Sub
Public Function SendDataToSocket(lngSocket As Long, bytData As Byte)
Dim arrBuffer() As Byte
Dim lngBytesSent As Long
Dim lngBufferLength As Long
'
If Len(bytData) = 0 Then
MsgBox "No Data to send available.", vbCritical, "Missing Data"
Exit Function
End If
lngBufferLength = Len(bytData)
arrBuffer() = StrConv(bytData, vbUnicode)
lngBytesSent = send(lngSocket, arrBuffer(0), lngBufferLength, 0&)
End Function
Public Function CheckAllSockets() As Long
'Return: 0 --> Sockets´ status
Dim fdRead As fd_set
Dim fdWrite As fd_set
Dim fdError As fd_set
Dim lngRetSelect As Long
Dim lngSocket As Long
Dim lvItem As ListItem
Dim i As Integer
fdRead.fd_count = frmClient.lvSockets.ListItems.Count
fdWrite.fd_count = frmClient.lvSockets.ListItems.Count
fdError.fd_count = frmClient.lvSockets.ListItems.Count
For i = 1 To frmClient.lvSockets.ListItems.Count
fdRead.fd_array(i) = CLng(Mid(frmClient.lvSockets.ListItems(i).Key, 2, Len(frmClient.lvSockets.ListItems(i).Key) - 1))
fdWrite.fd_array(i) = CLng(Mid(frmClient.lvSockets.ListItems(i).Key, 2, Len(frmClient.lvSockets.ListItems(i).Key) - 1))
fdError.fd_array(i) = CLng(Mid(frmClient.lvSockets.ListItems(i).Key, 2, Len(frmClient.lvSockets.ListItems(i).Key) - 1))
Next i
If fdRead.fd_count > 0 Then
lngRetSelect = vbselect(0, fdRead, fdWrite, fdError, 0)
If lngRetSelect = SOCKET_ERROR Then
MsgBox "Error while Checking the Sockets", vbCritical, "An error occured"
Exit Function
ElseIf lngRetSelect > 0 Then
If fdRead.fd_count > 0 Then
For i = 1 To fdRead.fd_count
lngSocket = fdRead.fd_array(i)
If lngSocket = lngListeningSocket Then
AddIncomingSocket lngSocket
Else
ReadSocketData lngSocket
End If
Next i
End If
If fdWrite.fd_count > 0 Then
For i = 1 To fdWrite.fd_count
lngSocket = fdWrite.fd_array(i)
'SendDataToSocket
Next i
End If
If fdError.fd_count > 0 Then
For i = 1 To fdError.fd_count
lngSocket = fdError.fd_array(i)
RemoveDownSocket lngSocket
Next i
End If
End If
End If
End Function
