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 секундыЗабыл уточнить. Дебажить бесполезно, идет в брик по окончанию выполнения, ничего не дает. С ума схожу. |
Небольшая проблема с докачкой на WinInet 
Дата 5.10.2012, 05:47 (
Загрузка ...
