На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
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 -
      Немного подкорректировал по немногочисленным примерам из интернета.
      Проверил результаты функций: на выходе нуля больше нигде нет. Параметр 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 -
        Вопрос с отправкой файла решён!
        Всем огромное спасибо!

        Файл, который я отправляю на сервер, я прикрепил к письму.
        Вроде, ещё нужно, наверное, случайным образом 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 Кбайт, скачиваний: 151)
        0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
        0 пользователей:


        Рейтинг@Mail.ru
        [ Script execution time: 0,0387 ]   [ 19 queries used ]   [ Generated: 28.03.24, 12:19 GMT ]