Главная страница
    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.042 c
3-1187087591
ari_9
2007-08-14 14:33
2007.12.23
зависимые ListSource для Lookup компонент. как лучше ? (+)


2-1196272152
NeiL
2007-11-28 20:49
2007.12.23
Работа с изображениями


15-1195558165
Vlad Oshin
2007-11-20 14:29
2007.12.23
Таскать объект по странице.


2-1195904979
PASZLIB
2007-11-24 14:49
2007.12.23
Большие числа


2-1196249636
Alex_C
2007-11-28 14:33
2007.12.23
Вопрос по Canvas.TextOut





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
Английский Французский Немецкий Итальянский Португальский Русский Испанский