Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2007.12.23;
Скачать: [xml.tar.bz2];

Вниз

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

 
Gulba   (2007-10-05 17:12) [0]

procedure TUrlLoader.execute;   //Реализует процесс закачки файла
var
 F: File;
 ResumePos, BufferLen, SumSize: DWORD;
 {hSession, }hURL: HInternet;
 Buffer: array[1..1024] of Byte;
 err: boolean;
 rsize:cardinal;
begin
repeat
SumSize := 0; ResumePos := 0;  //Инициализируемся
AssignFile(F, Path); //Свяжемся с файлом
Synchronize(Clear);
//hSession := InternetOpen("RNMC", PRE_CONFIG_INTERNET_ACCESS, nil, nil, 0);   //Открыли сессию
hURL := InternetOpenURL(Organizer_MainForm.hSession,PChar(URLadd),nil, 0, 0, 0);   //И наш УРЛ

Size:=0;
rsize:=4;
HttpQueryInfoW(hURL, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, @Size, rsize, nil);   //Сколько там наш файл весит?
if size=0 then
 begin
  err:=false;
  errtext:="Устаревшая ссылка"
 end
else

begin

 IF FileExists(Path) then //Есть ли на диске этот файл
  begin
    Reset(f,1); //Откроем!
    ResumePos := FileSize(F); //Откуда докачать
    SumSize:=ResumePos;
    Seek(F, FileSize(F)); //А писать будем в конец
  end else
    begin
    {$I-}
      ReWrite(f,1); //А раз нет, так создадим
      sumsize:=0;
    {$I+}
   end;

   if IOResult <> 0 then
      begin
      // showmessage("Не правильное имя файла!!!");
      err:=false;
      errText:="Не правильное имя файла!!!";
      end
else
 begin
  if ResumePos>0 then //Если докачиваем,
       InternetSetFilePointer(hURL,ResumePos,nil,0,0); //То сместимся

  REPEAT //Качаем
    err:= InternetReadFile(hURL, @Buffer,SizeOf(Buffer),BufferLen); //Читаем буфер
    sumSize:=sumSize+BufferLen;
    progress:=round (sumSize/size*100);
    Synchronize(ShowProgress);
    IF err= false then  break;//Ошибка чтения

    BlockWrite(f, Buffer, BufferLen); //Пишем в файл
    sleep(130)
  UNTIL (BufferLen=0)or Terminated; //Качаем, пока не все или надо
close(F)
end;

есть вот такой вот поток реализующий закачку файлов. Далее объявляеться динамический массив таких потоков. И есть массив ожидающих закачки файлов. И проблема такая что одновременно могут закачиваться только два файла. остальные ожидают их завершения и после запускаються. Я первый раз работаю с потоками просьба сильно не материть.


 
Gulba   (2007-10-05 17:17) [1]

procedure TUrlLoader.execute;   //Реализует процесс закачки файла
var
 F: File;
 ResumePos, BufferLen, SumSize: DWORD;
 {hSession, }hURL: HInternet;
 Buffer: array[1..1024] of Byte;
 err: boolean;
 rsize:cardinal;
begin
repeat
SumSize := 0; ResumePos := 0;  //Инициализируемся
AssignFile(F, Path); //Свяжемся с файлом
Synchronize(Clear);
//hSession := InternetOpen("RNMC", PRE_CONFIG_INTERNET_ACCESS, nil, nil, 0);   //Открыли сессию
hURL := InternetOpenURL(Organizer_MainForm.hSession,PChar(URLadd),nil, 0, 0, 0);   //И наш УРЛ

Size:=0;
rsize:=4;
HttpQueryInfoW(hURL, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, @Size, rsize, nil);   //Сколько там наш файл весит?
if size=0 then
 begin
  err:=false;
  errtext:="Устаревшая ссылка"
 end
else

begin

 IF FileExists(Path) then //Есть ли на диске этот файл
  begin
    Reset(f,1); //Откроем!
    ResumePos := FileSize(F); //Откуда докачать
    SumSize:=ResumePos;
    Seek(F, FileSize(F)); //А писать будем в конец
  end else
    begin
    {$I-}
      ReWrite(f,1); //А раз нет, так создадим
      sumsize:=0;
    {$I+}
   end;

   if IOResult <> 0 then
      begin
      // showmessage("Не правильное имя файла!!!");
      err:=false;
      errText:="Не правильное имя файла!!!";
      end
else
 begin
  if ResumePos>0 then //Если докачиваем,
       InternetSetFilePointer(hURL,ResumePos,nil,0,0); //То сместимся

  REPEAT //Качаем
    err:= InternetReadFile(hURL, @Buffer,SizeOf(Buffer),BufferLen); //Читаем буфер
    sumSize:=sumSize+BufferLen;
    progress:=round (sumSize/size*100);
    Synchronize(ShowProgress);
    IF err= false then  break;//Ошибка чтения

    BlockWrite(f, Buffer, BufferLen); //Пишем в файл
    sleep(130)
  UNTIL (BufferLen=0)or Terminated; //Качаем, пока не все или надо
close(F)
end;

if err then Synchronize(ShowWell)
else
  begin
    len:=1024;
    ZeroMemory(@errtext,SizeOf(errtext));
    if internetGetLastResponseInfo(ErCode,@errtext,len) then Synchronize(ShowError);
  end   // else

//   Synchronize(ShowError);//Показ результата

end;

InternetCloseHandle(hURL);
//InternetCloseHandle(hSession);

if (Organizer_MainForm.WaitingDownloadCount>0) then
 begin//Если список ожидающих не пуст
   EnterCriticalSection(Organizer_MainForm.CritSection);
      Name:=Organizer_MainForm.WaitingDownload[Organizer_MainForm.WaitingDownLoadCount -1].Name;
      URLadd:=Organizer_MainForm.WaitingDownload[Organizer_MainForm.WaitingDownLoadCou nt-1].URL;
      Path:="C:/"+name{Organizer_MainForm.WaitingDownload[Organizer_MainForm.WaitingDownLoadCount-1].Name}+".oms";
      Organizer_MainForm.WaitingDownload[Organizer_MainForm.WaitingDownLoadCount-1].Free;
      dec(Organizer_MainForm.WaitingDownLoadCount);
      SetLength(Organizer_MainForm.WaitingDownload,Organizer_MainForm.WaitingDownLoadC ount);
   LeaveCriticalSection(Organizer_MainForm.CritSection);
   Synchronize(NewDownload);
 end
else
 begin  //Иначе освоюождаем место
    EnterCriticalSection(Organizer_MainForm.CritSection);
      Organizer_MainForm.Indicator[number]:=true;
      dec(Organizer_MainForm.CurrentDownLoadCount);
    LeaveCriticalSection(Organizer_MainForm.CritSection);
    terminate;
 end;

until terminated;
end;



Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2007.12.23;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.47 MB
Время: 0.045 c
2-1196152756
Ростик
2007-11-27 11:39
2007.12.23
Как правильно записывать числа типа флоат


2-1196148033
IntruderLab
2007-11-27 10:20
2007.12.23
TMemo перейти к последней записи


2-1196411814
Человек
2007-11-30 11:36
2007.12.23
Патч


11-1181737379
Nikfel
2007-06-13 16:22
2007.12.23
Возможно ли изменить цвет Tkolbutton


2-1196410006
IvanB
2007-11-30 11:06
2007.12.23
ООП





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский