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

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Как скачать файл из интернета без зависания? 
:(
    Опции темы
diavo1os
Дата 5.8.2007, 12:38 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
Добрый день! подскажите пожалуйста...Как можно закачать файл из интернета без зависания...
Код

function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
 try
     Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0;
 except
   Result := False;
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
 SourceFile = 'http://mail.ru/55.wmv';
  DestFile = 'C:\55.wmv';
begin
 if DownloadFile(SourceFile, DestFile) then
 begin
   Label1.Caption:='1';
    end
 else
   ShowMessage('Error while downloading ' + SourceFile)
end;

Вот так я качаю файл..Но во время скачки у меня форма просто зависает а потом псоле закачки отвисает...и я ничего сделать не могу..возможно ли без зависания скачать ?
Заранее спс...



Это сообщение отредактировал(а) diavo1os - 5.8.2007, 12:39
PM MAIL   Вверх
Yanis
Дата 5.8.2007, 12:41 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


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

Репутация: нет
Всего: 111
diavo1os
Слушай, ну на мастерах тебе же вроде подсказали.
Или я ошибаюсь?

Добавлено через 1 минуту и 40 секунд
Дубль: http://www.delphimaster.ru/cgi-bin/forum.p...218865&n=18

Добавлено через 5 минут и 25 секунд
Цитата(diavo1os @  5.8.2007,  13:38 Найти цитируемый пост)
возможно ли без зависания скачать

Наверняка повторюсь...
Запусти функцию в отдельном потоке или используй последний параметр у URLDownloadToFile. Это тот, в котором ты передаёшь nil.


--------------------
user posted image *щёлк*
PM MAIL WWW ICQ   Вверх
diavo1os
Дата 5.8.2007, 13:07 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
я незнаю я там пять раз просил что в теме мне по теме отписывались..только вскольз.поэтмоу и обратился сюда..Пример покажи пожалуйста...я незнаю посл параметр у  URLDownloadToFile и про поток я спрашивал кокретнее (Thread). и все молчат...а в интернете литературы на эту тему мало...можешь хоть продемонстрирвоать?:
PM MAIL   Вверх
ALeXandrK
Дата 5.8.2007, 13:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


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

Репутация: нет
Всего: 6
Про потоки же целая статья написана. Разбирайся ... не хочу smile 
Тебе же дали направление.... 
Цитата

Запусти функцию в отдельном потоке или используй последний параметр у URLDownloadToFile.


Разбираешь предложение по словам, выделяешь главные, а дальше ... поиск.
Удачи smile 


--------------------
Богат не/ни тот, у кого много, а тот, кому хватает
PM WWW   Вверх
Alexeis
Дата 5.8.2007, 13:36 (ссылка) | (голосов:2) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 2
Всего: 459
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActiveX, UrlMon, StdCtrls;

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

type
   CalBackInet = class(TInterfacedObject, IBindStatusCallback)
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
      stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
   end;

function DownloadFile(SourceFile, DestFile: string): Boolean;
var
  CLB : IBindStatusCallback;
begin
 CLB := CalBackInet.Create as IBindStatusCallback;
 try
   Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, CLB) = 0;
 except
   Result := False;
 end;
 CLB := nil;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
 SourceFile = 'ftp://alexei-s1:**********@ftp.narod.ru:21/Install/sourceImg.rar';
  DestFile = 'C:\55.wmv';
begin
 if DownloadFile(SourceFile, DestFile)
 then
 begin
   Label1.Caption:='1';
 end
 else
   ShowMessage('Error while downloading ' + SourceFile)
end;


{ CalBackInet }

function CalBackInet.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin

end;

function CalBackInet.GetPriority(out nPriority): HResult;
begin

end;

function CalBackInet.OnDataAvailable(grfBSCF, dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin

end;

function CalBackInet.OnLowResource(reserved: DWORD): HResult;
begin

end;

function CalBackInet.OnObjectAvailable(const iid: TGUID;
  punk: IInterface): HResult;
begin

end;

function CalBackInet.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
  szStatusText: LPCWSTR): HResult;
begin
  //Этот метод вызывается постоянно
  //тут можно вызвать Application.ProcessMessages для обработки сообщений
  // перерисовки и отображения прогресса.
end;

function CalBackInet.OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult;
begin
  //Тут отображаем начало старта закачки
end;

function CalBackInet.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult;
begin
  //Вызовиться по завершению процесса закачки
end;

end.




--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Yanis
Дата 5.8.2007, 13:47 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


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

Репутация: нет
Всего: 111
Alexeis
Блин, ну чё творишь, чё творишь? smile smile


--------------------
user posted image *щёлк*
PM MAIL WWW ICQ   Вверх
Yanis
Дата 5.8.2007, 14:02 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


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

Репутация: нет
Всего: 111
Alexeis, ну не зря же я начал пальцы ломать на ноуте и писать экзампл. А ты меня опередил. Пришлось через лень дописывать smile 

Пример:
Код
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Clipbrd, WinInet, StdCtrls, ComCtrls, ExtCtrls, UrlMon, ActiveX;

type
  TOnProgressEvent = procedure(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR) of object;

  TBindStatusCallback = class(TObject, IBindStatusCallback)
  private
    FOnProgress: TOnProgressEvent;
  protected
    FRefCount: Integer;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  published
  public
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
      stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
    property OnDownload: TOnProgressEvent read FOnProgress write FOnProgress;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function DownloadFile(SourceFile, DestFile: string; DownloadEvent: TOnProgressEvent): Boolean;
    procedure Download(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR);
  end;

var
  Form1: TForm1;


implementation

{$R *.dfm}

procedure TForm1.Download(ulProgress, ulProgressMax, ulStatusCode: ULONG;
  szStatusText: LPCWSTR);
begin
  Caption := Format('%d of %d bytes (%s)', [ulProgress, ulProgressMax, szStatusText]);
  Application.ProcessMessages;
end;

function TForm1.DownloadFile(SourceFile, DestFile: string; DownloadEvent: TOnProgressEvent): Boolean;
var
  status: TBindStatusCallback;
begin
  try
    status := TBindStatusCallback.Create;
    status.OnDownload := DownloadEvent;
    Result := UrlDownloadToFile(nil,
                                PChar(SourceFile),
                                PChar(DestFile),
                                0,
                                status) = 0;
    status.Free;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DownloadFile('http://torrent.borland.com/turbodelphi_en.iso.zip',
               'c:\tmp\turbodelphi_en.iso.zip', Download);
end;

{ TBindStatusCallback }

function TBindStatusCallback.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin

end;

function TBindStatusCallback.GetPriority(out nPriority): HResult;
begin

end;

function TBindStatusCallback.OnDataAvailable(grfBSCF, dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin

end;

function TBindStatusCallback.OnLowResource(reserved: DWORD): HResult;
begin

end;

function TBindStatusCallback.OnObjectAvailable(const iid: TGUID;
  punk: IInterface): HResult;
begin

end;

function TBindStatusCallback.OnProgress(ulProgress, ulProgressMax,
  ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
begin
  if Assigned(FOnProgress) then
    FOnProgress(ulProgress, ulProgressMax, ulStatusCode, szStatusText);
  Result := S_OK;
end;

function TBindStatusCallback.OnStartBinding(dwReserved: DWORD;
  pib: IBinding): HResult;
begin

end;

function TBindStatusCallback.OnStopBinding(hresult: HResult;
  szError: LPCWSTR): HResult;
begin

end;

function TBindStatusCallback.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

function TBindStatusCallback._AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TBindStatusCallback._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;

end.


Для примера специально взял большой файл http://torrent.borland.com/turbodelphi_en.iso.zip.

Это сообщение отредактировал(а) Yanis - 5.8.2007, 14:20


--------------------
user posted image *щёлк*
PM MAIL WWW ICQ   Вверх
diavo1os
Дата 5.8.2007, 14:16 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
спс большое всем..осбенно Yanis...разобрался....
PM MAIL   Вверх
MetalFan
Дата 5.8.2007, 15:54 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128
Yanis, а что от TObject, а не от TInterfacedObject, как Alexeis? ихо так нагляднее) нет лишнего кода


--------------------
There are always someone smarter than you...
PM MAIL   Вверх
Yanis
Дата 5.8.2007, 16:28 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


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

Репутация: нет
Всего: 111
Цитата(MetalFan @  5.8.2007,  16:54 Найти цитируемый пост)
Yanis, а что от TObject, а не от TInterfacedObject, как Alexeis? ихо так нагляднее) нет лишнего кода

Ну да, так разумнее. Не внимательный потому что, вот и ляпаю smile

Добавлено @ 16:40
Реализация класса TBindStatusCallback:
Код
TBindStatusCallback = class(TInterfacedObject, IBindStatusCallback)


Код
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActiveX, UrlMon, StdCtrls;

type
  TOnProgressEvent = procedure(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR) of object;

  TBindStatusCallback = class(TInterfacedObject, IBindStatusCallback)
  private
    FOnProgress: TOnProgressEvent;
  published
  public
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
      stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
    property OnDownload: TOnProgressEvent read FOnProgress write FOnProgress;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function DownloadFile(SourceFile, DestFile: string; DownloadEvent: TOnProgressEvent): Boolean;
    procedure Download(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TBindStatusCallback }

function TBindStatusCallback.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.GetPriority(out nPriority): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnDataAvailable(grfBSCF, dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnLowResource(reserved: DWORD): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnObjectAvailable(const iid: TGUID;
  punk: IInterface): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnProgress(ulProgress, ulProgressMax,
  ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
begin
  if Assigned(FOnProgress) then
    FOnProgress(ulProgress, ulProgressMax, ulStatusCode, szStatusText);
  Result := S_OK;
end;

function TBindStatusCallback.OnStartBinding(dwReserved: DWORD;
  pib: IBinding): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnStopBinding(hresult: HResult;
  szError: LPCWSTR): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  DownloadFile('http://torrent.borland.com/turbodelphi_en.iso.zip',
               'c:\tmp\turbodelphi_en.iso.zip', Download);
end;

procedure TForm1.Download(ulProgress, ulProgressMax, ulStatusCode: ULONG;
  szStatusText: LPCWSTR);
begin
  Caption := Format('%d of %d bytes (%s)', [ulProgress, ulProgressMax, szStatusText]);
  Application.ProcessMessages;
end;

function TForm1.DownloadFile(SourceFile, DestFile: string;
  DownloadEvent: TOnProgressEvent): Boolean;
var
  status: TBindStatusCallback;
begin
  try
    status := TBindStatusCallback.Create;
    status.OnDownload := DownloadEvent;
    Result := UrlDownloadToFile(nil,
                                PChar(SourceFile),
                                PChar(DestFile),
                                0,
                                status) = 0;
    status.Free;
  except
    Result := False;
  end;
end;

end.


Отдельное спасибо MetalFan за пинок.

Это сообщение отредактировал(а) Yanis - 5.8.2007, 16:40


--------------------
user posted image *щёлк*
PM MAIL WWW ICQ   Вверх
MikeLevinN
Дата 12.9.2007, 10:24 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
Всем привет.
Использовал один из выше приведеных способов в своем приложении, что бы скачать 20Кб. Но ситуация такая, что мне кажется, что где-то память не освобождается. А именно, до начала вызова этого кода, моя программа расходует около четырех Мб, после же, начинает расходовать около шести и даже более.

Я было думал на свои кривые руки с разборкой скачанного файла, но попробовал просто вычеркнуть этап скачивания, подменив "скачанный" файл, файлом на диске, в таком случае с расходом памяти все нормально, т.е. это не в моем алгоритме косяк.

Сам код этот:
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActiveX, UrlMon, StdCtrls;

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

type
   CalBackInet = class(TInterfacedObject, IBindStatusCallback)
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
      stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
   end;

function DownloadFile(SourceFile, DestFile: string): Boolean;
var
  CLB : IBindStatusCallback;
begin
 CLB := CalBackInet.Create as IBindStatusCallback;
 try
   Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, CLB) = 0;
 except
   Result := False;
 end;
 CLB := nil;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
 SourceFile = 'ftp://alexei-s1:**********@ftp.narod.ru:21/Install/sourceImg.rar';
  DestFile = 'C:\55.wmv';
begin
 if DownloadFile(SourceFile, DestFile)
 then
 begin
   Label1.Caption:='1';
 end
 else
   ShowMessage('Error while downloading ' + SourceFile)
end;


{ CalBackInet }

function CalBackInet.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin

end;

function CalBackInet.GetPriority(out nPriority): HResult;
begin

end;

function CalBackInet.OnDataAvailable(grfBSCF, dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin

end;

function CalBackInet.OnLowResource(reserved: DWORD): HResult;
begin

end;

function CalBackInet.OnObjectAvailable(const iid: TGUID;
  punk: IInterface): HResult;
begin

end;

function CalBackInet.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
  szStatusText: LPCWSTR): HResult;
begin
  //Этот метод вызывается постоянно
  //тут можно вызвать Application.ProcessMessages для обработки сообщений
  // перерисовки и отображения прогресса.
end;

function CalBackInet.OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult;
begin
  //Тут отображаем начало старта закачки
end;

function CalBackInet.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult;
begin
  //Вызовиться по завершению процесса закачки
end;

end.


Что тут не так, куда мне копать?
PM MAIL   Вверх
Alexeis
Дата 12.9.2007, 11:33 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 2
Всего: 459
Цитата(MikeLevinN @  12.9.2007,  10:24 Найти цитируемый пост)
до начала вызова этого кода, моя программа расходует около четырех Мб, после же, начинает расходовать около шести и даже более.

  Это еще ни о чем не говорит. Утечки не проверяют по показаниям таск менеджера. Менеджер памяти делфи редко отдает память винде даже если удалены все объекты, потому что резервирует про запас. 


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
MikeLevinN
Дата 12.9.2007, 11:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
Хмм.. ну я даже не знаю, что и сказать, так просто кушать два метра памяти, на моём, хоть и мальеньком опыте не видел никогда. Просто не понимаю, как такое получается, что именно в данном случае влияет на это?

Т.е. ведь если я создам обычный класс, он у меня отожрет памяти пусть тоже два метра, а потом его удалю, - то расход памяти, судя по task manager сокращается. А тут такое дело, может есть способы все же как-то воздействовать на это, дабы избежать этих лишних расходов? Просто успокоиться не могу ни как. Или не обращать на это внимание?


И ещё вопрос в тему, как в данном коде прописать соединение через прокси?
PM MAIL   Вверх
Alexeis
Дата 12.9.2007, 12:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 2
Всего: 459
Нужно воспользоваться модулем для проверки утечек памяти. Что-то такое тут проскакивало на форуме, по завершению создается лог где написано чего и где не было освобождено. Без этого даже и браться не стоит. Кроме того приведенный пример почти пустой, ошибка может быть где угодно. Преведеные доводы не убедительны.

Добавлено через 3 минуты и 8 секунд
Модуль называется MemCheck.pas Он не стандартный но найти несложно.


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
MikeLevinN
Дата 12.9.2007, 16:17 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
Да я проверяю на наличие утечек через FastMM4, но все нормально, никаких утечек не зафиксировано.

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

Код в тестовом проекте такой же как и в примере, я добавил лишь:
Код

function CalBackInet.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
  szStatusText: LPCWSTR): HResult;
begin
  Application.ProcessMessages;
end;

function CalBackInet.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult;
begin
  ShowMessage('end!');
end;


Это нормальное явление, или как это объяснить? 
PM MAIL   Вверх
Alexeis
Дата 12.9.2007, 16:40 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 2
Всего: 459
Я думаю дело в том что в память загружается еще дополнительно библиотека 'URLMON.DLL'. Вероятно она и занимает много оперативки.


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
MikeLevinN
Дата 12.9.2007, 17:23 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
Ну об этом я в первую очередь и думал, но разве так должно быть? Почему она не выгружается, т.е. как её выгрузить?
PM MAIL   Вверх
Alexeis
Дата 12.9.2007, 17:31 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 2
Всего: 459
Цитата(MikeLevinN @  12.9.2007,  17:23 Найти цитируемый пост)
Почему она не выгружается, т.е. как её выгрузить? 

  Чтобы ее можно было выгрузить ее нужно динамически загрузить руками и получить адрес функции. Ну об этом же почти в любой книжке есть!


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
MikeLevinN
Дата 13.9.2007, 08:22 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
Ничего не помогло. И не понимаю, что происходит. Избавился от UrlMon.pas сделал динамическую загрузку и выгрузку библиотеки.

В ходе выяснилось, что сама загрузка библиотеки памяти много не отжирает, а вот в результате выполнения кода - закачки файла, наблюдается тоже самое память стремительно кушается. При выгрузке библиотеки, память не освобождается. Что не так?

Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, ActiveX;


type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  _tagBINDINFO = packed record
    cbSize: ULONG;
    szExtraInfo: LPWSTR;
    stgmedData: TStgMedium;
    grfBindInfoF: DWORD;
    dwBindVerb: DWORD;
    szCustomVerb: LPWSTR;
    cbstgmedData: DWORD;
    dwOptions: DWORD;
    dwOptionsFlags: DWORD;
    dwCodePage: DWORD;
    securityAttributes: TSecurityAttributes;
    iid: TGUID;
    pUnk: IUnknown;
    dwReserved: DWORD;
  end;
  TBindInfo = _tagBINDINFO;

  IBinding = interface
    ['{79eac9c0-baf9-11ce-8c82-00aa004ba90b}']
    function Abort: HResult; stdcall;
    function Suspend: HResult; stdcall;
    function Resume: HResult; stdcall;
    function SetPriority(nPriority: Longint): HResult; stdcall;
    function GetPriority(out nPriority: Longint): HResult; stdcall;
    function GetBindResult(out clsidProtocol: TCLSID; out dwResult: DWORD;
      out szResult: POLEStr; dwReserved: DWORD): HResult; stdcall;
  end;  

  IBindStatusCallback = interface
    ['{79eac9c1-baf9-11ce-8c82-00aa004ba90b}']
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
      stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
  end;

  TURLDownloadToFile = function (Caller: IUnknown; URL: PChar; FileName: PChar; Reserved: DWORD;
                                                     StatusCB: IBindStatusCallback): HResult; stdcall;

   CalBackInet = class(TInterfacedObject, IBindStatusCallback)
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
      stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
   end;

var
  Form1: TForm1;
  UrlMonHandle: THandle = 0;
  URLDownloadToFile: TURLDownloadToFile;

implementation

{$R *.dfm}

procedure LoadURLMon;
const
  UrlMonLib = 'URLMON.DLL';
  URLDownloadToFileName = 'URLDownloadToFileA';

begin
  URLMonHandle := LoadLibrary(PChar(UrlMonLib));
  if URLMonHandle <= HINSTANCE_ERROR then
    URLMonHandle := 0
  else
  begin
    URLDownloadToFile := GetProcAddress(URLMonHandle, URLDownloadToFileName);
    if(not assigned(URLDownloadToFile)) then
    begin
      FreeLibrary(URLMonHandle);
      URLMonHandle := 0;
      ShowMessage('Fail...');
    end else
      ShowMessage('Loaded...');
  end;
end;

procedure ReleaseURLMon;
begin
  if(URLMonHandle <> 0) then
  begin
    FreeLibrary(URLMonHandle);
    URLMonHandle := 0;
  end;
end;

function DownloadFile(SourceFile, DestFile: string): Boolean;
var
  CLB : IBindStatusCallback;
begin
 CLB := CalBackInet.Create as IBindStatusCallback;
 try
   Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, CLB) = 0;
 except
   Result := False;
 end;
 CLB := nil;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  LoadURLMon;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ReleaseURLMon;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
 if DownloadFile('http://wwtests', 'tests.zip')
 then
 begin
  ShowMessage('ok, downloaded');
 end
 else
   ShowMessage('Error while downloading')
end;

{ CalBackInet }

function CalBackInet.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin

end;

function CalBackInet.GetPriority(out nPriority): HResult;
begin

end;

function CalBackInet.OnDataAvailable(grfBSCF, dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin

end;

function CalBackInet.OnLowResource(reserved: DWORD): HResult;
begin

end;

function CalBackInet.OnObjectAvailable(const iid: TGUID;
  punk: IInterface): HResult;
begin

end;

function CalBackInet.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
  szStatusText: LPCWSTR): HResult;
begin
  Application.ProcessMessages;
end;

function CalBackInet.OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult;
begin
  //
end;

function CalBackInet.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult;
begin
  ShowMessage('Callback - Stop!');
end;

end.


Это сообщение отредактировал(а) MikeLevinN - 13.9.2007, 08:24
PM MAIL   Вверх
Alexeis
Дата 13.9.2007, 09:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 2
Всего: 459
MikeLevinN, это все же кэширование, причем возможно еще и кэширование винды. Если программу свернуть и развернуть, то первоначально память уменьшится до 600кб, а потом не будет превышать 2000 кб. таск мэнэнджер не показывает всей виртуальной памяти израсходованной программой, возможно такое увеличение связанно с подргрузкой из подкачки самой программы, ведь известно, что программа целиком в ОЗУ не загружается, только необходимый набор. 


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
MetalFan
Дата 13.9.2007, 09:43 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128
а ничего, что часть методов CalBackInet ничего не позвращает?


--------------------
There are always someone smarter than you...
PM MAIL   Вверх
Alexeis
Дата 13.9.2007, 10:37 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 2
Всего: 459
MetalFan, это же тестовый пример, а не реальный, да и не бывает так что ничего не возвращается совсем, просто значение результата неопределено.


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Dragin
Дата 29.9.2007, 11:04 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

Репутация: нет
Всего: нет
TThread
PM MAIL   Вверх
Coderr
Дата 7.3.2008, 22:06 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


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

Репутация: нет
Всего: 0
Хм. Что-то не пойму... То ли инет у меня быстрый, то ли я что-то не понял.
Использовал код Yanis'a из этого поста.
Вроде даже ничего не менял... Получается так что при скачке файла размером 1,38 Мб label показывает 0, подвисает и через мгновение показывает что всё скачалось. И действительно, всё скачивается. Только процесс не отображается. Собсно, в этом и проблем. smile 
Прикладываю сорс.

Присоединённый файл ( Кол-во скачиваний: 19 )
Присоединённый файл  Auto_Update.rar 14,84 Kb
--------------------
Кодинг - это стиль жизни!   
PM WWW ICQ   Вверх
Coderr
  Дата 14.3.2008, 02:47 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


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

Репутация: нет
Всего: 0
Странно... теперь вобще не качает... :(
--------------------
Кодинг - это стиль жизни!   
PM WWW ICQ   Вверх
vovksextra
Дата 14.3.2008, 18:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

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

http://forum.vingrad.ru/forum/topic-196305.html
PM MAIL   Вверх
Страницы: (2) [Все] 1 2 
 Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Сети"
Snowy
Poseidon
MetalFan

Запрещено:

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

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

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

Если Вам помогли и атмосфера форума Вам понравилась, то заходите к нам чаще! С уважением, Snowy, Poseidon, MetalFan.
 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Сети | Следующая тема »

Подписаться на тему | Подписка на этот форум | Скачать/Распечатать тему


 




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


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

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