Copy Files med ProgressBar

Her er noget kode du kan bruge, og som jeg selv bruger:

function CopyCallback( TotalFileSize,
                      TotalBytesTransferred,
                      StreamSize,
                      StreamBytesTransferred: COMP;
                      dwStreamNumber,
                      dwCallbackReason : DWORD;
                      hSourceFile,
                      hDestinationFile: THandle;
                      LProgressForm: TLProgressForm ): DWORD; stdcall;
var newpos: Integer;
begin
  Result := PROGRESS_CONTINUE;
  if Lprogressform.FCancel then result := progress_cancel;
  if dwCallbackReason = CALLBACK_CHUNK_FINISHED then
  begin
    newpos := Round( TotalBytesTransferred / TotalFileSize * 100 );
    with LProgressForm.progressbar1 do
      if newpos <> Position then Position := newpos;
    Application.ProcessMessages;
  end;
end;


function  Lcopyfile(source, target : string) : boolean;
begin
  result := false;
  try
    LProgressForm.label1.caption := source;
    application.processmessages;
    result := CopyFileEx(
                  PChar(source),
                  PChar(target),
                  @CopyCallback,
                  Pointer(LProgressForm),
                  @LProgressForm.FCancel,
                  0);
    setfileattributes(pchar(target),FILE_ATTRIBUTE_NORMAL);
    setfileattributes(pchar(target),FILE_ATTRIBUTE_ARCHIVE);
  except
    on exception do
    begin
      // absolutely nothing
    end;
  end;
end;

function  Lcopyfiles(source, target : string) : boolean;
var srec : tsearchrec;
begin
  result := false;
  LProgressForm := TLProgressForm.Create(application);
  LProgressForm.caption := F00.caption;
  LProgressForm.label2.caption := \'Fil kopieres\';
  LProgressForm.Show;
  Application.ProcessMessages;
  try
    if findfirst(source+\'\\*.*\',faanyfile,srec) = 0 then
    begin
      Lcopyfile(source+\'\\\'+srec.name,target+\'\\\'+srec.name);
    end;
    while findnext(srec) = 0 do
    begin
      Lcopyfile(source+\'\\\'+srec.name,target+\'\\\'+srec.name);
    end;
  finally
    findclose(srec);
    LProgressForm.hide;
    LProgressForm.free;
  end;
end;

procedure Lcopydirs(s,t : string);
var srec : tsearchrec;
begin
  if not directoryexists(t) then
  begin
    forcedirectories(t);
  end;
  try
    if findfirst(s+\'\\*.*\',faanyfile,srec) = 0 then
    begin
      if (srec.name <> \'.\') and (srec.name <> \'..\') then
      begin
        if (srec.attr and fadirectory > 0) then
        begin
          Lcopydirs(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end else
        begin
          Lcopyfile(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end;
      end;
    end;
    while findnext(srec) = 0 do
    begin
      if (srec.name <> \'.\') and (srec.name <> \'..\') then
      begin
        if (srec.attr and fadirectory > 0) then
        begin
          Lcopydirs(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end else
        begin
          Lcopyfile(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end;
      end;
    end;
  finally
    findclose(srec);
  end;
end;

Til disse funktioner har jeg lavet en ny form, Se linien \"  LProgressForm := TLProgressForm.Create(application);
\" hvorpå der er nogle labels der viser hvad der sker og så en alm. progressbar.

Jeg håber du kan gennemskue hvad det er der sker.

Gennemskue det aaahh det kniper lidt =)

Kan du ikke lave et eksemple og sende det til azs@ofir.dk ?

Gerne i ZIP eller RAR!

azs, de funktioner og procedurer jeg har vist er en lille del af et omfattende program jeg bruger til opdatering af kundernes forskellige programversioner.

Det er ikke lige en 5-minutters opgave at lave et lille eksempel program der viser hvordan man bruger alle de muligheder funktionerne giver. Jeg vil ikke kunne nå det i dag, men eftersom telefonerne burde stå stille det meste af dagen i morgen, vil jeg prøve at nå det i løbet af dagen. Du bliver derfor nødt til at vente til i morgen eftermiddag/aften før jeg kan sende noget til dig.

Hvis det er for langt tid, så prøv alligevel selv, og spørg når der er noget du ikke forstår.

Jeg kan godt vente til fredag! For jeg er nemlig ikke hjemme imorgen så du kan bare tage dig den tid du skal bruge!

Jeg har også prøvet selv men kan ikke lige få det til at virke! :(

Nu har jeg \"leget\" med det et stykke tid men jeg kan ikke få det til at virke!

Hvad er \"F00.caption\" for en og hvad er FCancel?

Når jeg vil compile det kan den ikke finde ud af hva det er!

Vil du ikke fortælle hva det er?

*****

Jeg har lavet den en ny form som du også har skrevet jeg skulle!
På formen \"LProgressForm\" har jeg 2 labels og en progressbar!
Og alle de funktioner som du har givet mig har jeg lagt på \"MainForm\" som ikke er \"LProgressForm\"\'en.

Kan eller vil du sige hva det er jeg har lavet forkert eller vil du gerne sende et eksemple på hvordan formne skal se ud osv.. Hvis det altså er forkert det jeg har gjort!

azs, jeg beklager. Der kom lige en opgave på tværs her i Himmelfarts ferien, så jeg har hverken haft tid til at kigge på det eller sågar haft tid til at se på eksperten. Så det er ikke fordi jeg ikke kan eller vil svare, blot fordi jeg har haft travlt.

Men: F00 er navnet på mainform så F00.caption er blot hovedformens overskrift der overføres til LProgressForms caption.

FCancel vender jeg lige tilbage til.

Det er nu helt iorden!!!

Hej azs,

Nedenstående et lille Delphi 5 testprojekt med de forskellige copyfile funktioner. Jeg har valgt at vise hele koden her for at andre også kan få glæde af den hvis de ønsker det.

Mærk de forskellige sektioner og gem dem med det navn der står ud for tallet.

Se derefter nedenstående hvordan du opretter testprojektet.

1. Unit1.dfm

object Form1: TForm1
  Left = 414
  Top = 286
  Width = 225
  Height = 192
  Caption = \'Kopiering..\'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = \'MS Sans Serif\'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 24
    Top = 24
    Width = 177
    Height = 25
    Caption = \'Kopier en fil\'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 24
    Top = 64
    Width = 177
    Height = 25
    Caption = \'Kopier flere filer\'
    TabOrder = 1
    OnClick = Button2Click
  end
  object Button3: TButton
    Left = 24
    Top = 104
    Width = 177
    Height = 25
    Caption = \'Kopier et dir\'
    TabOrder = 2
    OnClick = Button3Click
  end
end

2. Unit1.pas

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, filectrl;

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;

var
  Form1: TForm1;

implementation

uses LProgress;

{$R *.DFM}

function CopyCallback( TotalFileSize,
                      TotalBytesTransferred,
                      StreamSize,
                      StreamBytesTransferred: COMP;
                      dwStreamNumber,
                      dwCallbackReason : DWORD;
                      hSourceFile,
                      hDestinationFile: THandle;
                      LProgressForm: TLProgressForm ): DWORD; stdcall;
var newpos: Integer;
begin
  Result := PROGRESS_CONTINUE;
  if lprogressform.FCancel then result := PROGRESS_CANCEL;
  if dwCallbackReason = CALLBACK_CHUNK_FINISHED then
  begin
    newpos := Round( TotalBytesTransferred / TotalFileSize * 100 );
    with LProgressForm.progressbar1 do
      if newpos <> Position then Position := newpos;
    Application.ProcessMessages;
  end;
end;


function  Lcopyfile(source, target : string) : boolean;
begin
  result := false;
  try
    LProgressForm.label1.caption := source;
    application.processmessages;
    result := CopyFileEx(
                  PChar(source),
                  PChar(target),
                  @CopyCallback,
                  Pointer(LProgressForm),
                  @LProgressForm.FCancel,
                  0);
    setfileattributes(pchar(target),FILE_ATTRIBUTE_NORMAL);
    setfileattributes(pchar(target),FILE_ATTRIBUTE_ARCHIVE);
  except
    on exception do
    begin
      // absolutely nothing
    end;
  end;
end;

function  Lcopyfiles(source, target : string) : boolean;
var srec : tsearchrec;
begin
  result := false;
  LProgressForm := TLProgressForm.Create(application);
  LProgressForm.label2.caption := \'Filer kopieres\';
  LProgressForm.Show;
  Application.ProcessMessages;
  try
    if findfirst(source+\'\\*.*\',faanyfile,srec) = 0 then
    begin
      Lcopyfile(source+\'\\\'+srec.name,target+\'\\\'+srec.name);
    end;
    while findnext(srec) = 0 do
    begin
      Lcopyfile(source+\'\\\'+srec.name,target+\'\\\'+srec.name);
    end;
    result := true;
  finally
    findclose(srec);
    LProgressForm.hide;
    LProgressForm.free;
  end;
end;

procedure Lcopydirs(s,t : string);
var srec : tsearchrec;
begin
  if not directoryexists(t) then
  begin
    forcedirectories(t);
  end;
  try
    if findfirst(s+\'\\*.*\',faanyfile,srec) = 0 then
    begin
      if (srec.name <> \'.\') and (srec.name <> \'..\') then
      begin
        if (srec.attr and fadirectory > 0) then
        begin
          Lcopydirs(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end else
        begin
          Lcopyfile(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end;
      end;
    end;
    while findnext(srec) = 0 do
    begin
      if (srec.name <> \'.\') and (srec.name <> \'..\') then
      begin
        if (srec.attr and fadirectory > 0) then
        begin
          Lcopydirs(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end else
        begin
          Lcopyfile(s+\'\\\'+srec.name,t+\'\\\'+srec.name);
        end;
      end;
    end;
  finally
    findclose(srec);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var ffile, tfile : string;
begin
  // kopier 1 fil
  ffile := \'C:\\temp\\fil1.txt\';    // Fra fil
  tfile := \'C:\\temp\\fil2.txt\';    // til fil
  LProgressForm := TLProgressForm.Create(application);
  LProgressForm.label2.caption := \'Fil kopieres\';
  LProgressForm.Show;

  Lcopyfile(ffile, tfile);

  LProgressForm.hide;
  LProgressForm.free;
end;

procedure TForm1.Button2Click(Sender: TObject);
var ffile, tfile : string;
begin
  // kopier flere filer
  ffile := \'C:\\dir1\';    // FRA: alle filer i dir1
  tfile := \'C:\\dir2\';    // TIL: dir2  NB! Dir2 skal findes. Det er kun filer der kopieres

  Lcopyfiles(ffile, tfile);
end;

procedure TForm1.Button3Click(Sender: TObject);
var ffile, tfile : string;
begin
  // kopier et dir
  ffile := \'C:\\dir1\';    // FRA: alle filer og under dirs i dir1
  tfile := \'C:\\dir3\';    // TIL: dir3. NB! dir3 og evt. underdirs behøver ikke findes
  LProgressForm := TLProgressForm.Create(application);
  LProgressForm.label2.caption := \'Dir kopieres\';
  LProgressForm.Show;

  Lcopydirs(ffile, tfile);

  LProgressForm.hide;
  LProgressForm.free;
end;

end.

3. LProgressform.dfm

object LProgressForm: TLProgressForm
  Left = 368
  Top = 213
  BorderIcons = []
  BorderStyle = bsDialog
  ClientHeight = 118
  ClientWidth = 400
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -12
  Font.Name = \'Times New Roman\'
  Font.Style = []
  FormStyle = fsStayOnTop
  OldCreateOrder = True
  Position = poScreenCenter
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 15
  object Label1: TLabel
    Left = 8
    Top = 40
    Width = 385
    Height = 15
    Alignment = taCenter
    AutoSize = False
    Color = clAqua
    ParentColor = False
  end
  object Label2: TLabel
    Left = 8
    Top = 8
    Width = 377
    Height = 15
    Alignment = taCenter
    AutoSize = False
    Caption = \'Label2\'
  end
  object ProgressBar1: TProgressBar
    Left = 8
    Top = 64
    Width = 385
    Height = 16
    Min = 0
    Max = 100
    TabOrder = 0
  end
  object BitBtn1: TBitBtn
    Left = 168
    Top = 88
    Width = 75
    Height = 25
    TabOrder = 1
    OnClick = BitBtn1Click
    Kind = bkCancel
  end
end

4. LProgressform.pas

unit LProgress;

interface

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

type
  TLProgressForm = class(TForm)
    Label1: TLabel;
    ProgressBar1: TProgressBar;
    Label2: TLabel;
    BitBtn1: TBitBtn;
    procedure BitBtn1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    fcancel : longbool;
  end;

var
  LProgressForm: TLProgressForm;

implementation

{$R *.DFM}

procedure TLProgressForm.BitBtn1Click(Sender: TObject);
begin
  fcancel := true;
end;

procedure TLProgressForm.FormCreate(Sender: TObject);
begin
  fcancel := false;
end;

end.

... slut

Sådan skal du oprette dit testprojekt:

Start D5 og vælg \"New Application\".

Gem den derefter i et dir efter eget valg.

Udskift Unit1.dfm og Unit1.pas med ovenstående.
Kopier LProgress.dfm og LProgress.pas ind i samme dit.

Start D5 igen og vælg Project, add to project og vælg LProgress.pas.

NB! Når du tilføjer LProgress.pas til projekt1 så skal du efterfølgende i Project, Options, flytte formen fra \"Auto-create forms\" til \"Available forms\", da formen bliver created ved hvert kald.

Efter at du har lavet det skal din \"project1.dpr\" se således ud:

program Project1;

uses
  Forms,
  Unit1 in \'Unit1.pas\' {Form1},
  LProgress in \'LProgress.pas\' {LProgressForm};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Kompiler derefter projektet og det bør virke.

Der er 3 muligheder:

1. Kopier en fil. (button1). I OnClick eventen har jeg sat \"c:\\temp\\fil1\" som fra og \"c:\\temp\\fil2\" som til. Fil1 SKAL findes og fil2 må IKKE findes i temp diret. Ret det evt. til andre filnavne.

2. Kopier flere filer (button2). I OnClick eventen har jeg sat \"C:\\dir1\" som fra og \"c:\\dir2\" som til. NB! både dir1 og dir2 SKAL findes, og alle filer i dir1 kopieres til dir2. Der kopieres kun filer. Ikke evt. underdirs.

3. Kopier et dir (button3). I OnClick eventen har jeg sat \"C:\\dir1\" som fra og \"C:\\dir3\" som til. Alle filer og underdirs fra Dir1 kopieres til dir3. NB! Dir3 og evt. underdirs behøver ikke findes. kommandien ForceDirectories opretter alle de dirs der er brug for.

NB! I alle tilfælde overskrives evt. eksisterende filer uden at spørge brugeren først.

God fornøjelse.. Hvis du har nogen spørgsmål så spørg.

hmm Jeg har gjort lige præcis som du siger men den kupire ikke noget!

Den viser progressformen i 100msec eller der omkring og så blir den lukket!

Jeg forstår det ikke for jeg kan compile det og at det der men den vil ikke kupire file(s)/dirne!

Kan du hjælpe?

Jeg kan prøve:

1. Hvis ikke du har rettet i navnene for det jeg i eksemplet kopierer, er du så sikker på at:
a. fil1.txt findes i c:\\temp (for button1) ?
b. dir1 findes under c:\\ og at der er filer i dir1 (for button2) ?
c. dir1 findes under c:\\ og at der er filer og evt. underdirs i (for button3) ?

Ellers skal du enten rette eksemplerne for hver button OnClick event så hhv. FFile og TFile passer med det du har på din maskine, eller oprette de filer/dirs jeg bruger.

2. Hvilket styresystem bruger du ?
Funktionen der står for al kopiering hedder CopyFileEx og er en af de nye Windows API kald, specielt beregnet til Windows NT / 2K. Der findes et ældre API kald der hedder CopyFile, men det har ikke nogen CallBack funktion, så man ikke kan se progressbar bevæge sig.

1. ja det har jeg!

2. Jeg har WinME

I den version af Win32 Programmers reference hjælpefil, der installeres sammen med Delphi og formentligt også Windows, står der kun Windows NT ud for CopyFileEx funktionen. Men jeg ved det virker upåklageligt for Win2K og jeg formoder at dette også gælder for WinMe eftersom den er endnu nyere.

Så jeg tror ikke det er der problemet ligger. Hvis WinMe ikke kunne bruge den ville du givetvis få en kompilerings- eller RunTime fejl.

Men jeg checker endnu engang og vender tilbage.

Er det forøvrigt D5 du bruger ?

Jeg har lige selv prøvet at lave et program ud fra det jeg har vist, og på den måde jeg beskriver og kan konstatere at det virker som forventet. Det er naturligvis udført på en NT maskine (jeg har ikke andet) men på en anden end den jeg lavede det på.

Så at det ikke virker hos dig er altså ikke fordi der er en fejl i det jeg har skrevet. Så fejlen skal måske søges i WinMe. Da jeg ikke har den kan jeg ikke teste og finde fejlen, desværre.

Men prøv at lave nogle Showmessages (showmessage(\'her\') f.eks.) forskellige steder i koden så du kan følge hvor langt du kommer.

Du kan også teste på retursvaret af funktionen LCopyFile i button1\'s onclick event. Den skal returnere true hvis filen bliver kopieret og ellers false.

Prøv at rette linien

Lcopyfile(ffile, tfile);

med

if Lcopyfile(ffile, tfile) then
begin
  showmessage(\'OK\');
end else
begin
  showmessage(\'FEJL\');
end;

og se hvad der sker.

Jeg har lige prøvet dette:

if Lcopyfile(ffile, tfile) then
begin
  showmessage(\'OK\');
end else
begin
  showmessage(\'FEJL\');
end;

og den kommer med \"FEJL\". Så den retunere jo false, og så er det nok fordi den funktion ikke er i WinME. Eller fordi jeg har lavet forkert!

Hvis du gider! Vil du så prøve at sende en ZIP med koden som virker ved dig! Det kan jo være mig som har gjort noget forkert! ;|


/azs azs@ofir.dk

og ja jeg har D5 !

Jep, jeg sender dig en exe fil, men ikke før i morgen. Jeg har ikke mulighed for det i dag.