Модераторы: Snowy, Poseidon, MetalFan
  

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Небольшая проблема с докачкой на WinInet 
V
    Опции темы
Zmiuko
  Дата 5.10.2012, 05:47 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


http://zmiuko.ru
**


Профиль
Группа: Участник
Сообщений: 297
Регистрация: 8.10.2008

Репутация: нет
Всего: 2



Доброго всем времени, уважаемые. У меня суть проблемы вот в чем.

Накидал несложный код, ниже представленный:

Код

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, WinInet, IdURI, Vcl.ComCtrls,
  Vcl.StdCtrls, Vcl.ExtCtrls;

const
  AgentB = 'Opera/9.80 (Windows NT 6.1; U; ru) Presto/2.7.62 Version/11.00';

type
  TRecivByte = procedure(Progres,MaxSiz :Int64) of object;// закачка-прогресс
  TDownloadError = (deInternetOpen, deInternetOpenUrl, deDownloadingFile, deConnect, deRequest);
  TErrorEvent = procedure(Sender: TObject; E: TDownloadError) of object; //на случай ошибки

type TTextThreat = class(TThread)
  private
    FText :string;
    FUserAgent :string;
    FUrl :string;
    FMem :TMemoryStream;
    FPrgPos, FPrgMax :Int64; // позиция, максимум | прогресс закачки
    FOnProgres :TRecivByte; // прогресс закачки
    procedure Updateprogres;
  protected
    procedure Execute; override;
  public
    constructor Create(const ATerminateHandler: TNotifyEvent=nil; PauseThread :Boolean=True);
    destructor Destroy;
    //
    property UserAgent:string read FUserAgent write FUserAgent;
    property URL:string read FUrl write FUrl;
    property ResultText:string read FText; // принятый текст
    property OnProgress:TRecivByte read FOnProgres write FOnProgres;
    property Terminated;
  published
end;

type TChkURLThreat = class(TThread)
  private
    FResult :Boolean;
    FUserAgent :string;
    FUrl :string;
  protected
    procedure Execute; override;
  public
    constructor Create(const ATerminateHandler: TNotifyEvent=nil; PauseThread :Boolean=True);
    //
    property UserAgent:string read FUserAgent write FUserAgent;
    property URL:string read FUrl write FUrl;
    property ChkResult:Boolean read FResult; // принятый текст
    property Terminated;
  published
end;

// function THTTPSender.GetQueryInfo(hRequest: Pointer; Flag: integer): string;
type TQueryThreat = class(TThread)
  private
    FResult :string;
    FUserAgent :string;
    FQuery :Integer; // тип запроса
    FUrl :string;
    function GetQueryInfo(hRequest :Pointer; Flag :integer):string;
  protected
    procedure Execute; override;
  public
    constructor Create(const ATerminateHandler: TNotifyEvent=nil; PauseThread :Boolean=True);
    //
    property UserAgent:string read FUserAgent write FUserAgent;
    property URL:string read FUrl write FUrl;
    property Query:Integer read FQuery write FQuery default HTTP_QUERY_CONTENT_LENGTH;
    property ResultText:string read FResult; // принятый текст
    property Terminated;
  published
end;


type TDownloadThread = class(TThread)
  private
    fURL: String;
    FUserAgent :string;
    FFilePath :string; // полный путь до локально сохраняемого файла
    FCurPos, FMaxPos :Int64; // текущая позиция, всего
    FStartFilePos :Int64; // начало файла, для закачки
    //
    err: TDownloadError;  // ошибка, лучше реализовать работу с константами. а вот стоит ли заморачиваться с исключениями не уверен, решай сам
    fError: TErrorEvent;
    fAccepted: TNotifyEvent;
    fOnProgres: TRecivByte; // прогресс загрузки
    fBreak: TNotifyEvent;
    procedure toError;
    procedure toAccepted;
    procedure toDownloading;
    procedure toBreak;
    function GetQueryInfo(hRequest :Pointer; Flag :integer):string;
 protected
    procedure Execute; override;
 public
    constructor Create(const ATerminateHandler: TNotifyEvent=nil; CreateSuspennded: Boolean=True); //создание потока. CreateSuspennded в тру - не дает запустится потоку сразу после создания (в таком случае поток запускается методом resume).
    property URL:string read fURL write fURL; // вдруг понадобится во время скачки
    property UserAgent:string read FUserAgent write FUserAgent;
    property StartPositon:Int64 read FStartFilePos write FStartFilePos default 0; // для докачки
    property FilePath:string read FFilePath write FFilePath;
    //
    property OnError:TErrorEvent read fError write fError; // еггог
    property OnAccepted:TNotifyEvent read fAccepted write fAccepted; // загрузка завершилась удачно, по адресу Stream из конструктора лежит скачанная страничка
    property OnProgres:TRecivByte read fOnProgres write fOnProgres; // загрузка завершилась удачно, по адресу Stream из конструктора лежит скачанная страничка
    property OnBreak:TNotifyEvent read fBreak write fBreak; // загрузка завершилась удачно, по адресу Stream из конструктора лежит скачанная страничка
    property Terminated;
end;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Image1: TImage;
    Label1: TLabel;
    Edit1: TEdit;
    Label2: TLabel;
    Edit2: TEdit;
    Button1: TButton;
    Button2: TButton;
    Label3: TLabel;
    ProgressBar1: TProgressBar;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    FDwnLoadThread :TDownloadThread; // качалка
    FUserStop :Boolean; // стоп
    //
    function CheckUrl(url: string): boolean;
    function GetQueryResult(URL, UserAgent :string; Mode :Integer=HTTP_QUERY_CONTENT_LENGTH):string;
    // размер файла
    function GetURLFileSize(Url :string):Int64;
    // дата изменения файла
    function GetURLLastModify(Url :string):string;
    // получить HTML текст страницы
    function GetHTMLPageText(Url :string):string;
    //
    procedure thrTerminate(Sender:TObject);
    procedure thrProgress(Progres,MaxSiz :Int64);
    //
    function GetSizTxt(I64: Int64): String;
    function ExtractUrlFileName(Url: string): string;
    function GetSelFileSize(Path: string): Int64;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TTextThreat }

constructor TTextThreat.Create(const ATerminateHandler: TNotifyEvent; PauseThread :Boolean);
begin
  inherited Create(PauseThread);
  FreeOnTerminate := False;
  Priority := tpNormal;
  OnTerminate := ATerminateHandler;
  FPrgPos := 0;
  FPrgMax := 0;
  FMem := TMemoryStream.Create;
end;

destructor TTextThreat.Destroy;
begin
  FMem.Clear;
  FreeAndNil(FMem);
end;

procedure TTextThreat.Execute;
const
  HTTP_PORT = 80;
  Header = 'Content-Type: application/x-www-form-urlencoded' + sLineBreak;
var
  FSession, FConnect, FRequest :HINTERNET;
  FHost, FScript :String;
  Ansi :PAnsiChar;
  Buff :array[0..1023]of Char;
  BytesRead :Cardinal;
  FileSiz :Cardinal; // размер файла
  FIdUrI :TIdURI;
  Lst :TStrings;
begin
  FText := '';
  if Trim(URL) = '' then
    Exit;
  if Pos('http://', LowerCase(FUrl)) = Length(FUrl) then
    Exit;
  //
  if Pos('http://', LowerCase(FUrl)) = 0 then
    FUrl := 'http://' + FUrl;
  Lst := TStringList.Create;
  FIdUrI := TIdURI.Create(FUrl);
  try
    FText := '';
    FPrgPos := 0;
    FPrgMax := 0;
    //
    FMem.Clear;
    FMem.Position := 0;
    //
    FHost := FIdUrI.Host;
    FScript := FUrl;
    FScript := Copy(FScript,
      Pos(FIdUrI.Host, FScript) + Length(FIdUrI.Host) + 1,
      MaxInt);
    // Инициализируем WinInet
    FSession := InternetOpen(PChar(FUserAgent),
      INTERNET_OPEN_TYPE_PRECONFIG, // PRE_CONFIG_INTERNET_ACCESS,
      nil,
      nil,
      INTERNET_FLAG_RELOAD);
    if not Assigned(FSession) then
      Exit;
    try
      // Попытка соединения с сервером
      FConnect := InternetConnect(FSession,
        PChar(FHost),
        HTTP_PORT,
        nil,
        'HTTP/1.1',
        INTERNET_SERVICE_HTTP,
        0,
        0);
      if not Assigned(FConnect) then Exit;
      try
        // Подготавливаем запрос страницы
        Ansi := 'text/*';
        FRequest := HttpOpenRequest(FConnect,
          'GET',
          PChar(FScript),
          'HTTP/1.1',
          '',
          @Ansi,
          INTERNET_FLAG_RELOAD,
          0);
        if not Assigned(FConnect) then
          Exit;
        try
          // Добавляем заголовки
          if not (HttpAddRequestHeaders(FRequest,
            Header,
            Length(Header),
            HTTP_ADDREQ_FLAG_REPLACE or
            HTTP_ADDREQ_FLAG_ADD)) then
            Exit;
          // Отправляем запрос
          if not (HttpSendRequest(FRequest, nil, 0, nil, 0)) then
            Exit;
          // размер файла
          InternetQueryDataAvailable(FRequest, FileSiz, 0, 0);
          FPrgMax := FileSiz;
          // Получаем ответ
          FillChar(Buff, SizeOf(Buff), 0);
        repeat
          // FText := FText + Buff;
          FillChar(Buff, SizeOf(Buff), 0);
          InternetReadFile(FRequest, @Buff, SizeOf(Buff), BytesRead);
          FMem.Write(Buff, BytesRead);
          // сколько скачали
          FPrgPos := FPrgPos + BytesRead;
          Synchronize(Updateprogres);
        until BytesRead = 0;
          //
          FMem.Position := 0;
          Lst.LoadFromStream(FMem);
          FText := Lst.Text;
        finally
          InternetCloseHandle(FRequest);
        end;
      finally
        InternetCloseHandle(FConnect);
      end;
    finally
      InternetCloseHandle(FSession);
    end;
    //
    Sleep(1000);
  finally
    try
      FreeAndNil(FIdUrI);
      Lst.Clear;
      FreeAndNil(Lst);
    finally
      Terminate;
    end;
  end;
end;

procedure TTextThreat.Updateprogres;
begin // обновит прогресс
  if Assigned(FOnProgres) then
    FOnProgres(FPrgPos, FPrgMax);
end;

{ TChkURLThreat }

constructor TChkURLThreat.Create(const ATerminateHandler: TNotifyEvent; PauseThread: Boolean);
begin
  inherited Create(PauseThread);
  FreeOnTerminate := False;
  Priority := tpNormal;
  OnTerminate := ATerminateHandler;
end;

procedure TChkURLThreat.Execute;
var
  hSession, hfile, hRequest :hInternet;
  dwindex, dwcodelen :dword;
  dwcode :array[1..20]of char;
  res :pchar;
begin
  FResult := False;
  if Trim(FUrl) = '' then
    Exit;
  try
    if Pos('http://', LowerCase(FUrl)) = 0 then
      FUrl := 'http://' + FUrl;
    FResult := False;
    hSession := InternetOpen(PChar(FUserAgent),
      INTERNET_OPEN_TYPE_PRECONFIG,
      nil,
      nil,
      0);
    if assigned(hsession) then begin
      hfile := InternetOpenUrl(hsession,
        pchar(url),
        nil,
        0,
        INTERNET_FLAG_RELOAD,
        0);
      dwIndex := 0;
      dwCodeLen := 10;
      HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
      res := pchar(@dwcode);
      FResult := (res = '200') or (res = '302');
      if assigned(hfile) then
        InternetCloseHandle(hfile);
      InternetCloseHandle(hsession);
    end;
    //
    Sleep(1000);
  finally
    Terminate;
  end;
end;

{ TDownloadThread }

constructor TDownloadThread.Create(const ATerminateHandler: TNotifyEvent;
   CreateSuspennded: Boolean);
begin
 inherited Create(CreateSuspennded); //метод предка
 FreeOnTerminate := False; //очистка при уничтожении
 OnTerminate := ATerminateHandler;
 fURL := URL; //запоминаем урл
 FCurPos := 0; // позиция в фйале
 FMaxPos := 0; // размер файла
 FStartFilePos := -1; // установка позиции. автомат
end;

procedure TDownloadThread.Execute;
var
  pInet, pConnect, pUrl, pRequest :Pointer;
  Buffer :array[0..1024]of Byte;
  BytesRead :Cardinal; //количество прочитанных байт
  SumSize :Cardinal; // размер файла на сервере
  Header :string;
  i :Integer;
  Fs :TFileStream;
  //
  BufMaxLen :string; // ответ от Query запроса размера файла
begin
  //
  FCurPos := 0;
  FMaxPos := 0;
  //
  try
    if not FileExists(FFilePath) then begin
        try
          Fs := TFileStream.Create(FFilePath, fmCreate);
        except
          Exit;
        end;
    end
    else
      begin
        try
          Fs := TFileStream.Create(FFilePath, fmOpenReadWrite);
        except
          Exit;
      end;
    // установка позиции в файле | докачка
    if FStartFilePos >= 0 then // если -1, пропускаем установку
      begin // вручную указанная позиция начала закачки
        FCurPos := FStartFilePos;
        Fs.Position := FStartFilePos;
      end
    else
      if Fs.Size > 0 then // нужно ли докачивать
        begin // автоопределение места начала закачки | в конец файла - буффер
          FCurPos := Fs.Size - Length(Buffer);
          Fs.Position := Fs.Size- Length(Buffer);
        end
      else
        begin // в начало файла
          FCurPos := 0;
          Fs.Position := 0;
        end;
      end;
    //  ShowMessage(Format('Файл: %s'#13'Fs.Size: %d'#13 +
    //  'Fs.Position: %d'#13 +
    //  'FCurPos: %d'#13'FMaxPos: %d',
    //  [FFilePath, Fs.Size, Fs.Position, FCurPos, FMaxPos])
    //  );
    //
    pInet := InternetOpen(PChar(FUserAgent),
      INTERNET_OPEN_TYPE_PRECONFIG,
      nil,
      nil,
      0);
    if pInet = nil then begin //если сессия не открылась
      err := deInternetOpen;
      Synchronize(toError);
      Exit;
    end;
    try
      Header := Format('User-Agent: %s'#13 +
        'Accept: */*'#13 +
        'Connection: keep-alive'#13 +
        'Range: bytes=%d-', [FUserAgent, FCurPos]);
      pUrl := InternetOpenUrl(pInet,
        PChar(URL),
        PChar(Header),
        Length(Header),
        INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_RELOAD,
        0);
      if pUrl = nil then //если не достучались до урл
      begin
        err := deInternetOpenUrl;
        Synchronize(toError);
        Exit;
      end;
      // размер файла на сервере | после "Range: bytes=%d-" выдаст, сколько осталось
      BufMaxLen := GetQueryInfo(pUrl, HTTP_QUERY_CONTENT_LENGTH);
      SumSize := StrToInt64Def(BufMaxLen, 0);
      // полный размер файла на сервере
      if SumSize > 0 then
        Inc(SumSize, FCurPos)
      else
        if (SumSize = 0) then // в конце файла | дадим размер файла
          SumSize := FCurPos;
      FMaxPos := SumSize;
      //
      // прогресс
      Synchronize(toDownloading);
      // Сместимся в файле
      // v1
      // if FCurPos > 0 then
      //  InternetSetFilePointer(pURL, FCurPos, nil, FILE_BEGIN, 0);
      // v2
      // if FCurPos > 0 then
      //    HttpSendRequest(pURL,
      //      PChar(Format('Range: bytes=%d-', [FCurPos])),
      //      Length(Format('Range: bytes=%d-', [FCurPos])),
      //      nil,
      //      0);
      // закачка
      Repeat
        // остановка загрузки
        if Terminated then
          Break;
        FillChar(Buffer, SizeOf(Buffer), 0); //заполняем буфер нолями
        if InternetReadFile(pUrl, @Buffer, Length(Buffer), BytesRead) then begin
          Fs.Write(Buffer, BytesRead); //пишем буфер в поток если прочитали
          // прогресс
          // FCurPos := Fs.Size;
          Inc(FCurPos, BytesRead);
          Synchronize(toDownloading);
        end
        else
        begin //если прочитать не удалось
          err := deDownLoadingFile;
          Synchronize(toError);
          Exit;
        end;
        Until (BytesRead = 0); //прочитано все
      finally
        if pUrl <> nil then //открывалось успешно?
          InternetCloseHandle(pUrl); //закрываем
        if pRequest <> nil then //открывалось успешно?
          InternetCloseHandle(pRequest); //закрываем
        if pConnect <> nil then //открывалось успешно?
          InternetCloseHandle(pConnect); //закрываем
        if pInet <> nil then //открывалось успешно?
          InternetCloseHandle(pInet); //закрываем
        end;
        if Terminated then
          Synchronize(toBreak)
        else
          Synchronize(toAccepted);  //сообщаем об успешном завершении
        Sleep(1000);
  finally
    FreeAndNil(Fs);
    Terminate;
  end;
end;

function TDownloadThread.GetQueryInfo(hRequest: Pointer; Flag: integer): string;
var
  code :String;
  size,index :Cardinal;
begin
  Result := '';
  SetLength(code, 8); // достаточная длина для чтения статус-кода
  size := Length(code);
  index := 0;
  if HttpQueryInfo(hRequest, Flag, PChar(code), size, index) then
    Result := Code
  else
    if (GetLastError = ERROR_INSUFFICIENT_BUFFER) then // увеличиваем буффер
    begin
      SetLength(code, size);
      size := Length(code);
      if HttpQueryInfo(hRequest, Flag, PChar(code), size, index) then
        Result := code;
    end
  else
    Result := '';
end;

procedure TDownloadThread.toAccepted;
begin
  if Assigned(fAccepted) then
    fAccepted(Self);
end;

procedure TDownloadThread.toBreak;
begin
  if Assigned(fBreak) then
    fBreak(Self);
end;

procedure TDownloadThread.toDownloading;
begin
  if Assigned(fOnProgres) then
    fOnProgres(FCurPos, FMaxPos);
end;

procedure TDownloadThread.toError;
begin
  if Assigned(fError) then
    OnError(Self, err);
end;

{ TQueryThreat }

constructor TQueryThreat.Create(const ATerminateHandler: TNotifyEvent; PauseThread: Boolean);
begin
  inherited Create(PauseThread);
  FreeOnTerminate := False;
  Priority := tpNormal;
  OnTerminate := ATerminateHandler;
  // длина
  FQuery := HTTP_QUERY_CONTENT_LENGTH;
end;

procedure TQueryThreat.Execute;
const
  BufferSize = 1024;
var
  hSession, hURL :HInternet;
  Buffer :array[1..BufferSize]of byte;
  BufferLen :DWORD;
begin
  try
    if Trim(FUrl) = '' then
      Exit;
    //
    if Pos('http://', LowerCase(FUrl)) = 0 then
      FUrl := 'http://' + FUrl;
    //
    if Pos('http://', LowerCase(FUrl)) = Length(FUrl) then
      Exit;
    //
    hSession := InternetOpen(PChar(FUserAgent),
      INTERNET_OPEN_TYPE_PRECONFIG,
      nil,
      nil,
      0);
    if Assigned(hSession) then begin
      try
        hURL := InternetOpenURL(hSession,
          PChar(FUrl),
          nil,
          0,
          0,
          0);
        if Assigned(hURL) then begin
          try
            FResult := GetQueryInfo(hURL, FQuery);
          finally
            InternetCloseHandle(hURL);
          end;
        end;
      finally
        InternetCloseHandle(hSession);
      end;
    end;
    Sleep(1000);
  finally
    Terminate;
  end;
end;

function TQueryThreat.GetQueryInfo(hRequest: Pointer; Flag: integer): string;
var
  code :String;
  size,index :Cardinal;
begin
  Result := '';
  SetLength(code, 8); // достаточная длина для чтения статус-кода
  size := Length(code);
  index := 0;
  if HttpQueryInfo(hRequest, Flag, PChar(code), size, index) then
    Result := Code
  else
  if (GetLastError = ERROR_INSUFFICIENT_BUFFER) then // увеличиваем буффер
  begin
    SetLength(code, size);
    size := Length(code);
    if HttpQueryInfo(hRequest, Flag, PChar(code), size, index) then
      Result := code;
  end
  else
    Result := '';
end;

function TForm1.ExtractUrlFileName(Url: string): string;
var
  A :LongInt;
begin
  // извлечь название файла из ссылки
  Result := '';
  A := LastDelimiter('/', Url);
  if (A > 0) and (Url[A] = '/') then
    Result := Copy(Url, A + 1, Length(Url) - A);
end;

function TForm1.GetSelFileSize(Path: string): Int64;
var
  Fs :TFileStream;
begin
  // размер файла на диске
  Result := -1;
  if Not FileExists(Path) then
    Exit;
  Fs := TFileStream.Create(Path, fmOpenRead);
  try
    Result := Fs.Size;
  finally
    FreeAndNil(Fs);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  SavFilePath :string;
begin
  Button1.Enabled := False;
  FDwnLoadThread := TDownloadThread.Create(thrTerminate, True);
  try
    if not CheckUrl(Edit1.Text) then begin
      ShowMessage('файла по ссылке нет');
      Exit;
    end;
    if not DirectoryExists(Edit2.Text) then begin
      ShowMessage('Директория не выбрана');
      Exit;
    end;
    Button2.Enabled := True;
    SavFilePath := IncludeTrailingBackslash(Edit2.Text) + ExtractUrlFileName(Edit1.Text);
    //
    FDwnLoadThread := TDownloadThread.Create(thrTerminate, True);
    FDwnLoadThread.URL := Edit1.Text; // URL файла
    FDwnLoadThread.UserAgent := AgentB;
    FDwnLoadThread.FilePath := SavFilePath; // путь для сохранения файла
    FDwnLoadThread.StartPositon := -1; // -1 = автоопределение позиции докачки
    FDwnLoadThread.OnProgres := thrProgress; // отображение процесса закачки
    FDwnLoadThread.Resume;
    while not FDwnLoadThread.Terminated do
      Application.HandleMessage;
    if FUserStop then begin
      MessageBox(Handle, 'Закачку прервал пользователь', 'Информация', MB_OK + MB_ICONINFORMATION);
    end;
  finally
    FUserStop := False;
    FreeAndNil(FDwnLoadThread);
    Button1.Enabled := True;
    Button2.Enabled := False;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FUserStop := True;
  FDwnLoadThread.Terminate;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  Label2.Caption := GetSizTxt(GetURLFileSize(Edit1.Text));
end;

function TForm1.CheckUrl(url: string): boolean;
var
  ChkThr :TChkURLThreat;
begin
  Result := False;
  if Trim(Url) = '' then
    Exit;
  //
  ChkThr := TChkURLThreat.Create(thrTerminate, True);
  try
    ChkThr.UserAgent := AgentB;
    ChkThr.URL := url;
    // пуск
    ChkThr.Resume;
    // ждем
    while not ChkThr.Terminated do
      Application.HandleMessage;
    // результат проверки
    Result := ChkThr.ChkResult;
  finally
    FreeAndNil(ChkThr);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  with Edit1 do begin
    ShowHint := True;
    Hint := 'Вставляйте значение протокола в начале адреса!'#13 + 'http:// или https://';
  end;
   Edit2.Text := IncludeTrailingBackslash(ExtractFilePath(ParamStr(0)));
  FUserStop := False;
end;

function TForm1.GetHTMLPageText(Url: string): string;
var
  TxtThr :TTextThreat;
begin
  // получить HTML текст страницы
  Result := '';
  if Trim(Url) = '' then
    Exit;
  TxtThr := TTextThreat.Create(thrTerminate, True);
  try
    TxtThr.OnProgress := thrProgress; // прогресс закачки
    TxtThr.UserAgent := AgentB;
    TxtThr.URL := Url;
    TxtThr.Resume;
    //
    while not TxtThr.Terminated do
      Application.HandleMessage;
    //
    Result := TxtThr.ResultText;
  finally
    FreeAndNil(TxtThr);
  end;
end;

function TForm1.GetQueryResult(URL, UserAgent: string; Mode: Integer): string;
var
  QThr :TQueryThreat;
  Text :string;
begin
  Result := '';
  if Trim(URL) = '' then
    Exit;
  //
  QThr := TQueryThreat.Create(thrTerminate, True);
  try
    QThr.UserAgent := UserAgent;
    QThr.URL := URL;
    QThr.Query := Mode;
    QThr.Resume;
    while not QThr.Terminated do
      Application.HandleMessage;
    //
    Text := QThr.ResultText;
    // выведем результат
    Result := Text;
  finally
    FreeAndNil(QThr);
  end;
end;

function TForm1.GetSizTxt(I64: Int64): String;
const
  i64GB = 1024 * 1024 * 1024;
  i64MB = 1024 * 1024;
  i64KB = 1024;
begin
  // перевод байт в строку
  Result := '0 б';
  if I64 div i64GB > 0 then
    Result := Format('%.2f Гб', [I64/i64GB])
  else
  if I64 div i64MB > 0 then
    Result := Format('%.2f Мб', [I64/i64MB])
  else
  if I64 div i64KB > 0 then
    Result := Format('%.2f Кб', [I64/i64KB])
  else
    Result := IntToStr(I64) + ' б';
end;

function TForm1.GetURLFileSize(Url: string): Int64;
begin
  // размер файла
  Result := StrToInt64Def(GetQueryResult(Url, AgentB, HTTP_QUERY_CONTENT_LENGTH), 0);
end;

function TForm1.GetURLLastModify(Url: string): string;
begin
  // дата изменения файла
  Result := GetQueryResult(Url, AgentB, HTTP_QUERY_LAST_MODIFIED);
end;

procedure TForm1.thrProgress(Progres, MaxSiz: Int64);
begin
  with ProgressBar1 do begin
    Max := MaxSiz;
    Position := Progres;
    Update;
  end;
  Label3.Caption := Format('Выполнено: %s из %s', [GetSizTxt(Progres), GetSizTxt(MaxSiz)]);
end;

procedure TForm1.thrTerminate(Sender: TObject);
begin
  SendMessage(Handle, WM_NULL, 0, 0);
end;

end.


Цель кода скачать с указанного http адреса в интернете файл и сохранить его по указанному локальному пути. Он замечательный, все красиво работает.

Проблема: программа идет в отказ при попытке стачивания файла более 3 гигабайт. Конечно она может идет в отказ и при 2,9999 или 2,751 гигабайтам, но я не проверял. Прекрасно скачиваются файлы размером до 2 гигабайт, без зависания формы, хорошо работает поток, но стоит только дать ссылку на файл 3 гигабайта, 4, 5 как программа через секунду после запуска обработки не производя никаких действий выдает что файл скачан, создавая пустышку на локальном диске. То есть задал урл, но скачан файл с размером 0.

Грешным делом подумал, что проблема в самом WinInet либо проблема с моей головой и мне надо либо оперативной памяти купить плату дополнительно, либо руки выпрямить, но, накидал маленький код:

Код

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, WinInet, Vcl.StdCtrls;

type
  TMyThread = class(TThread) //Новый класс
  private
    count,sum,answer: Integer;
  protected
    procedure ShowResult;
    procedure Execute; override;
  end;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TMyThread.Execute;
var
  session,url:HInternet;
  appName:WideString;
  BufArr:array[1..1024] of byte;
  BufLen:DWORD;
  F:File;
begin
  answer:=0;
  appName := ExtractFileName(Application.ExeName);
  session := InternetOpen(Pchar(appName),INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);
  url:=InternetOpenUrl(session,PWideChar('http://олололололо/мегафайл'),nil,0,0,0);
  AssignFile(F,'диск:\мегафайл');
  Rewrite(F,1);
  repeat
    InternetReadFile(url,@BufArr,SizeOf(BufArr),BufLen);
    BlockWrite(F,BufArr,BufLen);
    answer := answer+BufLen;
  until BufLen=0;
  CloseFile(F);
  InternetCloseHandle(session);
  Synchronize(ShowResult);
end;

procedure TMyThread.ShowResult;
begin
  Form1.Edit1.Text := IntToStr(answer);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyThread:TMyThread;
begin
  MyThread := TMyThread.Create(False);
end;

end.



,выполнил и файл был скачан.. и 3 гигабайта и 4... и даже восемь гигабайт.

Прошу, ребят, посмотрите и подкиньте идейку слабоумному. Я все перетряс, десять раз перепродумывал. Не доходит где ошибся.

Заранее спасибо.

Добавлено через 2 минуты и 3 секунды
Забыл уточнить. Дебажить бесполезно, идет в брик по окончанию выполнения, ничего не дает. С ума схожу.
PM MAIL WWW ICQ Skype Jabber   Вверх
Illusion Dolphin
Дата 5.10.2012, 09:20 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003

Репутация: 2
Всего: 63



Цитата

SumSize := StrToInt64Def(BufMaxLen, 0);

SumSize - Cardinal, StrToInt64Def вощвращает Int64 если стоит Range checking то возможно тут упадёт, ну и прогресс неверный будет 100%. 

P.S. У мня скачиване идёт (4.3Gb), но прогресс неверный.

Добавлено через 7 минут и 39 секунд
Скачалось со 2й попытки. Ещё замечание - стандартный прогресс бар не оддерживает Int64, так что при выводе прогресса надо смотреть что есть максимальное значение больше чем MaxInt, то нормировать значение под Integer.


--------------------
В мире всего две бесконечности: вселенная и человеческая глупость... На счёт вселенной я не уверен.
Шифрование и организация фотографий - Photo Database 4.5
PM MAIL WWW ICQ   Вверх
Zmiuko
Дата 5.10.2012, 12:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


http://zmiuko.ru
**


Профиль
Группа: Участник
Сообщений: 297
Регистрация: 8.10.2008

Репутация: нет
Всего: 2



Цитата(Illusion Dolphin @  5.10.2012,  09:20 Найти цитируемый пост)
SumSize - Cardinal, StrToInt64Def вощвращает Int64 если стоит Range checking то возможно тут упадёт, ну и прогресс неверный будет 100%. 

P.S. У мня скачиване идёт (4.3Gb), но прогресс неверный.

Добавлено через 7 минут и 39 секунд
Скачалось со 2й попытки. Ещё замечание - стандартный прогресс бар не оддерживает Int64, так что при выводе прогресса надо смотреть что есть максимальное значение больше чем MaxInt, то нормировать значение под Integer. 


Дай я тебя расцелую.  smile 

Все верно. Абсолютно верно. SumSize не трогал (но внимания стоит), вылечил убрав ProgressBar и комментированием части текста:

Код

  with ProgressBar1 do begin
    Max := MaxSiz;
    Position := Progres;
    Update;
  end;


Придется танцевать в другую сторону, большое спасибо за совет.  smile 

Это сообщение отредактировал(а) Zmiuko - 5.10.2012, 12:41
PM MAIL WWW ICQ Skype Jabber   Вверх
  
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Сети"
Snowy
Poseidon
MetalFan

Запрещено:

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делится вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи

Если Вам помогли и атмосфера форума Вам понравилась, то заходите к нам чаще! С уважением, Snowy, Poseidon, MetalFan.

 
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Сети | Следующая тема »


 




[ Время генерации скрипта: 0.0859 ]   [ Использовано запросов: 22 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.