На главную
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
15 мая "Исходники.РУ" отмечают 20-летие присутствия в сети!
Поздравляем всех причастных и неравнодушных с юбилеем сайта!
И огромное спасибо всем, кто был с нами все эти годы!
msm.ru
! Правила раздела Visual Basic: Общие вопросы
Здесь обсуждаются вопросы по языку Visual Basic 1-6 (а так же по схожим языкам, как, например, PowerBASIC).
Вопросы по Visual Basic .NET (это который входит в состав Visual Studio 2002/2003/2005/2008+, для тех, кто не в курсе) обсуждаются в разделе .NET.

Обратите внимание:
1. Прежде чем начать новую тему или отправить сообщение, убедитесь, что Вы не нарушаете правил форума!
2. Обязательно воспользуйтесь поиском. Возможно, Ваш вопрос уже обсуждали. Полезные ссылки приведены ниже.
3. Темы с просьбой выполнить какую-либо работу за автора в этом разделе не обсуждаются. Студенты, вам сюда: ПОМОЩЬ СТУДЕНТАМ!
4. Используйте теги [ code=vba ] ...текст программы... [ /code ] для выделения текста программы подсветкой.
5. Помните, здесь телепатов нет. Формулируйте свой вопрос максимально грамотно и чётко: Как правильно задавать вопросы
6. Запрещено отвечать в темы месячной (и более) давности, без веских на то причин.

Полезные ссылки:
user posted image FAQ Сайта user posted image FAQ Раздела user posted image Кладовка user posted image Наши Исходники user posted image API-Guide user posted image Поиск по Разделу user posted image MSDN Library Online user posted image Google

Ваше мнение о модераторах: user posted image SCINER, user posted image B.V.
Модераторы: SCINER, B.V.
  
> Отправка TXT-файла по HTTP, методом POST на WINAPI
Здравствуйте! Всех с Днём Победы!

Есть PHP-файл на сервере с формой отправки файла, и есть локальный файл для передачи на сервер. Не могу разобраться, как корректно вызвать функцию HttpSendRequestEx. Параметр rslt1 равен нулю.
ExpandedWrap disabled
    rslt1 = HttpSendRequestEx(hRequest, BufferIn, 0, 0, 0)


Файл http_in.php:
ExpandedWrap disabled
    <!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>


Код, отправляющий файл на сервер:
ExpandedWrap disabled
    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


Подскажите, пожалуйста, в чём ошибка у меня?
Сообщение отредактировано: salieri -
log(2 ^ 232.582.657)-1 is prime!
Немного подкорректировал по немногочисленным примерам из интернета.
Проверил результаты функций: на выходе нуля больше нигде нет. Параметр dwBytesWritten в функции InternetWriteFile выдаёт определённое число отличное от нуля, но файл на сервере так и не появляется.
Помогите, пожалуйста.


Файл http_in.php:
ExpandedWrap disabled
    <!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>


Код, отправляющий файл на сервер:
ExpandedWrap disabled
    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
Сообщение отредактировано: salieri -
log(2 ^ 232.582.657)-1 is prime!
Вопрос с отправкой файла решён!
Всем огромное спасибо!

Файл, который я отправляю на сервер, я прикрепил к письму.
Вроде, ещё нужно, наверное, случайным образом Boundary получать, но это отдельный вопрос. Пока и так работает всё.

ExpandedWrap disabled
    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 & "\123456.txt", Text1.Text, rslt)
     
     
    End Sub

Прикреплённый файлПрикреплённый файл123456.txt (26,61 Кбайт, скачиваний: 4)
log(2 ^ 232.582.657)-1 is prime!
1 пользователей читают эту тему (1 гостей и 0 скрытых пользователей)
0 пользователей:


Рейтинг@Mail.ru
[ Script Execution time: 0,1393 ]   [ 22 queries used ]   [ Generated: 31.05.20, 09:07 GMT ]