Option Explicit

 

Private Const INTERNET_AUTODIAL_FORCE_ONLINE As Long = 1

Private Const INTERNET_OPEN_TYPE_PRECONFIG  As Long = 0

Private Const INTERNET_DEFAULT_HTTP_PORT    As Long = 80

Private Const INTERNET_SERVICE_HTTP         As Long = 3

Private Const INTERNET_FLAG_RELOAD          As Long = &H80000000

Private Const HTTP_ADDREQ_FLAG_REPLACE      As Long = &H80000000

Private Const HTTP_ADDREQ_FLAG_ADD          As Long = &H20000000

 Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000

 

 

 

Private Declare Function HttpSendRequestEx Lib "wininet.dll" Alias "HttpSendRequestExA" (ByVal hHttpRequest As Long, lpBuffersIn As INTERNET_BUFFERS, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

 

Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long

Private 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

Private 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

Private 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

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 Long

Private 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

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

 Private 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

Private Declare Function HttpEndRequest Lib "wininet.dll" Alias "HttpEndRequestA" (ByVal hHttpRequest As Long, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

 

Private Declare Function InternetWriteFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) As Integer

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

 

 

 

 

Private Const HTTP_QUERY_CONTENT_TYPE = 1

Private Const HTTP_QUERY_CONTENT_LENGTH = 5

Private Const HTTP_QUERY_EXPIRES = 10

Private Const HTTP_QUERY_LAST_MODIFIED = 11

Private Const HTTP_QUERY_PRAGMA = 17

Private Const HTTP_QUERY_VERSION = 18

Private Const HTTP_QUERY_STATUS_CODE = 19

Private Const HTTP_QUERY_STATUS_TEXT = 20

Private Const HTTP_QUERY_RAW_HEADERS = 21

Private Const HTTP_QUERY_RAW_HEADERS_CRLF = 22

Private Const HTTP_QUERY_FORWARDED = 30

Private Const HTTP_QUERY_SERVER = 37

Private Const HTTP_QUERY_USER_AGENT = 39

Private Const HTTP_QUERY_SET_COOKIE = 43

Private Const HTTP_QUERY_REQUEST_METHOD = 45

Private Const HTTP_STATUS_DENIED = 401

Private Const HTTP_STATUS_PROXY_AUTH_REQ = 407

Private Const HSR_INITIATE = &H8

 

'Private Declare Function HttpSendRequestEx Lib "wininet.dll" Alias "HttpSendRequestExA" (ByVal hHttpRequest As Long, lpBuffersIn As INTERNET_BUFFERS, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

 

 

Private Type INTERNET_BUFFERS

dwStructSize As Long

Next As Long

lpcszHeader As Long

dwHeadersLength As Long

dwHeadersTotal As Long

lpvBuffer As Long

dwBufferLength As Long

dwBufferTotal As Long

dwOffsetLow As Long

dwOffsetHigh As Long

End Type

 

Function TranslateErrorCode(ByVal lErrorCode As Long) As String

 

 

Select Case lErrorCode

    Case 12001: TranslateErrorCode = "No more handles could be generated at this Time "

    Case 12002: TranslateErrorCode = "The request has timed out."

    Case 12003: TranslateErrorCode = "An extended error was returned from the server."

    Case 12004: TranslateErrorCode = "An internal error has occurred."

    Case 12005: TranslateErrorCode = "The URL is invalid."

    Case 12006: TranslateErrorCode = "The URL scheme could not be recognized, or is not supported."

    Case 12007: TranslateErrorCode = "The server name could not be resolved."

    Case 12008: TranslateErrorCode = "The requested protocol could not be located."

    Case 12009: TranslateErrorCode = "A request to InternetQueryOption or InternetSetOption specified an invalid option value."

    Case 12010: TranslateErrorCode = "The length of an option supplied to InternetQueryOption or InternetSetOption is incorrect for the type of option specified."

    Case 12011: TranslateErrorCode = "The request option can not be set, only queried. "

    Case 12012: TranslateErrorCode = "The Win32 Internet support is being shutdown or unloaded."

    Case 12013: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied user name is incorrect."

    Case 12014: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied password is incorrect. "

    Case 12015: TranslateErrorCode = "The request to connect to and login to an FTP server failed."

    Case 12016: TranslateErrorCode = "The requested operation is invalid. "

    Case 12017: TranslateErrorCode = "The operation was canceled, usually because the handle on which the request was operating was closed before the operation completed."

    Case 12018: TranslateErrorCode = "The type of handle supplied is incorrect for this operation."

    Case 12019: TranslateErrorCode = "The requested operation can not be carried out because the handle supplied is not in the correct state."

    Case 12020: TranslateErrorCode = "The request can not be made via a proxy."

    Case 12021: TranslateErrorCode = "A required registry value could not be located. "

    Case 12022: TranslateErrorCode = "A required registry value was located but is an incorrect type or has an invalid value."

    Case 12023: TranslateErrorCode = "Direct network access cannot be made at this time. "

    Case 12024: TranslateErrorCode = "An asynchronous request could not be made because a zero context value was supplied."

    Case 12025: TranslateErrorCode = "An asynchronous request could not be made because a callback function has not been set."

    Case 12026: TranslateErrorCode = "The required operation could not be completed because one or more requests are pending."

    Case 12027: TranslateErrorCode = "The format of the request is invalid."

    Case 12028: TranslateErrorCode = "The requested item could not be located."

    Case 12029: TranslateErrorCode = "The attempt to connect to the server failed."

    Case 12030: TranslateErrorCode = "The connection with the server has been terminated."

    Case 12031: TranslateErrorCode = "The connection with the server has been reset."

    Case 12036: TranslateErrorCode = "The request failed because the handle already exists."

    Case Else: TranslateErrorCode = "Error details not available."

End Select

 

 

End Function

 

 

Private Function getQueryOption(info As String, hHttpOpenRequest As Long) As String

    Dim sBuffer         As String * 1024

    Dim lBufferLength   As Long

    Dim intRes As Integer

 

    sBuffer = vbNullString

    lBufferLength = Len(sBuffer)

    intRes = HttpQueryInfo(hHttpOpenRequest, info, ByVal sBuffer, lBufferLength, 0)

    If intRes > 0 Then

        getQueryOption = sBuffer

    Else

        getQueryOption = vbNullString

    End If

End Function

 

 

 

 

 

Private Function HttpPostFromFile(ByVal FileNameToSend As String, _

                                ByRef ReturnString As String, _

                                ByRef result As HTTPTransactionResult) As Boolean

 

 

 

 

    On Local Error GoTo error_handler

    Dim hInternetOpen As Long

    Dim hInternetConnect As Long

    Dim hHttpOpenRequest As Long

    Dim bRet As Boolean

    Dim lret As Long

    Dim iret As Integer

    Dim filenumb As Integer

    Dim macchina As String

    Dim doc As String

    Dim BufferIn As INTERNET_BUFFERS

    Dim abBin() As Byte

 

    Dim sbinfile As String

    Dim nbinfile As Integer

    Dim dwpostsize As Long

    Dim n As Long

    Dim letti As Long

    Dim pbuffer As String

    Dim MyOffset As Long

    Dim chunks As Long

    Dim BytesRemain As Long

    Dim ChunkLen As Long

    Dim bDoLoop             As Boolean

    Dim sReadBuffer         As String * 2048

    Dim lNumberOfBytesRead  As Long

    Dim sHeader As String

 

 

Dim sBoundary As String

 

 

    'Definitions

    ChunkLen = 2048

 

  '  On Error GoTo error_handler

    hInternetOpen = 0

    hInternetConnect = 0

    hHttpOpenRequest = 0

    result.strRETURN_ERROR = vbNullString

    result.intRETURN_ERROR = 0

  '  macchina = URLToMachineName(documento)

  '  doc = URLToPathFileName(documento)

hInternetOpen = InternetOpen("", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

Label1(0).Caption = hInternetOpen

    If hInternetOpen = 0 Then

        result.intRETURN_ERROR = Err.LastDllError

        result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

        HttpPostFromFile = False

    Else 'internetopen ok

hInternetConnect = InternetConnect(hInternetOpen, "www.***.ru", INTERNET_DEFAULT_HTTP_PORT, "", "", INTERNET_SERVICE_HTTP, 0, 0)

    Label1(1).Caption = hInternetConnect

        If hInternetConnect = 0 Then

            result.intRETURN_ERROR = Err.LastDllError

            result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

            HttpPostFromFile = False

        Else 'internetConnect Ok

'hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "POST", "/http_in.php", "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0)

    hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "POST", "/http_in.php", "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)

 

 

         Label1(2).Caption = hHttpOpenRequest

            If hHttpOpenRequest = 0 Then

                result.intRETURN_ERROR = Err.LastDllError

                result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                HttpPostFromFile = False

            Else 'HTTPopenrequest OK

 

 

 

                sBoundary = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"

sHeader = "Content-Type: multipart/form-data; boundary=" & sBoundary & vbCrLf

 

'rslt2 = HttpAddRequestHeaders(hRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)

'    Label1(4).Caption = rslt2

 

 

    '--- post data

 

 

                  sbinfile = FileNameToSend

 

             ' Text2.Text = "--" & sBoundary & vbCrLf & _

"Content-Disposition: multipart/form-data; name=""upfile""; filename=""" & Mid$(sbinfile, InStrRev(sbinfile, "\") + 1) & """" & vbCrLf & _

"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _

"SOD" & vbCrLf & "--" & sBoundary & "--"

 

 

 

 

          '      sHeader = "Content-Type: application/x-octet-stream" & vbCrLf

                iret = HttpAddRequestHeaders(hHttpOpenRequest, _

                                             sHeader, _

                                             Len(sHeader), _

                                             HTTP_ADDREQ_FLAG_REPLACE Or _

                                             HTTP_ADDREQ_FLAG_ADD)

         Label1(3).Caption = iret

                If iret = 0 Then

                    result.intRETURN_ERROR = Err.LastDllError

                    result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                    HttpPostFromFile = False

                Else 'HttpAddRequestHeaders ok

 

                    sbinfile = FileNameToSend

                    nbinfile = FreeFile

                    Open sbinfile For Binary Access Read Lock Write As #nbinfile

 

'

 

                    ReDim abBin(ChunkLen)

    dwpostsize = LOF(nbinfile)

 

   ' Close #nbinfile

 

                    BufferIn.dwStructSize = 40   ' Must be set or error will occur

                    BufferIn.Next = 0

                    BufferIn.lpcszHeader = 0

                    BufferIn.dwHeadersLength = 0

                    BufferIn.dwHeadersTotal = 0

                    BufferIn.lpvBuffer = 0

                    BufferIn.dwBufferLength = 0

                    BufferIn.dwBufferTotal = dwpostsize 'This is the only member used other than dwStructSize

                    BufferIn.dwOffsetLow = 0

                    BufferIn.dwOffsetHigh = 0

                    'HSR_INITIATE try with the second last param.

bRet = HttpSendRequestEx(hHttpOpenRequest, BufferIn, 0, 0, 0)

     Label1(4).Caption = bRet

                    If (bRet = False) Then

                        result.intRETURN_ERROR = Err.LastDllError

                        result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                        HttpPostFromFile = False

                    Else 'SendRequestEx ok

 

 

               '      nbinfile = FreeFile

               '     Open sbinfile For Binary Access Read Lock Write As #nbinfile

 

 

                        chunks = dwpostsize \ ChunkLen

                        BytesRemain = dwpostsize - (chunks * ChunkLen)

                        MyOffset = 1

                        n = 0

                        bRet = True

                        Dim RealChunkLen As Long

                        RealChunkLen = 0

                        While (n < chunks) And (bRet = True)

                            Get #nbinfile, MyOffset, abBin

                            pbuffer = StrConv(abBin, vbUnicode)

 

 

 

 

'pbuffer = "--" & sBoundary & vbCrLf & _

"Content-Disposition: multipart/form-data; name=""upfile""; filename=""" & Mid$(sbinfile, InStrRev(sbinfile, "\") + 1) & """" & vbCrLf & _

"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _

StrConv(abBin, vbUnicode) & vbCrLf & "--" & sBoundary & "--"

 

 

 

                            bRet = InternetWriteFile(hHttpOpenRequest, _

                                                    pbuffer, _

                                                    ChunkLen, _

                                                    letti)

                            n = n + 1

                            Text1.Text = Text1.Text & "send " & n

 

                            MyOffset = 1 + (n * ChunkLen)

                        Wend

 

                       Label1(5).Caption = bRet

                        If bRet = False Then

                            result.intRETURN_ERROR = Err.LastDllError

                            result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                            HttpPostFromFile = False

                        Else 'all internetwritefile (- the last) ok

                            ReDim abBin(BytesRemain)

                            Get #nbinfile, MyOffset, abBin

                            pbuffer = StrConv(abBin, vbUnicode) ' & vbCrLf & "--" & sBoundary & "--"

                            'pbuffer = pbuffer & "--AaBbCcDd00--"

 

                            bRet = InternetWriteFile(hHttpOpenRequest, _

                                                        pbuffer, _

                                                        BytesRemain, _

                                                        letti)

 

                            Close #nbinfile

                  Label1(6).Caption = bRet

                            If bRet = False Then

                                result.intRETURN_ERROR = Err.LastDllError

                                result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                                HttpPostFromFile = False

                            Else 'the last internetwritefile ok

                                Dim param As Long

                                param = 0

                                'HSR_INITIATE penultimo

                                lret = HttpEndRequest(hHttpOpenRequest, 0, 0, 0)

Label1(7).Caption = lret

                                If lret = 0 Then

 

                                    result.intRETURN_ERROR = Err.LastDllError

                                    result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                                    HttpPostFromFile = False

                                Else 'HttpEndRequest ok

                                    result.HTTP_QUERY_CONTENT_TYPE = getQueryOption(HTTP_QUERY_CONTENT_TYPE, hHttpOpenRequest)

                                    result.HTTP_QUERY_CONTENT_LENGTH = getQueryOption(HTTP_QUERY_CONTENT_LENGTH, hHttpOpenRequest)

                                    result.HTTP_QUERY_LAST_MODIFIED = getQueryOption(HTTP_QUERY_LAST_MODIFIED, hHttpOpenRequest)

                                    result.HTTP_QUERY_PRAGMA = getQueryOption(HTTP_QUERY_PRAGMA, hHttpOpenRequest)

                                    result.HTTP_QUERY_EXPIRES = getQueryOption(HTTP_QUERY_EXPIRES, hHttpOpenRequest)

                                    result.HTTP_QUERY_VERSION = getQueryOption(HTTP_QUERY_VERSION, hHttpOpenRequest)

                                    result.HTTP_QUERY_STATUS_CODE = getQueryOption(HTTP_QUERY_STATUS_CODE, hHttpOpenRequest)

                                    result.HTTP_QUERY_STATUS_TEXT = getQueryOption(HTTP_QUERY_STATUS_TEXT, hHttpOpenRequest)

                                    result.HTTP_QUERY_RAW_HEADERS = getQueryOption(HTTP_QUERY_RAW_HEADERS, hHttpOpenRequest)

                                    result.HTTP_QUERY_RAW_HEADERS_CRLF = getQueryOption(HTTP_QUERY_RAW_HEADERS_CRLF, hHttpOpenRequest)

                                    result.HTTP_QUERY_FORWARDED = getQueryOption(HTTP_QUERY_FORWARDED, hHttpOpenRequest)

                                    result.HTTP_QUERY_SERVER = getQueryOption(HTTP_QUERY_SERVER, hHttpOpenRequest)

                                    result.HTTP_QUERY_USER_AGENT = getQueryOption(HTTP_QUERY_USER_AGENT, hHttpOpenRequest)

                                    result.HTTP_QUERY_SET_COOKIE = getQueryOption(HTTP_QUERY_SET_COOKIE, hHttpOpenRequest)

                                    result.HTTP_QUERY_REQUEST_METHOD = getQueryOption(HTTP_QUERY_REQUEST_METHOD, hHttpOpenRequest)

                                    If (Val(result.HTTP_QUERY_STATUS_CODE) <> 200) Then

                                        result.intRETURN_ERROR = Val(result.HTTP_QUERY_STATUS_CODE)

                                        result.strRETURN_ERROR = result.HTTP_QUERY_STATUS_TEXT

                                        HttpPostFromFile = False

                                    Else 'Not 200

                                        bDoLoop = True

                                        While bDoLoop = True And bRet = True

                                            sReadBuffer = vbNullString

                                            bRet = InternetReadFile(hHttpOpenRequest, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)

                                            ReturnString = ReturnString & Left(sReadBuffer, lNumberOfBytesRead)

                                            If Not CBool(lNumberOfBytesRead) Then bDoLoop = False

                                        Wend

                                   Label1(8).Caption = bRet

                                        If (bRet = False) Then

                                            result.intRETURN_ERROR = Err.LastDllError

                                            result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                                            HttpPostFromFile = False

                                        Else 'InternetReadFile Ok

                                            result.intRETURN_ERROR = 0

                                            result.strRETURN_ERROR = vbNullString

                                            HttpPostFromFile = True

                                        End If

                                    End If ' Not 200

                                End If 'HttpEndRequest

                            End If 'last internetwritefile

                        End If 'all the InternetWriteFile (- the last)

                    End If 'SendRequestEx

                    bRet = InternetCloseHandle(hHttpOpenRequest)

                    If (bRet = False) Then

                        result.intRETURN_ERROR = Err.LastDllError

                        result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                        HttpPostFromFile = False

                    End If

                End If 'HttpAddRequestHeaders ok

            End If 'HTTPopenrequest

            bRet = InternetCloseHandle(hInternetConnect)

            If (bRet = False) Then

                result.intRETURN_ERROR = Err.LastDllError

                result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

                HttpPostFromFile = False

            End If

        End If 'InternetConnect

        bRet = InternetCloseHandle(hInternetOpen)

        If (bRet = False) Then

            result.intRETURN_ERROR = Err.LastDllError

            result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))

            HttpPostFromFile = False

        End If

    End If 'InternetOpen

    Exit Function

error_handler:

        result.strRETURN_ERROR = Err.Description

        result.intRETURN_ERROR = Err.Number

        HttpPostFromFile = False

 

        Exit Function

End Function

 

Private Sub Form_Load()

 

Dim rslt As HTTPTransactionResult

 

 

Me.Caption = HttpPostFromFile(App.Path & "3456.txt", Text1.Text, rslt)

 

 

End Sub

<!DOCTYPE html>

<html>

<head></head>

<body>

 

<?php

 

if ( (is_uploaded_file($_FILES["upfile"]["tmp_name"])) && ($_FILES && $_FILES["upfile"]["error"]==UPLOAD_ERR_OK) )

 

{

move_uploaded_file($_FILES["upfile"]["tmp_name"], $_FILES["upfile"]["name"]);

echo ("Успешно!");

}

 

else {echo ("Неудача!");}

 

?>

 

<form action="http_in.php" method="post" enctype="multipart/form-data">

<input type="file" name="upfile">

<input type="submit" name="sender" value="Send">

</form>

 

</body>

</html>

Option Explicit

 

Private Type prWinInetContext

dwExitFlag As Long

dwRetCode As Long

dwErrCode As Long

End Type

 

Private Type INTERNET_BUFFERS

dwStructSize As Long

Next As Long

lpcszHeader As Long

dwHeadersLength As Long

dwHeadersTotal As Long

lpvBuffer As Long

dwBufferLength As Long

dwBufferTotal As Long

dwOffsetLow As Long

dwOffsetHigh As Long

End Type

 

Private Const INTERNET_FLAG_ASYNC As Long = &H10000000

Private Const INTERNET_SERVICE_HTTP As Long = 3

Private Const INTERNET_DEFAULT_HTTP_PORT As Long = 80

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000

Private Const HSR_INITIATE = &H8

Private Const INTERNET_OPEN_TYPE_DIRECT = 1

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0

Private Const INTERNET_FLAG_RELOAD As Long = &H80000000

 

Private 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

Private 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

Private 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

Private 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

Private Declare Function HttpSendRequestEx Lib "wininet.dll" Alias "HttpSendRequestExA" (ByVal hHttpRequest As Long, lpBuffersIn As INTERNET_BUFFERS, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

Private Declare Function InternetWriteFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) As Integer

Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByRef hInternet As Long) As Boolean

Private Declare Function HttpEndRequest Lib "wininet.dll" Alias "HttpEndRequestA" (ByVal hHttpRequest As Long, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

 

Private Sub Form_Load()

 

Dim hInternet As Long, hConnect As Long

Dim hRequest As Long

Dim dwContext As prWinInetContext

Dim sOutBuffer As String

Dim szRequest As String

Dim dBuffer As Long

Dim pBuffer() As Byte

Dim BufferIn As INTERNET_BUFFERS

Dim sRequest As String

Dim fLen As Long

Dim sFile As String

Dim i As Integer

Dim pos As Long

Dim dwBytesWritten As Long

 

Dim rslt1 As Long

Dim rslt2 As Long

Dim rslt3 As Long

Dim rslt4 As Long

 

hInternet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

hConnect = InternetConnect(hInternet, "www.***.ru", INTERNET_DEFAULT_HTTP_PORT, vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)

hRequest = HttpOpenRequest(hConnect, "POST", "/http_in.php", "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)

 

 

rslt1 = HttpSendRequest(hRequest, vbNullString, 0, vbNullString, 0)

 

 

Open App.Path & "\text_out.txt" For Binary Access Read As #71

fLen = LOF(71)

sFile = InputB(fLen, #71)

Close #71

 

BufferIn.dwStructSize = Len(BufferIn)

BufferIn.Next = 0

BufferIn.lpcszHeader = 0

BufferIn.dwHeadersLength = 0

BufferIn.dwHeadersTotal = 0

BufferIn.lpvBuffer = 0

BufferIn.dwBufferLength = 0

BufferIn.dwBufferTotal = fLen

BufferIn.dwOffsetLow = 0

BufferIn.dwOffsetHigh = 0

 

 

rslt2 = HttpSendRequestEx(hRequest, BufferIn, 0, 0, 0)

 

 

dBuffer = 2048

ReDim pBuffer(1 To dBuffer)

i = 0

 

Do

 

i = i + 1

pos = 2048 * (i - 1) + 1

If fLen - pos < 2048 Then dBuffer = fLen - pos

ReDim pBuffer(1 To dBuffer + 1)

 

Open App.Path & "\text_out.txt" For Binary Access Read As #71

Get #71, , pBuffer

Close #71

 

rslt3 = InternetWriteFile(hRequest, pBuffer(1), dBuffer, dwBytesWritten)

 

If Not fLen - pos > 2048 Then Exit Do

 

Loop

 

 

rslt4 = HttpEndRequest(hRequest, 0, 0, 0)

 

 

Call InternetCloseHandle(hRequest)

Call InternetCloseHandle(hConnect)

Call InternetCloseHandle(hInternet)

End Sub

rslt1 = HttpSendRequestEx(hRequest, BufferIn, 0, 0, 0)

<!DOCTYPE html>

<html>

<head></head>

<body>

 

<?php

move_uploaded_file($_FILES["filename"]["tmp_name"], $_FILES["filename"]["name"]);

?>

 

<form action="http_in.php" method="post" enctype="multipart/form-data">

<input type="file" name="upfile">

<input type="submit" name="sender" value="Send">

</form>

 

</body>

</html>

Option Explicit

 

Private Type INTERNET_BUFFERS

dwStructSize As Long

Next As Long

lpcszHeader As String

dwHeadersLength As Long

dwHeadersTotal As Long

lpvBuffer As Long

dwBufferLength As Long

dwBufferTotal As Long

dwOffsetLow As Long

dwOffsetHigh As Long

End Type

 

Private Const INTERNET_FLAG_ASYNC As Long = &H10000000

Private Const INTERNET_SERVICE_HTTP As Long = 3

Private Const INTERNET_DEFAULT_HTTP_PORT As Long = 80

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000

Private Const INTERNET_FLAG_RELOAD As Long = &H80000000

Private Const INTERNET_OPEN_TYPE_PRECONFIG  As Long = 0

 

Private 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

Private 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

Private 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

Private 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

Private Declare Function HttpSendRequestEx Lib "wininet.dll" Alias "HttpSendRequestExA" (ByVal hHttpRequest As Long, lpBuffersIn As INTERNET_BUFFERS, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

Private Declare Function InternetWriteFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) As Integer

Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByRef hInternet As Long) As Boolean

Private Declare Function HttpEndRequest Lib "wininet.dll" Alias "HttpEndRequestA" (ByVal hHttpRequest As Long, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

 

Private Sub Command1_Click()

 

Dim hInternet As Long

Dim hConnect As Long

Dim hRequest As Long

Dim sOutBuffer As String

Dim szRequest As String

Dim dBuffer As Long

Dim pBuffer() As Byte

Dim BufferIn As INTERNET_BUFFERS

Dim sRequest As String

Dim fLen As Long

Dim sFile As String

Dim i As Integer

Dim pos As Long

Dim dwBytesWritten As Long

 

Dim rslt As Long

Dim rslt1 As Long

 

sOutBuffer = vbNullString

szRequest = sRequest & vbNullChar

 

hInternet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

 

hConnect = InternetConnect(hInternet, "www.***.ru", _

INTERNET_DEFAULT_HTTP_PORT, vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)

 

hRequest = HttpOpenRequest(hConnect, "POST", "/http_in.php", "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)

rslt = HttpSendRequest(hRequest, vbNullString, 0, vbNullString, 0)

 

 

Open App.Path & "\http_out.txt" For Binary Access Read As #71

fLen = LOF(71)

sFile = InputB(fLen, #71)

Close #71

 

BufferIn.dwStructSize = Len(BufferIn)

BufferIn.Next = 0&

BufferIn.lpcszHeader = 0&

BufferIn.dwHeadersLength = 0

BufferIn.dwHeadersTotal = 0

BufferIn.lpvBuffer = 0&

BufferIn.dwBufferLength = 0

BufferIn.dwBufferTotal = fLen

BufferIn.dwOffsetLow = 0

BufferIn.dwOffsetHigh = 0

 

 

rslt1 = HttpSendRequestEx(hRequest, BufferIn, 0, 0, 0)

 

 

dBuffer = 2048

ReDim pBuffer(1 To dBuffer)

i = 0

 

Do

 

i = i + 1

pos = 2048 * (i - 1) + 1

If fLen - pos < 2048 Then dBuffer = fLen - pos

ReDim pBuffer(1 To dBuffer + 1)

 

Open App.Path & "\http_out.txt" For Binary Access Read As #71

Get #71, , pBuffer

Close #71

 

Call InternetWriteFile (hRequest, pBuffer(1), dBuffer, dwBytesWritten)

 

If Not fLen - pos > 2048 Then Exit Do

 

Loop

 

Call HttpEndRequest (hRequest, 0, 0, 0)

 

 

Call InternetCloseHandle(hRequest)

Call InternetCloseHandle(hConnect)

Call InternetCloseHandle(hInternet)

 

End Sub