TRANSFERT DE FICHIER VIA WINSOCK

'Simple File transfert using Winsock.ocx, if you dont want of this dependancy you can use csocket @vbip.com
'Greetz: undergroundkonnekt team
'this is an exemple, if you use it, give the credit to its author.

Option Explicit

Dim BlnTflag As Boolean 'Flag de transfert, Transfert Flag
Dim LngCursor As Long 'Pointeur de position dans fichier source, source file position pointer


''''''''''''''''CLIENT'''''''''''''''''
'''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''
Private Sub CmdConnect_Click()
WskC.Connect TxtIp.Text, TxtCPort.Text 'Connection

End Sub

Private Sub CmdSend_Click()
On Error GoTo actcancel

If BlnTflag = False Then 'si on est pas dans un transfert, if we're not transferring
    LngCursor = 0 'reinitialisation du pointeur, pointer reinitialisation
    If WskC.State <> 7 Then
        'Call ErrorHandler(2)
    Else
        DlgSend.ShowOpen 'common dialog
        WskC.SendData "Transfert" & "|" & DlgSend.FileTitle & "|" & FileLen(DlgSend.FileName) 'on envoie le nom du fichier, we send the file name
    End If
Else
    Exit Sub
End If

actcancel: Exit Sub
End Sub

Private Sub WskC_Close()
Me.Caption = "Disconnected"
CmdConnect.Caption = "Connect"
End Sub

Private Sub WskC_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)
Me.Caption = "Disconnected"
CmdConnect.Caption = "Connect"
End Sub

Private Sub WskC_Connect()

Me.Caption = "Connected"
CmdConnect.Caption = "Disconnect"
End Sub


Private Sub WskC_DataArrival(ByVal bytesTotal As Long)
Dim strdata As String 'datas reçues, received datas
Dim strBuffer As String 'Buffer

WskC.GetData strdata 'get data

'si il reste moins de 2048 octets
'if there are more than 2048 left
If FileLen(DlgSend.FileName) - LngCursor < 2048 Then
    'on ajuste la taille du buffer
    'Buffer size adjustment
    strBuffer = Space(FileLen(DlgSend.FileName) - LngCursor)
'Si il reste plus de 2048 octets
'if there are more than 2048 bytes left
ElseIf FileLen(DlgSend.FileName) - LngCursor > 2048 Then
    'buffer = 2048
    strBuffer = Space(2048)
End If

'Si le pointeur est egal à la taille fichier source
'if pointer value = source file size
If FileLen(DlgSend.FileName) = LngCursor Then
    'on a fini le transfert, on ferme le fichier on le dit au server
    'we have finished the transfert, we close the opened file, and we tell the server the job is done
    LblStatut.Caption = "Statut: " & DlgSend.FileName & " successfully uploaded"
    WskC.SendData "E"
    Close #1
    Exit Sub
End If

'Le server nous demande de commencer le transfert
'the server ask for the transfert beginning
If Left(strdata, 1) = "S" Then
    LblStatut.Caption = "Statut: Uploading " & DlgSend.FileName
    'on ouvre le fichier en binaire
    'we open the file in binary mode
    Open DlgSend.FileName For Binary As #1
        Get #1, , strBuffer 'on prend un bout de code equivalent au buffer, we get some datas according to the buffer size
    WskC.SendData strBuffer 'on l'envoie, we send it
    LngCursor = Len(strBuffer) 'on update le pointeur au debut du transfert il est de la taille du buffer(2048), we update the pointer, at the beginning of a transfert it's 2048
'Le server demande un autre bout de fichier
'The server ask for another file chunk
ElseIf Left(strdata, 1) = "N" Then
        Get #1, LngCursor + 1, strBuffer 'on reprend l'equivalent du buffer, we take some datas (=buffersize)
    WskC.SendData strBuffer 'on envoie, we send
    LngCursor = LngCursor + Len(strBuffer) 'on update le pointeur, we update the pointer
End If
End Sub

 
'''''''''''SERVER''''''''''''
'''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Private Sub CmdListen_Click()
On Error Resume Next
If TxtSPort.Text <> "" Then
    WskS.LocalPort = TxtSPort.Text
    WskS.Close
    WskS.Listen 'Listening
Else
    'Call ErrorHandler(1)
End If
End Sub


Private Sub WskS_ConnectionRequest(ByVal requestID As Long)

WskS.Close
WskS.Accept requestID
End Sub

Private Sub WskS_DataArrival(ByVal bytesTotal As Long)
Dim strdata As String
Dim StrSplited() As String
Dim StrFilename As String
Dim LngFileSize As Long

WskS.GetData strdata 'getdata
StrSplited = Split(strdata, "|") 'On split les datas, we split data (delimiter = |)

If strdata = "E" Then 'si c'est la fin d'un transfert, if it's the end of a transfert
    Close #2 'on ferme le fichier destination, we close the dest file
    BlnTflag = False 'we update the flag
    Exit Sub
End If

If BlnTflag = False Then 'si on est pas dans un transfert, if we're not in a file transfert
'on l'initialise en updatant le flag, en récuperant le nom du fichier , on ouvre un fichier vierge en binaire, puis en demande un bout de fichier
'transfert initialisation: flag update, file name get, we open a free file, then we ask for the first chunk
    If StrSplited(0) = "Transfert" Then
        StrFilename = StrSplited(1)
        BlnTflag = True
        WskS.SendData "S"
        If Dir(App.Path & "\" & StrFilename) <> "" Then 'on efface le fichier si il est déja present, we erase the file if it exists
            Kill (App.Path & "\" & StrFilename)
        End If
        
        Open App.Path & "\" & StrFilename For Binary As #2
    End If
Else
    Put #2, LOF(2) + 1, strdata 'on ecrit les bout de donner en fin de fichier, we write data at the end of the file
    WskS.SendData "N" 'we ask for another chunk
End If
End Sub