Текущий архив: 2004.06.27;
Скачать: CL | DM;

Вниз

Копирование с "msctls_progress32"   Найти похожие ветки 

← →
KORN   (2004-05-17 16:29) [0]

Люди, если у кого-то есть пример копирования файлов (на АЙПИ) с отображение прогресса в компоненте "msctls_progress32", пожалуйста, поделитесь. А то у меня, получилось следующее:

procedure FastFileCopy(const hProgress: HWND; InFileName, OutFileName: string);
const
BufSize = 3*4*4096; { 48Kbytes gives me the best results }
type
PBuffer = ^TBuffer;
TBuffer = array[1..BufSize] of Byte;
var
Size: DWORD;
Buffer: PBuffer;
infile, outfile: file;
SizeDone, SizeFile: LongInt;
begin
if (InFileName <> OutFileName) then begin
 buffer := nil;
 Assign(infile, InFileName);
 Reset(infile, 1);
  try
   SizeFile := FileSize(infile);
   Assign(outfile, OutFileName);
   Rewrite(outfile, 1);

   //устанавливаем минимальную и максимальную позицию прогресса
   SendMessage(hProgress, PBM_SETRANGE, 0, MAKELPARAM(0, SizeFile));
   //Устанавливаем шаг
   SendMessage(hProgress, PBM_SETSTEP, 1, 0);

    try
     SizeDone := 0;
     New(Buffer);
  repeat
   BlockRead(infile, Buffer^, BufSize, Size);
   Inc(SizeDone, Size);

   //Устанавливаем позицию
   SendMessage(hProgress, PBM_SETPOS, SizeDone, 0);

   BlockWrite(outfile, Buffer^, Size)
  until Size < BufSize;
   FileSetDate(TFileRec(outfile).Handle,
   FileGetDate(TFileRec(infile).Handle));
  finally
   if Buffer <> nil then Dispose(Buffer);
    CloseFile(outfile)
  end;
 finally
  CloseFile(infile);
 end;
end;
end;

Но прогресс все-равно не работает. Где ошибка? Помогите!

---

← →
KORN   (2004-05-17 19:40) [1]

Вижу, что "мастера" в WIN32API не в зуб ногой...

---

← →
Игорь Шевченко ©   (2004-05-17 21:36) [2]

> Вижу, что "мастера" в WIN32API не в зуб ногой...


Эт точно...

---

← →
Cobalt ©   (2004-05-17 23:41) [3]

2 KORN
1) Попробуй анализировать результат SendMessage
2) Функция вызывается из какого-то события?

---

← →
Viman ©   (2004-05-18 09:09) [4]

Не пользовался напрямую msctls_progress32, ничего не скажу что это такое. Сам-то прогресс рисуется во время копирования? В циклах не мешает ставить такую вещь как Application.ProcessMessages, чтобы успевало в данном случае обрабатываться сообщение WM_PAINT и все должно быть нормально. Если не используешь VCL, то тогда вызывай вместо ProcessMessages что-нибудь типа SendMessage(hProgress, WM_PAINT, ...), либо InvalidateRect - UpdateWindow.
Успехов.

---

← →
NAlexey ©   (2004-05-18 12:13) [5]


procedure FastFileCopy(const hProgress: HWND; InFileName, OutFileName: string);
const
 BufSize = 3*4*4096; { 48Kbytes gives me the best results }
type
 PBuffer = ^TBuffer;
 TBuffer = array[1..BufSize] of Byte;
var
 Size: DWORD;
 Buffer: PBuffer;
 infile, outfile: file;
 SizeDone, SizeFile: LongInt;
begin
 if (InFileName <> OutFileName) then
 begin
   buffer := nil;
   Assign(infile, InFileName);
   Reset(infile, 1);
   try
     SizeFile := FileSize(infile);
     Assign(outfile, OutFileName);
     Rewrite(outfile, 1);
     //устанавливаем минимальную и максимальную позицию прогресса
     SendMessage(hProgress, PBM_SETRANGE, 0, MAKELPARAM(0, SizeFile div BufSize));
     //Устанавливаем шаг
     SendMessage(hProgress, PBM_SETSTEP, 1, 0);
     try
       SizeDone := 0;
       New(Buffer);
       repeat
         BlockRead(infile, Buffer^, BufSize, Size);
         Inc(SizeDone{, BufSize});
         //Устанавливаем позицию
         SendMessage(hProgress, PBM_SETPOS, SizeDone, 0);
         BlockWrite(outfile, Buffer^, Size)
       until Size < BufSize;
       FileSetDate(TFileRec(outfile).Handle,
       FileGetDate(TFileRec(infile).Handle));
     finally
       if Buffer <> nil then
         Dispose(Buffer);
       CloseFile(outfile)
     end;
   finally
     CloseFile(infile);
   end;
 end;
end;

function WindProc(hWindow: HWnd; Message, wParam, lParam: Integer): Integer; stdcall;
begin
 Result := 0;
 case Message of
   WM_DESTROY:
   begin
     PostQuitMessage(0);
     Exit;
   end;
 else
   Result := DefWindowProc(hWindow, Message, wParam, lParam);
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 hWindow: THandle;
 PB: THandle;
 Inst: HINST;

 function GetSplashWindow: THandle;
 var
   WinClass: WNDCLASS;
   Left, Top, W, H: Integer;
 begin
   WinClass.style := 0;
   WinClass.cbClsExtra := 0;
   WinClass.cbWndExtra := 0;
   WinClass.hInstance := hInstance;
   WinClass.hIcon := 0;
   WinClass.hCursor := LoadCursor(0, IDC_ARROW);;
   WinClass.hbrBackground := color_btnface + 1;
   WinClass.lpszMenuName := nil;
   WinClass.lpszClassName := "ProgressWnd";
   WinClass.lpfnWndProc := @WindProc;
   Windows.RegisterClass(WinClass);
   W := 300;
   H := 40;
   Left := (Screen.Width - W) div 2;
   Top :=  (Screen.Height - H) div 2;
   Result := CreateWindowEx(WS_EX_TOOLWINDOW or
     WS_EX_DLGMODALFRAME or WS_EX_TOPMOST,
     WinClass.lpszClassName, "????", WS_POPUP, Left,
     Top, W, H, HWND_DESKTOP, 0, HInstance, nil);
 end;

begin
 Inst := HInstance;
 hWindow := GetSplashWindow;
 PB := CreateWindow("msctls_progress32", "progressbar", WS_VISIBLE or WS_CHILD or WS_BORDER,
   8, 8, 281, 18, hWindow, 0, Inst, nil);
 SendMessage(PB, PBM_SETPOS, 0, 0);
 ShowWindow(hWindow, SW_NORMAL);
 FastFileCopy(PB, "C:\BigData.rar", "C:\BigData1.rar")
end;

---

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

Текущий архив: 2004.06.27;
Скачать: CL | DM;

Наверх

Память: 0.49 MB
Время: 0.023 c