Delphi,发布WinInet并跟踪上传进度

Question

如何发布帖子请求并跟踪进度？

这不起作用(查看评论):

procedure StatusCallback(
  hInet:        HINTERNET;
  Context:      DWORD_PTR;
  Status:       DWORD;
  pInformation: Pointer;
  InfoLength:   DWORD ); stdcall;
var
  s: string;
  c: Cardinal;
begin
  case Status of
    INTERNET_STATUS_CLOSING_CONNECTION: s := 'Closing the connection to the server';
    INTERNET_STATUS_CONNECTED_TO_SERVER: s := 'Successfully connected to the socket address: ';
    INTERNET_STATUS_CONNECTING_TO_SERVER: s := 'Connecting to the socket address';
    INTERNET_STATUS_CONNECTION_CLOSED: s := 'Successfully closed the connection to the server';
    INTERNET_STATUS_CTL_RESPONSE_RECEIVED: s := 'Not implemented';
    INTERNET_STATUS_HANDLE_CLOSING: s := 'This handle value has been terminated';
    INTERNET_STATUS_HANDLE_CREATED: s := 'InternetConnect has created the new handle';
    INTERNET_STATUS_INTERMEDIATE_RESPONSE: s :=
      'Received an intermediate (100 level) status code message from the server';
    INTERNET_STATUS_NAME_RESOLVED: s := 'Successfully found the IP address: ' + PAnsiChar(pInformation);
    INTERNET_STATUS_PREFETCH: s := 'Not implemented';
    INTERNET_STATUS_RECEIVING_RESPONSE: s := 'Waiting for the server to respond to a request ';
    INTERNET_STATUS_REDIRECT: s := 'HTTP request is about to automatically redirect the request ' +
      PAnsiChar(pInformation);
    INTERNET_STATUS_REQUEST_COMPLETE: s := 'An asynchronous operation has been completed';
    INTERNET_STATUS_REQUEST_SENT: s := 'Successfully sent the information request to the server: ' +
      IntToStr(NativeUInt(pInformation)) + ' Byte';
    INTERNET_STATUS_RESOLVING_NAME: s := 'Looking up the IP address: ' + PAnsiChar(pInformation);
    INTERNET_STATUS_RESPONSE_RECEIVED: s := 'Successfully received a response from the server: ' +
      IntToStr(NativeUInt(pInformation)) + ' Byte';
    INTERNET_STATUS_SENDING_REQUEST: s := 'Sending the information request to the server.';
    INTERNET_STATUS_STATE_CHANGE:
      begin
        s := 'Moved between a secure (HTTPS) and a nonsecure (HTTP) site.';
        case DWORD(pInformation) of
          INTERNET_STATE_CONNECTED: s := s + #13#10 + 'Connected state. Mutually exclusive with disconnected state.';
          INTERNET_STATE_DISCONNECTED: s := s + #13#10 +
            'Disconnected state. No network connection could be established.';
          INTERNET_STATE_DISCONNECTED_BY_USER: s := s + #13#10 + 'Disconnected by user request.';
          INTERNET_STATE_IDLE: s := s + #13#10 + 'No network requests are being made by Windows Internet.';
          INTERNET_STATE_BUSY: s := s + #13#10 + 'Network requests are being made by Windows Internet.';
        end;
      end;
  end;
  tss.Add(s);
end;

function Https_Post(var callSettings: httpCallSettings; xServer,xRes: string): Integer;
const
  BufferSize=1024*64;
var
  hInet    : HINTERNET;
  hConnect : HINTERNET;
  hRequest : HINTERNET;
  dwc: UInt64;
  ErrorCode : Integer;
  lpdwBufferLength: DWORD;
  lpdwReserved    : DWORD;
  dwBytesRead     : DWORD;
  lpdwNumberOfBytesAvailable: DWORD;
  heads: ansistring;
  header: TStringStream;
begin
tss := tstringlist.Create;
  Result   :=0;
  callSettings.Response :='';
  hInet    := InternetOpen(PChar(callSettings.uAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if hInet=nil then
  begin
    ErrorCode:=GetLastError;
    raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
  end;

  try
    hConnect := InternetConnect(hInet, PChar(xServer), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, dwc);
    if hConnect=nil then
    begin
      ErrorCode:=GetLastError;
      raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
    end;

    try
      hRequest := HttpOpenRequest(hConnect, 'POST', PChar(xRes), HTTP_VERSION, '', nil, INTERNET_FLAG_SECURE, dwc);
      if hRequest=nil then
      begin
        ErrorCode:=GetLastError;
        raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
      end;

      try

      Header := TStringStream.Create('');
      with Header do
        begin
          WriteString('Host: ' + xServer + sLineBreak);
          WriteString('User-Agent: '+ callSettings.uAgent + SLineBreak);
          WriteString('Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8'+SLineBreak);
          WriteString('Accept-Language: en-us,en;q=0.5' + SLineBreak);
          WriteString('Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7'+SLineBreak);
          WriteString('Keep-Alive: 300'+ SLineBreak);
          if callSettings.ExtraHeader <> '' then WriteString(callSettings.ExtraHeader + SlineBreak);
          if callSettings.CType <> ''       then WriteString('Content-Type: ' + callSettings.cType + SlineBreak);
          WriteString('Connection: keep-alive'+ SlineBreak + SlineBreak);
        end;

        HttpAddRequestHeaders(hRequest, PChar(Header.DataString), Length(Header.DataString), HTTP_ADDREQ_FLAG_ADD);

        InternetSetStatusCallback( hRequest, @StatusCallback );

        //send the post request
        if not HTTPSendRequest(hRequest, nil, 0, @callSettings.postvars[1], Length(callSettings.postvars)) then
        begin
          ErrorCode:=GetLastError;
          raise Exception.Create(Format('HttpSendRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
        end;

          lpdwBufferLength:=SizeOf(Result);
          lpdwReserved    :=0;
          //get the response code
          if not HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @Result, lpdwBufferLength, lpdwReserved) then
          begin
            ErrorCode:=GetLastError;
            raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
          end;

         CallSettings.CallStatus := Result;
         //if the response code =200 then get the body
         if Result=200 then
          if InternetQueryDataAvailable(hRequest, lpdwNumberOfBytesAvailable, 0, 0) then
          begin
            SetLength(callSettings.response,lpdwNumberOfBytesAvailable);
            InternetReadFile(hRequest, @callSettings.response[1], lpdwNumberOfBytesAvailable, dwBytesRead);
          end
          else
          begin
            ErrorCode:=GetLastError;
            raise Exception.Create(Format('InternetQueryDataAvailable Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
          end;

      finally
        InternetCloseHandle(hRequest);
      end;
    finally
      InternetCloseHandle(hConnect);
    end;
  finally
    InternetCloseHandle(hInet);
  end;
  showmessage(tss.Text);
end;

Run Code Online (Sandbox Code Playgroud)

Answer 1

Rem*_*eau 5

用于InternetSetStatusCallback()向HTTP会话注册回调函数,以在请求操作的各个阶段接收状态信息.

请注意文档中的以下警告:

注意在指定的回调函数lpfnInternetCallback参数将不会在为请求手柄异步操作当被叫dwContext的参数HttpOpenRequest被设置为零(INTERNET_NO_CALLBACK)当连接句柄,或dwContext的手柄InternetConnect被设置为零(INTERNET_NO_CALLBACK).

尝试更像这样的东西:

function SockAddrToString(pAddr: LPSOCKADDR; AddrSize: DWORD): String;
var
  Buf: array[0..40] of Char;
  Len: DWORD;
begin
  Result := '';
  Len := Length(Buf);
  if WSAAddressToString(pAddr, AddrSize, nil, Buf, Len) = 0 then
    SetString(Result, Buf, Len-1);
end;

procedure StatusCallback(
  hInet:        HINTERNET;
  Context:      DWORD_PTR;
  Status:       DWORD;
  pInformation: Pointer;
  InfoLength:   DWORD ); stdcall;
var
  s: string;
begin
  case Status of
    INTERNET_STATUS_CLOSING_CONNECTION: s := 'Closing the connection to the server';
    INTERNET_STATUS_CONNECTED_TO_SERVER: s := 'Successfully connected to the socket address: ' + SockAddrToString(PSOCKADDR(pInformation), InfoLength);
    INTERNET_STATUS_CONNECTING_TO_SERVER: s := 'Connecting to the socket address: ' + SockAddrToString(PSOCKADDR(pInformation), InfoLength);
    INTERNET_STATUS_CONNECTION_CLOSED: s := 'Successfully closed the connection to the server';
    INTERNET_STATUS_CTL_RESPONSE_RECEIVED: s := 'Not implemented';
    INTERNET_STATUS_HANDLE_CLOSING: s := 'This handle value has been terminated';
    INTERNET_STATUS_HANDLE_CREATED: s := 'InternetConnect has created the new handle';
    INTERNET_STATUS_INTERMEDIATE_RESPONSE: s := 'Received an intermediate (100 level) status code message from the server';
    INTERNET_STATUS_NAME_RESOLVED: s := 'Successfully found the IP address: ' + PAnsiChar(pInformation);
    INTERNET_STATUS_PREFETCH: s := 'Not implemented';
    INTERNET_STATUS_RECEIVING_RESPONSE: s := 'Waiting for the server to respond to a request';
    INTERNET_STATUS_REDIRECT: s := 'HTTP request is about to automatically redirect the request ' +
      PAnsiChar(pInformation);
    INTERNET_STATUS_REQUEST_COMPLETE: s := 'An asynchronous operation has been completed';
    INTERNET_STATUS_REQUEST_SENT: s := 'Successfully sent the information request to the server: ' + IntToStr(PDWORD(pInformation)^) + ' Bytes';
    INTERNET_STATUS_RESOLVING_NAME: s := 'Looking up the IP address: ' + PAnsiChar(pInformation);
    INTERNET_STATUS_RESPONSE_RECEIVED: s := 'Successfully received a response from the server';
    INTERNET_STATUS_SENDING_REQUEST: s := 'Sending the information request to the server';
    INTERNET_STATUS_STATE_CHANGE:
      begin
        s := 'Moved between a secure (HTTPS) and a nonsecure (HTTP) site.';
        case PDWORD(pInformation)^ of
          INTERNET_STATE_CONNECTED: s := s + #13#10 + 'Connected state. Mutually exclusive with disconnected state.';
          INTERNET_STATE_DISCONNECTED: s := s + #13#10 + 'Disconnected state. No network connection could be established.';
          INTERNET_STATE_DISCONNECTED_BY_USER: s := s + #13#10 + 'Disconnected by user request.';
          INTERNET_STATE_IDLE: s := s + #13#10 + 'No network requests are being made by Windows Internet.';
          INTERNET_STATE_BUSY: s := s + #13#10 + 'Network requests are being made by Windows Internet.';
        end;
      end;
  end;
  tss.Add(s);
end;

procedure WinInetCheck(Success: Boolean; Function: PChar);
var
  ErrorCode : Integer;
begin
  if not Success then
  begin
    ErrorCode := GetLastError;
    raise Exception.CreateFmt('%s Error %d: %s', [Function, ErrorCode, GetWinInetError(ErrorCode)]);
  end;
end;

function Https_Post(var callSettings: httpCallSettings; xServer, xRes: string): Integer;
const
  BufferSize = 1024*64;
  AcceptTypes: array[0..] of PChar = ('text/html', 'application/xhtml+xml', 'application/xml;q=0.9', '*/*;q=0.8', nil);
var
  hInet    : HINTERNET;
  hConnect : HINTERNET;
  hRequest : HINTERNET;
  dwBufferLength: DWORD;
  dwReserved    : DWORD;
  dwBytesRead     : DWORD;
  dwNumberOfBytesAvailable: DWORD;
  Header: TStringStream;
  sHeader: String;
begin
  Result := 0;
  tss := TStringList.Create;
  try
    callSettings.Response := '';
    hInet := InternetOpen(PChar(callSettings.uAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
    WinInetCheck(hInet <> nil, 'InternetOpen');
    try
      hConnect := InternetConnect(hInet, PChar(xServer), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
      WinInetCheck(hConnect <> nil, 'InternetConnect');
      try
        hRequest := HttpOpenRequest(hConnect, 'POST', PChar(xRes), HTTP_VERSION, '', @AcceptTypes, INTERNET_FLAG_SECURE or INTERNET_FLAG_KEEP_CONNECTION, 1);
        WinInetCheck(hRequest <> nil, 'HttpOpenRequest');
        try    
          Header := TStringStream.Create('');
          try
            Header.WriteString('Accept-Language: en-us,en;q=0.5' + #13#10);
            Header.WriteString('Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7' + #13#10);
            Header.WriteString('Keep-Alive: 300' + #13#10);
            if callSettings.ExtraHeader <> '' then
              Header.WriteString(callSettings.ExtraHeader + #13#10);
            if callSettings.CType <> '' then
              Header.WriteString('Content-Type: ' + callSettings.cType + #13#10);
            sHeader := Header.DataString;
            WinInetCheck(HttpAddRequestHeaders(hRequest, PChar(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD), 'HttpAddRequestHeaders');
          finally
            Header.Free;
          end;

          InternetSetStatusCallback(hRequest, @StatusCallback);

          //send the post request
          WinInetCheck(HTTPSendRequest(hRequest, nil, 0, @callSettings.postvars[1], Length(callSettings.postvars)), 'HttpSendRequest');

          //get the response code
          dwBufferLength := SizeOf(Result);
          dwReserved := 0;
          WinInetCheck(HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @Result, dwBufferLength, dwReserved), 'HttpQueryInfo');    
          CallSettings.CallStatus := Result;

          //if the response code =200 then get the body
          if Result = 200 then
          begin
            WinInetCheck(InternetQueryDataAvailable(hRequest, dwNumberOfBytesAvailable, 0, 0), 'InternetQueryDataAvailable');
            SetLength(callSettings.response, dwNumberOfBytesAvailable);
            if dwNumberOfBytesAvailable <> 0 then
              WinInetCheck(InternetReadFile(hRequest, @callSettings.response[1], dwNumberOfBytesAvailable, dwBytesRead), 'InternetReadFile');
          end;
        finally
          InternetCloseHandle(hRequest);
        end;
      finally
        InternetCloseHandle(hConnect);
      end;
    finally
      InternetCloseHandle(hInet);
    end;
    ShowMessage(tss.Text);
  finally
    tss.Free;
  end;
end;

Run Code Online (Sandbox Code Playgroud)

归档时间：	9 年，8 月前
查看次数：	500 次
最近记录：	9 年，8 月前