http upload from within Excel (vba)

[russland]

Hi,

I need to upload a zip file to a http-server. A html formupload (<input type="file">) works fine and neat. But my excel code fails to send a proper post method. So I wasted so much time finding out the proper headers (msdn and rfc) and methods that I'm willing to simply copy code that anyone could/would provide.

Did anyone succed in this?
thanks for any hint or code.

 

[russland]

Option Explicit

Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long _
) As Long

Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long _
) As Long

Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" ( _
ByVal hHttpSession As Long, _
ByVal sVerb As String, _
ByVal sObjectName As String, _
ByVal sVersion As String, _
ByVal sReferer As String, _
ByVal something As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long _
) As Long

Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" ( _
ByVal hHttpRequest As Long, _
ByVal sHeaders As String, _
ByVal lHeadersLength As Long, _
ByVal sOptional As String, _
ByVal lOptionalLength As Long _
) As Long

Declare Function InternetReadFile Lib "wininet.dll" ( _
ByVal hFile As Long, _
ByVal sBuffer As String, _
ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long _
) As Long

Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" ( _
ByVal hHttpRequest As Long, _
ByVal lInfoLevel As Long, _
ByRef sBuffer As Any, _
ByRef lBufferLength As Long, _
ByRef lIndex As Long _
) As Integer

Declare Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As Long _
) As Integer

Private Declare Function HttpAddRequestHeaders Lib "wininet.dll" _
Alias "HttpAddRequestHeadersA" _
(ByVal hHttpRequest As Long, _
ByVal sHeaders As String, _
ByVal lHeadersLength As Long, _
ByVal lModifiers As Long) As Integer

'new
Const HTTP_ADDREQ_FLAG_ADD = &H20000000
Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000

Const INTERNET_FLAG_SECURE = &H800000
Const INTERNET_FLAG_IGNORE_CERT_CN_INVALID = &H1000
Const INTERNET_FLAG_RELOAD = &H80000000
Const HTTP_QUERY_STATUS_CODE = 19
Const HTTP_QUERY_STATUS_TEXT = 20
Const INTERNET_SERVICE_HTTP = 3
Const INTERNET_OPEN_TYPE_PRECONFIG = 0

Public Enum INTERNET_DEF
INTERNET_DEFAULT_HTTP_PORT = 80
INTERNET_DEFAULT_HTTPS_PORT = 443
End Enum

Sub UploadFiles()

Dim intFile As Integer
Dim strPostData As String
Dim strStatusCode As String
Dim strStatusText As String

'Hier die Connection: Wenn das Login stimmt, kommt ein "OK" zurück, wenn nicht ein "Access Denied"
'Call UrlPost("

https://localhost/default.asp",

strPostData, strStatusCode, _
strStatusText, INTERNET_DEFAULT_HTTPS_PORT, "bzimmer", "8russland8")
Call UrlPost("

http://localhost/default.asp",

strPostData, strStatusCode, _
strStatusText, INTERNET_DEFAULT_HTTP_PORT, "user", "password")

intFile = FreeFile
Open "C:\PopUpCalendar.zip" For Binary As intFile
strPostData = String(LOF(intFile), " ")
Get intFile, , strPostData
Close intFile

'Hier der POST Request an upload.asp / Wenn das Excel Workbook authentifiziert ist, kommmt die Fehlermeldung
'des upload.asp codes "Wrong Content-Type. Make sure you have included the attribute ENCTYPE="multipart/form-data" in your form"
'wenn es nicht authentifiziert ist, kommt die standart Holspace Fehlermeldung.
Call UrlPost("

http://localhost/upload.asp",

strPostData, strStatusCode, _
strStatusText, INTERNET_DEFAULT_HTTP_PORT, "user", "password")

End Sub

Sub UrlPost(stURL As String, strPostData As String, _
ststrStatusCode As String, _
stStatusText As String, _
Optional lgInternet As INTERNET_DEF = INTERNET_DEFAULT_HTTP_PORT, _
Optional stUser As String = vbNullString, _
Optional stPass As String = vbNullString)

Dim strRead As String * 2048
Dim strLoad As String
Dim sHeader As String
Dim strUrlDeb As String
Dim strUrlFin As String
Dim strMethod As String
Dim strPost As String
Dim strBoundary As String
Dim blnDoLoop As Boolean
Dim lngISession As Long
Dim lngIConnect As Long
Dim lngIRequest As Long
Dim lngFlags As Long
Dim lngRep As Long
Dim lngRead As Long

If (InStr(1, stURL, "/") > 0) Then
strUrlDeb = Replace(LCase$(stURL), "

http://",

vbNullString)
strUrlDeb = Replace(LCase$(strUrlDeb), "

https://",

vbNullString)
strUrlFin = strUrlDeb
strUrlDeb = Left$(strUrlDeb, InStr(1, strUrlDeb, "/") - 1)
strUrlFin = Mid$(strUrlFin, InStr(1, strUrlFin, "/") + 1)
Else
strUrlDeb = stURL
strUrlFin = vbNullString
End If
If (strPostData <> vbNullString) Then
strPost = strPostData
strMethod = "POST"
'strBoundary = "-----------------------------83072601111497"
'Here is something wrong with the header...

'Some examples from the internet:.

'strLoad = "-----------------------------83072601111497" & vbCrLf _
& "Content-Disposition: form-data; name=""tb""" & vbCrLf & vbCrLf _
& "3" & vbCrLf _
& "-----------------------------83072601111497" & vbCrLf _
& "Content-Disposition: form-data; name=""FileType""" & vbCrLf & vbCrLf _
& "ClientList" & vbCrLf _
& "-----------------------------83072601111497" & vbCrLf _
& "Content-Disposition: form-data; name=""SessionCode""" & vbCrLf & vbCrLf _
& strSessionCode & vbCrLf _
& "-----------------------------83072601111497" & vbCrLf _
& "Content-Disposition: form-data; name=""FileFormat""" & vbCrLf & vbCrLf _
& strFileFormat & vbCrLf _
& "-----------------------------83072601111497" & vbCrLf _
& "Content-Disposition: form-data; name=""FName""; filename=""temp.txt""" & vbCrLf _
& "Content-Type: text/plain" & vbCrLf & vbCrLf _
& tFile & vbCrLf _
& "-----------------------------83072601111497--"
'strLoad = vbNullString
'strLoad = "Content-Type: application/x-

http://www-form-urlencoded"

& vbCrLf
strLoad = "Content-Type: multipart/form-data, boundary=--AaB03x" & vbCrLf
'strLoad = "Content-Type: multipart/form-data; boundary=" & strBoundary & vbCrLf
Else
strPost = vbNullString
strMethod = "GET"
strLoad = vbNullString
End If
If (lgInternet = INTERNET_DEFAULT_HTTPS_PORT) Then
lngFlags = INTERNET_FLAG_SECURE Or _
INTERNET_FLAG_IGNORE_CERT_CN_INVALID
Else
lngFlags = INTERNET_FLAG_RELOAD
End If
lngISession = InternetOpen(Application.Name, INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, vbNullString, 0)
If CBool(lngISession) Then
lngIConnect = InternetConnect(lngISession, strUrlDeb, lgInternet, stUser, stPass, _
INTERNET_SERVICE_HTTP, 0, 0)
lngIRequest = HttpOpenRequest(lngIConnect, strMethod, strUrlFin, "HTTP/1.0", _
vbNullString, 0, lngFlags, 0)
If (strMethod = "GET") Then
lngRep = HttpSendRequest(lngIRequest, strLoad, Len(strLoad), strPost, Len(strPost))
Else 'POST
Dim bRet As Boolean
bRet = HttpAddRequestHeaders(lngIRequest, strLoad, Len(strLoad), _
HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
strPost = _
"--AaB03x" & vbCrLf & _
"Content-Disposition: form-data; name=""theFile""; filename=""C:\$User\Holcim\FPR\PopUpCalendar.zip""" _
& """" & vbCrLf & _
"Content-Transfer-Encoding: binary" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
strPost & vbCrLf

lngRep = HttpSendRequest(lngIRequest, vbNullString, 0, strPost, Len(strPost))
End If

blnDoLoop = True
strLoad = vbNullString
Do While blnDoLoop
strRead = vbNullString
blnDoLoop = InternetReadFile(lngIRequest, strRead, Len(strRead), lngRead)
strLoad = strLoad & Left$(strRead, lngRead)
Debug.Print strLoad
If Not CBool(lngRead) Then blnDoLoop = False
Loop
ststrStatusCode = Space$(1024)
lngRead = 1024
HttpQueryInfo lngIRequest, HTTP_QUERY_STATUS_CODE, ByVal ststrStatusCode, lngRead, 0
ststrStatusCode = Left$(ststrStatusCode, lngRead)
stStatusText = Space$(1024)
lngRead = 1024
HttpQueryInfo lngIRequest, HTTP_QUERY_STATUS_TEXT, ByVal stStatusText, lngRead, 0
stStatusText = Left$(stStatusText, lngRead)
End If
Call InternetCloseHandle(lngISession)
Call InternetCloseHandle(lngIConnect)
Call InternetCloseHandle(lngIRequest)

End Sub