ProgressBar et copie de répertoire

Version imprimable

31/07/2018, 12h16
bern59

ProgressBar et copie de répertoire

Bonjour,
Je voudrais copier un répertoire entier vers un autre (CopyDirTree) mais j'aimerai que s'affiche la progression dans un progressbar.
J'ai vainement cherché le code.
Qui a une solution ?
Merci.
31/07/2018, 12h19
Jipété

Citation:

Envoyé par bern59

J'ai vainement cherché le code.

Vainement, vraiment ? Il y en a plein le web, faut juste utiliser les bons mots-clé, éventuellement en regardant comment ça se passe en Delphi.

(là je n'ai pas trop le temps, et je n'ai pas ça en rayon.)
31/07/2018, 14h30
tourlourou

Sous Windows, MoveFileWithProgressA.
31/07/2018, 14h53
bern59

progressbar

Citation:

Envoyé par tourlourou

Sous Windows, MoveFileWithProgressA.

Merci,mais ma recherche concerne Lazarus.
31/07/2018, 15h16
BeanzMaster

Salut pour afficher une progression tu dois d'abord connaitre le nombre total de répertoires ou fichiers à copier ensuite c'est facile. Tu sais calculer un pourcentage ? Non ? Alors une petite règle de trois et hop

Exemple
En pourcentage

ProgressBar.Min := 0
ProgressBar.Max := 100

Pourcentage 100 X

Elements Total Copiés

X := (Nombre_d_element_copiés * 100) div Nombre_total_d_élément_a_copier

ProgressBar.Position := X

Malheureusement CopyDirTree ne te permet pas de connaitre le nombre de fichiers ou de répertoires à l'avance. L plus simple c'est de mettre la propriété "Style" sur "pbstMarquee"

Voir aussi cette discussion sur la copie de dossier
31/07/2018, 16h55
bern59

progressbar

Citation:

Envoyé par BeanzMaster

Salut pour afficher une progression tu dois d'abord connaitre le nombre total de répertoires ou fichiers à copier ensuite c'est facile. Tu sais calculer un pourcentage ? Non ? Alors une petite règle de trois et hop

Exemple
En pourcentage

ProgressBar.Min := 0
ProgressBar.Max := 100

Pourcentage 100 X

Elements Total Copiés

X := (Nombre_d_element_copiés * 100) div Nombre_total_d_élément_a_copier

ProgressBar.Position := X

Malheureusement CopyDirTree ne te permet pas de connaitre le nombre de fichiers ou de répertoires à l'avance. L plus simple c'est de mettre la propriété "Style" sur "pbstMarquee"

Voir aussi cette discussion sur la copie de dossier

C'est gentil de me répondre mais je tiens à signaler que le calcul des pourcentages ne m'a jamais posé de problème ; je n'ai pas compris comment mettre la propriété "Style" sur "pbstMarquee".
.

Merci quant même.
31/07/2018, 18h04
tourlourou

Citation:

Envoyé par bern59

Merci,mais ma recherche concerne Lazarus.

Là n'est pas la question : il faut savoir quel est l'OS cible.
Pour du seul Windows, faire appel aux fonctions de son API est judicieux, d'où mon lien. On doit pouvoir aussi faire un ShellExec pour Copy qui affichera la boîte de progression de Windows.
Pour une solution multiplateforme, soit il existe une solution Lazarus, soit il suffit de balayer le répertoire en stockant la taille et le nombre des fichiers, puis de boucler sur la copie en faisant progresser à chaque fichier ou lot de x fichiers un TProgressBar soi-même (ne pas oublier un Application.ProcessMessages ensuite pour lui permettre de se dessiner à sa nouvelle position).
31/07/2018, 20h59
thierrybo

1 pièce(s) jointe(s)

Bonjour,

peut-être que tu devrais étudier le logiciel DoubleCommander, fait avec Lazarus et qui l'implémente. Ci dessous la version Linux mais il y a une version Windows et Mac :

Pièce jointe 400688
31/07/2018, 22h00
BeanzMaster

Citation:

Envoyé par bern59

C'est gentil de me répondre mais je tiens à signaler que le calcul des pourcentages ne m'a jamais posé de problème ;

Tu ne l'as pas préciser.

Citation:

Envoyé par bern59

je n'ai pas compris comment mettre la propriété "Style" sur "pbstMarquee".

Tu devrais d'abord commencer par apprendre à utilisé l'EDI, placer des composants, definir les propriétés via l'inspecteur d'objet etc..... Cela serai déjà un bon début plutôt que de foncer tête baisser. Tu ne vas pas te jeter à l'eau si tu ne sait pas nager :zoubi: (à moins que tu ai pied :mrgreen:)

hello,

Citation:

Envoyé par thierrybo

Bonjour,
peut-être que tu devrais étudier le logiciel DoubleCommander, fait avec Lazarus et qui l'implémente. Ci dessous la version Linux mais il y a une version Windows et Mac :

en tout cas dans doubleCommander c'est dans le fichier fFileOpDlg.pas que cela est intéressant :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
procedure TfrmFileOp.SetProgressBytes(Operation: TFileSourceOperation;  ProgressBar: TKASProgressBar; CurrentBytes: Int64; TotalBytes: Int64);
begin
  if (CurrentBytes = -1) then
    ProgressBar.Style := pbstMarquee
  else begin
    if Operation.State = fsosRunning then ProgressBar.Style := pbstNormal;
    ProgressBar.SetProgress(CurrentBytes, TotalBytes,
                            cnvFormatFileSize(CurrentBytes, True) + 'B/' +
                            cnvFormatFileSize(TotalBytes, True) + 'B'
                            );
  end;
end;
 
 
procedure TfrmFileOp.SetProgressFiles(Operation: TFileSourceOperation;
  ProgressBar: TKASProgressBar; CurrentFiles: Int64; TotalFiles: Int64);
begin
  if (CurrentFiles = -1) then
    ProgressBar.Style := pbstMarquee
  else begin
    if Operation.State = fsosRunning then ProgressBar.Style := pbstNormal;
    ProgressBar.SetProgress(CurrentFiles, TotalFiles,
                            cnvFormatFileSize(CurrentFiles, True) + '/' +
                            cnvFormatFileSize(TotalFiles, True)
                            );
  end;
end;

Ami calmant, J.P

2 pièce(s) jointe(s)

A priori, il n'existe pas de solution toute faite.

Mais comme les autres personnes l'ont déjà indiqué dans ce sujet, créer soi-même une fonction pour le faire ou adapter une solution déjà existante n'est pas très compliqué.

Exemple: adaptation de la classe TCopyDir (cf. http://forum.lazarus.freepascal.org/...?topic=20759.0)

J'ai juste rajouté ici une fonction callback après chaque copie de fichier (quelques lignes de code pour la modification):
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 ... CopyDir := TCopyDir.Create(DIRIN, DirOut); CopyDir.CopyHiddenFiles := false; CopyDir.CopySystemFiles := false; CopyDir.OnProgress := @Self.CDOnProgress; // ajout d'une fonction callback CopyDir.Start; ... procedure TForm1.CDOnProgress(FilesDone: Integer; FilesFailed: Integer; TotalFiles: Integer); var i1: Integer; begin if TotalFiles<>0 then // sanity begin i1 := (((FilesDone + FilesFailed) * 100) div TotalFiles); if i1<>ProgressBar1.Position then begin ProgressBar1.Position := i1; Application.ProcessMessages; end; end; end;
Ce n'est qu'une modification assez grossière, mais c'était essentiellement dans un but démonstratif:
- callback sur le nombre de fichiers et non le nombre d'octets copiés; donc problème si les tailles des fichiers sont très différentes et/ou s'il y a de très gros fichiers,
- code non optimisé; utiliser Length() pour les nombres de fichiers est loin d'être efficace,
- fonction callback de mon programme exemple très basique; sans compter le lag habituel des ProgressBar, au moins sous Windows.

Programme exemple incluant la modification de la classe TCopyDir concernée (fichier CopyDir.pas) attaché.

1 pièce(s) jointe(s)

Et pour le fun uniquement, un exemple avec IFileOperation (pour Windows uniquement, donc), sur lequel je ne m'étais jamais penché auparavant.

C'est seulement vraiment très dommage que toutes les déclarations Windows n'aient pas encore été converties pour Free Pascal, car il faut avouer que c'est un travail plutôt pénible.

Exemple repris depuis http://zarko-gajic.iz.hr/replacing-s...l-delphi-code/

- 1ère version uniquement, qui ne fonctionne pas si le répertoire de destination n'existe pas déjà,
- exemple pour une forme avec 2 TButtons et 1 TStaticText.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
 
unit Unit1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    StaticText1: TStaticText;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
 
  public
 
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.lfm}
 
uses
  Windows, ShlObj, ActiveX, ComObj,
  LazUTF8;
 
{ TForm1 }
 
//------------------------------------------------------------------------------
 
// IFileOperation declarations
 
const
    // OPPROGDLGF
    OPPROGDLG_DEFAULT               = 0;
    OPPROGDLG_ENABLEPAUSE           = $80;
    OPPROGDLG_ALLOWUNDO             = $100;
    OPPROGDLG_DONTDISPLAYSOURCEPATH = $200;
    OPPROGDLG_DONTDISPLAYDESTPATH   = $400;
    OPPROGDLG_NOMULTIDAYESTIMATES   = $800;
    OPPROGDLG_DONTDISPLAYLOCATIONS  = $1000;
    // SPACTION
    SPACTION_NONE                   = 0;
    SPACTION_MOVING                 = ( SPACTION_NONE + 1 );
    SPACTION_COPYING                = ( SPACTION_MOVING + 1 );
    SPACTION_RECYCLING              = ( SPACTION_COPYING + 1 );
    SPACTION_APPLYINGATTRIBS        = ( SPACTION_RECYCLING + 1 );
    SPACTION_DOWNLOADING            = ( SPACTION_APPLYINGATTRIBS + 1 );
    SPACTION_SEARCHING_INTERNET     = ( SPACTION_DOWNLOADING + 1 );
    SPACTION_CALCULATING            = ( SPACTION_SEARCHING_INTERNET + 1 );
    SPACTION_UPLOADING              = ( SPACTION_CALCULATING + 1 );
    SPACTION_SEARCHING_FILES        = ( SPACTION_UPLOADING + 1 );
    SPACTION_DELETING               = ( SPACTION_SEARCHING_FILES + 1 );
    SPACTION_RENAMING               = ( SPACTION_DELETING + 1 );
    SPACTION_FORMATTING             = ( SPACTION_RENAMING + 1 );
    SPACTION_COPY_MOVING            = ( SPACTION_FORMATTING + 1 );
    // PDMODE
    PDM_DEFAULT                     = 0;
    PDM_RUN                         = $1;
    PDM_PREFLIGHT                   = $2;
    PDM_UNDOING                     = $4;
    PDM_ERRORSBLOCKING              = $8;
    PDM_INDETERMINATE               = $10;
    // PDOPSTATUS
    PDOPS_RUNNING                   = 1;
    PDOPS_PAUSED                    = 2;
    PDOPS_CANCELLED                 = 3;
    PDOPS_STOPPED                   = 4;
    PDOPS_ERRORS                    = 5;
 
type
    IOperationsProgressDialog = interface(IUnknown)
      ['{0c9fb851-e5c9-43eb-a370-f0677b13874c}']
      function StartProgressDialog(hwndOwner: HWND; flags: DWORD): HResult; stdcall;    // flags: OPPROGDLGF
      function StopProgressDialog: HResult; stdcall;
      function SetOperation(action: DWORD): HResult; stdcall;       // action: SPACTION
      function SetMode(mode: DWORD): HResult; stdcall;              // mode: PDMODE
      function UpdateProgress(ullPointsCurrent: ULONGLONG; ullPointsTotal: ULONGLONG; ullSizeCurrent: ULONGLONG; ullSizeTotal: ULONGLONG; ullItemsCurrent: ULONGLONG; ullItemsTotal: ULONGLONG): HResult; stdcall;
      function UpdateLocations(psiSource: IShellItem; psiTarget: IShellItem; psiItem: IShellItem): HResult; stdcall;
      function ResetTimer: HResult; stdcall;
      function PauseTimer: HResult; stdcall;
      function ResumeTimer: HResult; stdcall;
      function GetMilliseconds(out pullElapsed: ULONGLONG; out pullRemaining: ULONGLONG): HResult; stdcall;
      function GetOperationStatus(out popstatus: DWORD): HResult; stdcall;    	// popstatus: PDOPSTATUS
    end;
 
    IObjectWithPropertyKey = interface(IUnknown)
      ['{fc0ca0a7-c316-4fd2-9031-3e628e6d4f23}']
      function SetPropertyKey(key: REFPROPERTYKEY): HResult; stdcall;
      function GetPropertyKey(out pKey: PROPERTYKEY): HResult; stdcall;
    end;
 
    IPropertyChange = interface(IObjectWithPropertyKey)
      ['{f917bc8a-1bba-4478-a245-1bde03eb9431}']
      function ApplyToPropVariant(propvarIn: REFPROPVARIANT; out ppropvarOut: PROPVARIANT): HResult; stdcall;
    end;
 
    IPropertyChangeArray = interface(IUnknown)
      ['{380f5cad-1b5e-42f2-805d-637fd392d31e}']
      function GetCount(out pcOperations: UINT): HResult; stdcall;
      function GetAt(iIndex: UINT; const riid: REFIID; out ppv: PPointer): HResult; stdcall;
      function InsertAt(iIndex: UINT; ppropChange: IPropertyChange): HResult; stdcall;
      function Append(ppropChange: IPropertyChange): HResult; stdcall;
      function AppendOrReplace(ppropChange: IPropertyChange): HResult; stdcall;
      function RemoveAt(iIndex: UINT): HResult; stdcall;
      function IsKeyInArray(key: REFPROPERTYKEY): HResult; stdcall;
    end;
 
    IFileOperation = interface(IUnknown)
      ['{947aab5f-0a5c-4c13-b4d6-4bf7836fc9f8}']
      function Advise(pfops: IFileOperationProgressSink; out pdwcookie: DWORD): HResult; stdcall;
      function Unadvise(dwCookie: DWORD): HResult; stdcall;
      function SetOperationFlags(dwOperationFlags: DWORD): HResult; stdcall;
      function SetProgressMessage(pszMessage: LPCWSTR): HResult; stdcall;
      function SetProgressDialog(popd: IOperationsProgressDialog): HResult; stdcall;
      function SetProperties(pproparray: IPropertyChangeArray): HResult; stdcall;
      function SetOwnerWindow(hwndOwner: HWND): HResult; stdcall;
      function ApplyPropertiesToItem(psiItem: IShellItem): HResult; stdcall;
      function ApplyPropertiesToItems(punkItems: IUnknown): HResult; stdcall;
      function RenameItem(psiItem: IShellItem; pszNewName: LPCWSTR; pfopsItem: IFileOperationProgressSink): HResult; stdcall;
      function RenameItems(punkItems: IUnknown; pszNewName: LPCWSTR): HResult; stdcall;
      function MoveItem(psiItem: IShellItem; psiDestinationFolder: IShellItem; pszNewName: LPCWSTR; pfopsItem: IFileOperationProgressSink): HResult; stdcall;
      function MoveItems(punkItems: IUnknown; psiDestinationFolder: IShellItem): HResult; stdcall;
      function CopyItem(psiItem: IShellItem; psiDestinationFolder: IShellItem; pszCopyName: LPCWSTR; pfopsItem: IFileOperationProgressSink): HResult; stdcall;
      function CopyItems(punkItems: IUnknown; psiDestinationFolder: IShellItem): HResult; stdcall;
      function DeleteItem(psiItem: IShellItem; pfopsItem: IFileOperationProgressSink): HResult; stdcall;
      function DeleteItems(punkItems: IUnknown): HResult; stdcall;
      function NewItem(psiDestinationFolder: IShellItem; dwFileAttributes: DWORD; pszName: LPCWSTR; pszTemplateName: LPCWSTR; pfopsItem: IFileOperationProgressSink): HResult; stdcall;
      function PerformOperations: HResult; stdcall;
      function GetAnyOperationsAborted(out pfAnyOperationsAborted: BOOL): HResult; stdcall;
    end;
 
//------------------------------------------------------------------------------
 
const
    CLSID_FileOperation: TGUID  = '{3ad05575-8857-4850-9277-11b85bdb8e09}';
 
// /* Extended file operation flags */
// #if (_WIN32_IE >= 0x0700)
const
    FOFX_NOSKIPJUNCTIONS        = $00010000;
    FOFX_PREFERHARDLINK         = $00020000;
    FOFX_SHOWELEVATIONPROMPT    = $00040000;
    FOFX_EARLYFAILURE           = $00100000;
    FOFX_PRESERVEFILEEXTENSIONS = $00200000;
    FOFX_KEEPNEWERFILE          = $00400000;
    FOFX_NOCOPYHOOKS            = $00800000;
    FOFX_NOMINIMIZEBOX          = $01000000;
    FOFX_MOVEACLSACROSSVOLUMES  = $02000000;
    FOFX_DONTDISPLAYSOURCEPATH  = $04000000;
    FOFX_DONTDISPLAYDESTPATH    = $08000000;
    FOFX_REQUIREELEVATION       = $10000000;
    FOFX_COPYASDOWNLOAD         = $20000000;
    FOFX_DONTDISPLAYLOCATIONS   = $40000000;
// #endif
 
// /* Functions in SHELL32.DLL */
// #if (_WIN32_IE >= 0x0700)
function SHCreateItemFromParsingName(pszPath: LPCWSTR; pbc: IBindCTX; const riid: REFIID; out ppv): HResult; stdcall; external 'shell32' name 'SHCreateItemFromParsingName';
// #endif
 
function CopyFileIFileOperation(const srcFile, destFile : widestring) : boolean;
//works on Windows >= Vista and 2008 server
var
  r : HRESULT;
  fileOp: IFileOperation;
  siSrcFile: IShellItem;
  siDestFolder: IShellItem;
  destFileFolder, destFileName : widestring;
begin
  result := false;
 
  destFileFolder := ExtractFileDir(destFile);
  destFileName := ExtractFileName(destFile);
 
  //init com
  r := CoInitializeEx(nil, COINIT_APARTMENTTHREADED or COINIT_DISABLE_OLE1DDE);
  if Succeeded(r) then
  begin
    //create IFileOperation interface
    r := CoCreateInstance(CLSID_FileOperation, nil, CLSCTX_ALL, IFileOperation, fileOp);
    if Succeeded(r) then
    begin
      //set operations flags
      r := fileOp.SetOperationFlags(FOF_NOCONFIRMATION OR FOFX_NOMINIMIZEBOX);
      if Succeeded(r) then
      begin
        //get source shell item
        r := SHCreateItemFromParsingName(PWideChar(srcFile), nil, IShellItem, siSrcFile);
        if Succeeded(r) then
        begin
          //get destination folder shell item
          r := SHCreateItemFromParsingName(PWideChar(destFileFolder), nil, IShellItem, siDestFolder);
 
          //add copy operation
          if Succeeded(r) then r := fileOp.CopyItem(siSrcFile, siDestFolder, PWideChar(destFileName), nil);
        end;
 
        //execute
        if Succeeded(r) then r := fileOp.PerformOperations;
 
        result := Succeeded(r);
 
        OleCheck(r);
      end;
    end;
 
    CoUninitialize;
  end;
end;
 
//------------------------------------------------------------------------------
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.Terminate;
end;
 
procedure TForm1.Button2Click(Sender: TObject);
const DIRIN = 'C:\lazarus\lcl';
var DirOut: string;
var l1: boolean;
begin
  StaticText1.Caption := ' Copying...';
  DirOut := GetCurrentDir() + '\CopyOfLCL\';    // must exists
  try
    l1 := CopyFileIFileOperation(UTF8ToUTF16(DIRIN), UTF8ToUTF16(DirOut));
  except
    l1 := False;
  end;
  if l1 then
    StaticText1.Caption := ' Copy done'
  else
    StaticText1.Caption := ' Error';
end;
 
end.

1 pièce(s) jointe(s)

Citation:

Envoyé par FChrisF

Dans fpc, tu devrais jeter un oeil dans les unités shellapi, shlobj.

Voici un autre code toujours que pour windows :aie: qui utilise les shFileOperations :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
unit Unit1;
{$mode objfpc}{$H+}
interface
 
uses
  windows, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  ComCtrls,shellapi;
 
type
  { TForm1 }
 
 
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
 
  public
 
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.lfm}
function CopyDir(const fromDir, toDir: string): Boolean;
var
  fos: TSHFileOpStruct;
begin
  ZeroMemory(@fos, SizeOf(fos));
  with fos do
  begin
    wFunc  := FO_COPY;
    fFlags := FOF_FILESONLY;
    pFrom  := PChar(fromDir + #0);
    pTo    := PChar(toDir)
  end;
  Result := (0 = ShFileOperation(fos));
end;
 
function MoveDir(const fromDir, toDir: string): Boolean;
var
  fos: TSHFileOpStruct;
begin
  ZeroMemory(@fos, SizeOf(fos));
  with fos do
  begin
    wFunc  := FO_MOVE;
    fFlags := FOF_FILESONLY;
    pFrom  := PChar(fromDir + #0);
    pTo    := PChar(toDir)
  end;
  Result := (0 = ShFileOperation(fos));
end;
 
function DelDir(dir: string): Boolean;
var
  fos: TSHFileOpStruct;
begin
  ZeroMemory(@fos, SizeOf(fos));
  with fos do
  begin
    wFunc  := FO_DELETE;
    fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
    pFrom  := PChar(dir + #0);
  end;
  Result := (0 = ShFileOperation(fos));
end;
 
 
{ TForm1 }
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.Terminate;
end;
 
procedure TForm1.Button2Click(Sender: TObject);
const DIRIN = 'M:\Test\';
var DirOut: String;
begin
  ProgressBar1.Position := 0;
  Memo1.Clear; Memo1.Lines.Add(' Copying...');
  DirOut := GetCurrentDir() + '\CopyOfDir\';
  CopyDir(DirIn,DirOut);
end;
 
end.

Pièce jointe 401218

ami calmant J.P

1 pièce(s) jointe(s)

hello,
sous linux, voici une solution possible en utilisant l'excellent utilitaire de copie rsync lancé dans Lazarus grâce au composant TprocessEx (voir ici)
Le principe :
Grâce au composant TprocessEx qui permet d'exécuter un programme externe et de récupérer ce qu'il affiche pendant l'exécution , on lance rsync pour une copie avec un affichage de la progression.
Voici le type de ligne qui est affiché :

Citation:

309.68M 50% 63.10MB/s 0:00:04 (xfr#355, to-chk=197/634)

Dans la fenêtre Lazarus on affiche ce qui est renvoyé par rsync dans un TMemo et on utilise le composant Tregexpr pour récupérer grâce aux expressions régulières, le pourcentage effectué et le nombre de fichiers restant à copier sur le nombre total de fichiers. Dans une barre de progression on affiche le pourcentage effectué et dans un label on affiche le nombre de fichiers restant à copier sur le nombre total de fichiers.
Voici le code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
unit Unit1;
{$mode objfpc}{$H+}
 
 
interface
uses
   {$IFDEF LINUX}
     baseUnix,
   {$ENDIF}
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  Menus, ComCtrls, Process, regexpr, Processutils;
 
 
type
  { TForm1 }
  TForm1 = class(TForm)
    Bt_Stop: TButton;
    Bt_GoEx: TButton;
    Bt_Abort: TButton;
    FicEnCours: TLabel;
    MemConsole: TMemo;
    ProgressBar1: TProgressBar;
    procedure Bt_AbortClick(Sender: TObject);
    procedure Bt_StopClick(Sender: TObject);
    procedure Bt_GoExClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
 
 
  public
    procedure ProcessOutput(Sender:TProcessEx; output:string);
    procedure ProcessError(Sender:TProcessEx; {%H-}IsException:boolean);
  end;
 
 
var
  Form1: TForm1;
  Proc: TProcessEx;
  RegexObj: TRegExpr;
 
 
implementation
 
 
{$R *.lfm}
 
 
{ TForm1 }
 
 
procedure TForm1.Bt_StopClick(Sender: TObject);
  begin
  if Proc <> Nil then
   begin
   Proc.Terminate(0);
   Proc := nil;
   end;
 
 
  end;
 
 
procedure TForm1.Bt_AbortClick(Sender: TObject);
begin
if Proc <> Nil then
   begin
   fpKill(Proc.ProcessID,SIGINT);
   Proc := nil;
   end;
end;
 
 
procedure TForm1.Bt_GoExClick(Sender: TObject);
var dirin,dirout : string;
begin
   dirin := '/home/jurassic/examples/';
   dirout := '/home/jurassic/BackupExamples/';
  try
   Proc := TProcessEx.Create(nil);
   Proc.Executable := '/usr/bin/rsync';
   Proc.Parameters.Add('-hr');
   Proc.Parameters.Add('--no-i-r');
   Proc.Parameters.Add('--info=progress2');
   Proc.Parameters.Add(dirin);
   Proc.Parameters.Add(dirout);
   Proc.OnErrorM:=@(ProcessError);
   Proc.OnOutputM:=@(ProcessOutput);
   Proc.Execute();
   finally
     Proc.Free;
     Proc := nil;
   end;
end;
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  RegexObj := TRegExpr.Create;
  RegexObj.Expression := ' \s.*\s(\d+)%.*chk=(.*)\).*';
  Proc :=  Nil;
end;
 
 
procedure TForm1.ProcessError(Sender: TProcessEx; IsException: boolean);
begin
   MemConsole.Lines.Append('Erreur ! ' + Sender.ExceptionInfo);
end;
 
 
procedure TForm1.ProcessOutput(Sender: TProcessEx; output : string);
begin
  if RegexObj.Exec(output) then
      begin
      ProgressBar1.Position := StrtoInt(RegexObj.Match[1]);
      FicEnCours.Caption := RegexObj.Match[2];
      end;
   MemConsole.Lines.Text :=  MemConsole.Lines.Text + output;
  // pour scroll automatique
  MemConsole.SelStart := Length(MemConsole.Lines.Text)-1;
  MemConsole.SelLength:=0;
end;
end.

Et voici le résultat sous Lubuntu 16.04 avec Lazarus 1.8.2 :

Pièce jointe 401248

A noter que rsync suivant les distributions linux n'est pas présent par défaut et qu'il faut installer le paquet.

Ami calmant, J.P

03/08/2018, 13h03
FChrisF

Citation:

Envoyé par jurassic pork

Dans fpc, tu devrais jeter un oeil dans les unités shellapi, shlobj.
[...]

Oui, "l'ancienne" API Windows SHFileOperation y est bien, en effet.

Mais la "nouvelle" interface Windows IFileOperation n'y est pas; tout comme la plupart des "nouvelles" interfaces venues avec Windows Vista et plus. A part quelques rares exceptions, utilisées par ailleurs par Lazarus et la LCL.

J'ai d'ailleurs l'impression que FPC en est plus ou moins resté à la version Delphi 7 en ce qui concerner les déclarations Windows, non ?

Cela permet ainsi de faire le tour de ce qui donc possible directement avec Windows.
03/08/2018, 15h58
BeanzMaster

Bonjour,

Je ne sais si c'est de la même interface que tu parles mais dans l'unité win32Extra on peux trouver IFileOperationProgressSink il y a également les unités jwa* provenant de la JCL/JVCL qui se trouvent dans le dossier fpcsrc\packages\winunits-jedi\src qui contiennent bon nombre de déclarations d'api non présentes dans l'unité Windows
03/08/2018, 18h56
FChrisF

Citation:

Envoyé par BeanzMaster

Je ne sais si c'est de la même interface que tu parles mais dans l'unité win32Extra on peux trouver IFileOperationProgressSink il y a également les unités jwa* provenant de la JCL/JVCL qui se trouvent dans le dossier fpcsrc\packages\winunits-jedi\src qui contiennent bon nombre de déclarations d'api non présentes dans l'unité Windows

Eh bien, la "sous-interface" IFileOperationProgressSink est utilisée dans plusieurs méthodes de l'interface IFileOperation (cf. le code source que j'ai posté auparavant).

Mais c'est en fait une interface commune, utilisée également par d'autres interfaces; notamment comme pour l'interface IFileSaveDialog, qui fait partie des rares "nouvelles" interfaces utilisées par la LCL. D'où probablement la présence de cette déclaration.

Concernant les unités Jedi, j'avais déjà vérifié: rien en ce qui la concerne. En tous les cas pas pour les versions actuelles de FPC (3.0.4) et Lazarus (1.8.2 - bon d'accord, en fait j'ai une version de retard pour Lazarus).

Mais il y a probablement quelqu'un qui a déjà fait le travail, ou au moins une partie du travail. Je n'ai pas vraiment cherché sur Internet, mais il est possible que cela existe déjà (ces "nouvelles" interfaces sont d'ailleurs disponibles dans Delphi).
03/08/2018, 20h15
foetus

Citation:

Envoyé par FChrisF

Mais il y a probablement quelqu'un qui a déjà fait le travail, ou au moins une partie du travail. Je n'ai pas vraiment cherché sur Internet, mais il est possible que cela existe déjà

Je peux me tromper mais si tu utilises les APIs sorties depuis Vista, il me semble que Microsoft force à avoir un manifeste Windows 8.

Et donc, tu fais une croix pour la comptabilité Windows XP :whistle: :whistle:

Pourcentage	100	X
Elements	Total	Copiés

Pourcentage	100	X
Elements	Total	Copiés