SERVERXMLHTTP : AUTOMATISATION D'ENVOI D'UN FORMULAIRE AVEC UPLOAD

Sub Send_File()

    Dim XMLfileName As String
    Dim ZIPfileName As String
 
    'Variables systeme fichier
    Dim Fso As FileSystemObject
    Dim FSo2 As FileSystemObject
    Dim FichierLog_Stream As TextStream
    Dim LOGfileName As String
 
      
  
        
        '##########################################################################
        'Lecture du fichier pour stockage Binaire
        Dim strFileName1 As String
        Dim nFile As Integer
        Dim strText As String
        
        strFileName1 = "C:\nomfichier.xml"
        nFile = FreeFile
        
        Open strFileName1 For Binary As #nFile
        strText = String(LOF(nFile), " ")
        Get #nFile, , strText
        Close #nFile
       
        '##########################################################################
        'Préparation des entete et body du formulaire
        Dim ServerSafeHTTP As XMLHTTP50
        Set ServerSafeHTTP = CreateObject("Msxml2.ServerXMLHTTP")
                
        ServerSafeHTTP.Open "POST", Const_URL_SERVER_DEST, False
        
        Dim StrBody As String
        
        StrBody = ""
        StrBody = StrBody & setBody("Champ1", "voiture") 'Champ Champ1 du formulaire
        StrBody = StrBody & setBody("Champ2", "modele") 'Champ Champ2 du formulaire
        StrBody = StrBody & setBodyFile(Right(strFileName1, 3)) 'entete du fichier selon son type
        StrBody = StrBody & strText & vbCrLf & "--" & Const_BOUNDARY & "--" 'Fin de traitement
        
        Dim aPostData() As Byte
        aPostData = StrConv(StrBody, vbFromUnicode)
        
        ServerSafeHTTP.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & Const_BOUNDARY & vbCrLf
        ServerSafeHTTP.send aPostData
        
        
        If ServerSafeHTTP.Status = 200 Then
            msgbox ("Envoi effectué :" & ServerSafeHTTP.responseText)
        Else
            msgbox ("Erreur :" & _
            ServerSafeHTTP.Status & vbcrlf & ServerSafeHTTP.statusText & vbcrlf &  ServerSafeHTTP.responseText)
        End If

End Sub

'Création des Champs du formulaire
Function setBody(name, value)
    Dim body
    body = "--" & Const_BOUNDARY & vbCrLf
    body = body & "Content-Disposition: form-data; name=""" & name & """" & vbCrLf & vbCrLf
    body = body & value & vbCrLf
    setBody = body
End Function

'Création de l'entete UPLOAD du champ fichier du formulaire selon son type
Function setBodyFile(extention)
    Dim body
    body = "--" & Const_BOUNDARY & vbCrLf
    body = body & "Content-Disposition: form-data; name=""file""; filename=""ExportCARIFPCH.xml""" & vbCrLf
    body = body & "Content-Transfer-Encoding: binary" & vbCrLf & vbCrLf
    Select Case extention
        Case "zip"
            body = body & "Content-Type: application/zip" & vbCrLf & vbCrLf
        Case "xml"
            body = body & "Content-Type: text/xml" & vbCrLf & vbCrLf
        Case Else
            body = body & "Content-Type: text/plain" & vbCrLf & vbCrLf
    End Select
    
    setBodyFile = body
End Function