Copier un dossier vers un autre dossier avec ajout de l'extension aux fichiers

Version imprimable

Voir 40 message(s) de cette discussion en une page

Bonjour à toutes et à tous,

Avec une fonction pour copier un dossier vers un autre dossier, j'aimerai pouvoir copier que les fichiers du 1er dossier qui ont un poids de plus >250K et leur ajouter une extension soit .jpg.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 function CopyFolder(FromFld, ToFld: string): boolean; var fos: TSHFileopStruct; begin // il faut supprimer les antislashs de fin sinon vous aurez droit à un message d'erreur FromFld := ExcludeTrailingPathDelimiter(Trim(FromFld)); ToFld := ExcludeTrailingPathDelimiter(Trim(ToFld)); FillChar(fos, SizeOf(fos),0); with fos do begin wFunc := FO_COPY; pFrom := PChar(FromFld+#0); pTo := PChar(ToFld+#0); fFlags := FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR; end; Result := ShFileOperation(fos)=0; end;
J'utilise Windows 10 64bits et D6.

Si quelqu'un avait une idée merci d'avance.

@+,

cincap

14/11/2019, 13h58
tourlourou

La solution passe peut-être par une boucle FindFirst/FindNext avec exploitation du TSearchRec et copie fichier par fichier.

Bonjour,

if faut créer le répertoire de destination s'il n'existe pas (ForceDirectories ) puis utiliser FindFirst et FindNext :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
var
  sr       : TSearchRec ;
  FileAttrs: Integer ;
  Chemin   : String ;
begin
  FileAttrs := faAnyFile ;
  if FindFirst(Chemin, FileAttrs, sr) = 0 then
    begin
      repeat
        if (sr.Attr and FileAttrs) = sr.Attr then
        begin
//         Copy du fichier et modification de l'extension
        end;
      until FindNext(sr) <> 0 ;
      FindClose(sr) ;
    end;
  end;

(code non testé)

Si tu as des sous-répertoires, regarde ici

A+
Charly

@ tourlourou et @ Charly910, merci pour vos suggestions que je vais tester.

@ Charly910, avec la fonction décrite à mon topic, comme le DossierOriginal existe, elle crée le DossierFinal si il n'existe pas !

Pour son utilisation :
Code:

1 2 3 4 5 6 7 8 procedure TForm1.Button1Click(Sender: TObject); begin if copyfolder('C:\DossierOriginal','C:\DossierFinal') then ShowMessage('Copie effectuée avec succès') else ShowMessage('Copie non effectuée'); end;
Je vais tester et pour vous rassurer c'est en fait que je suis en train de reprendre des anciennes applications et de chercher d'autres solutions.

@+,

cincap

Bonsoir,

il y a surement mieux et plus simple, mais essaye comme ceci :

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
function CopyFolder(FromFld, ToFld: string): boolean;
Var
  sr       : TSearchRec ;
  FileAttrs: Integer ;
  Chemin   : String ;
  FicRes   : String ;
 
Begin
  FromFld := IncludeTrailingPathDelimiter(Trim(FromFld)) ;
  ToFld := IncludeTrailingPathDelimiter(Trim(ToFld)) ;
 
  // Contrôle des entrées
  If not DirectoryExists(FromFld) Then
    Begin
      Result := False ;
      Exit ;
    End ;
  If (ToFld = '') Then    // Sinon ForceDirectories échoue
    Begin
      Result := False ;
      Exit ;
    End ;
 
  // Création éventuelle du répertoire cible
  SysUtils.ForceDirectories(ToFld) ;
  If not DirectoryExists(ToFld) Then
    Begin
      Result := False ;
      Exit ;
    End ;
 
  //  Exploration du répertoire source
  Chemin:=FromFld+'*.*' ;
  Result:=True;
  FileAttrs := faAnyFile ;
  if FindFirst(Chemin, FileAttrs, sr) = 0 then
    begin
      repeat
        If ((Sr.Name<>'.')And(sr.Name<>'..') And ((Sr.Attr And faDirectory)=0)) Then
        begin
//         Copy du fichier et modification de l'extension
          FicRes := ToFld+sr.Name ;
          FicRes := ChangeFileExt(FicRes, '.jpg') ;
          If not Windows.CopyFile(PChar(FromFld+sr.Name), PChar(FicRes), False) Then
            Begin
              Result := False ;
              FindClose(sr) ;
              Exit ;
            End
        end;
      until FindNext(sr) <> 0 ;
      FindClose(sr) ;
    end;
  Result := True ;
End;

A+
Charly

14/11/2019, 20h02
pprem

Modernisez-vous et oubliez les FindFirst / FindNext et TSearchrec : passez à http://docwiki.embarcadero.com/Libra...ctory.GetFiles avec un filtre géré sous forme de predicate. (si votre version de Delphi est assez récente, bien entendu).
15/11/2019, 08h23
cincap

Bonjour à toutes et à tous,

@ pprem, merci de ton intervention mais à mon âge, je suis toujours sous Delphi 6 comme précisé dans mon topic.

Citation:

J'utilise Windows 10 64bits et D6.

@ Charly910, excellent travail, cela fonctionne correctement pour les 3/4 de ce que j'aimerai, reste à ne sauver que les fichiers qui ont un poids supérieur à 250 Kb.

En effet dans le dossier original, les fichiers n'ont pas d'extensions et avec la nouvelle mouture de la fonction, tous les fichiers sont bien copié avec l'extension dans ce cas .jpg.

J'ai testé mais sans bon résultat, je vous tiens au courant.

@+,

cincap
15/11/2019, 08h38
SergioMaster

Bonjour,

Citation:

Envoyé par cincap

reste à ne sauver que les fichiers qui ont un poids supérieur à 250 Kb.

à ma souvenance, que j'ai été rafraîchir, la structure de SearchRec contient l'information de taille (Size) en octets.
Donc, en ajoutant dans le test (ligne 39) une nouvelle condition AND (sr.size>=250*1024) il n'y a pas à soulever ce point
15/11/2019, 09h55
Charly910

Oui, j'avais zappé le coup des 250 kb !! il suffit en effet de le rajouter dans le test.

je ne sais pas si le test sur . et .. est strictement indispensable dans ce cas ou on a filtré les directory ?

A+
Charly
15/11/2019, 09h58
Charly910

Effectivement je pense que l'on peut enlever : (Sr.Name<>'.') And (sr.Name<>'..')

A+
Charly
15/11/2019, 13h07
cincap
@ SergioMaster et @ Charly910 c'est exactement cela, j'avais testé sur une ligne ceci qui ne fonctionnait pas :
Code:

1 2 FloatToStrF(Sr.Size/250000, ffFixed, 7, 2)
Sans avoir pensé directement dans le processus de recherche.

A ce stade, je pourrai aussi tester une autre condition suivant la largeur de l'image .jpg (width) qui est de 1920 x 1080 car dans ce dossier il existe aussi un fichier convertit en image de 1080 x 1920 qui ne m'intéresse pas et qui est aussi copié (demi mal).

Je ferme le topic puisque l'excellente solution correspond à mon topic.

Grand merci à @ SergioMaster et @ Charly910 et les autres.

@+,

cincap
15/11/2019, 14h06
SergioMaster

Citation:

Envoyé par cincap

A ce stade, je pourrai aussi tester une autre condition suivant la largeur de l'image .jpg (width) qui est de 1920 x 1080 car dans ce dossier il existe aussi un fichier convertit en image de 1080 x 1920 qui ne m'intéresse pas et qui est aussi copié (demi mal).

Ah, non, pour cela il faudrait charger le fichier dans un Tbitmap (ou plutôt un TJpeg) pour pouvoir tester ces caractéristiques

Bonsoir,

pour faire plaisir à Patrick, voici la version "moderne" en D10.3 :

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
function CopyFolder(FromFld, ToFld: string): boolean ;
var
  LList: TStringDynArray;
  i    : Integer;
  LSearchOption: TSearchOption;
  Chemin   : String ;
  f: file of Byte;
  size: Longint;
Begin
  FromFld := IncludeTrailingPathDelimiter(Trim(FromFld)) ;
  ToFld := IncludeTrailingPathDelimiter(Trim(ToFld)) ;
 
  // Contrôle des entrées
  If not DirectoryExists(FromFld) Then
    Begin
      Result := False ;
      Exit ;
    End ;
  If (ToFld = '') Then    // Sinon ForceDirectories échoue
    Begin
      Result := False ;
      Exit ;
    End ;
 
  // Création éventuelle du répertoire cible
  ForceDirectories(ToFld) ;
  If not DirectoryExists(ToFld) Then
    Begin
      Result := False ;
      Exit ;
    End ;
 
  //  Exploration du répertoire source
  Chemin:=FromFld+'*.*' ;
  Result:=True;
 
  { Recherche non récursive }
  LSearchOption := TSearchOption.soTopDirectoryOnly;
 
  try
    { Recherche des fichiers }
    LList := TDirectory.GetFiles(FromFld, '*.*', LSearchOption);
 
  except
    { En cas d'erreur }
    Result := False ;
    MessageDlg('Chemin incorrect ou filtre de fichier incorrect', mtError, [mbOK], 0);
    Exit;
  end;
 
  { Copie des fichiers }
  for i := 0 to Length(LList) - 1 do
    Begin
       AssignFile(f, LList[i]);
      Reset(f);
      try
        size := FileSize(f);
        // à voir s'il faut modifier le test sur la taille ??
        If Size > 250 * 1024 Then TFile.Copy(LList[i], ToFld+TPath.GetFileNameWithoutExtension(LList[i])+'.jpg', True);
       finally
        CloseFile(f);
      end;
    End;
  Result := True ; 
end;

A+
Charly

16/11/2019, 08h50
cincap

Bonjour à toutes et à tous,

@ SergioMaster, merci de ta réponse, je vais à l'occasion tester la fonction concernant la largeur de l'image .jpg.

@ Charly910, je suppose que ta modification servira aux versions supérieures à D6 ?

Car sinon après test j'obtiens deux erreurs à la compilation :

Citation:

LList: TStringDynArray;

LSearchOption: TSearchOption;

Ce qui me parait normal vu le contexte.

Encore merci d'avoir trouvé une excellente solution à mon topic.

@+,

cincap

Bonjour,

le type TStringDynArray n'existe que dans les versions plus récentes de Delphi (par exemple la 10.3 dont tu peux télécharger gratuitement la version Community)

Sinon pour connaitre et tester les dimensions de tes Jpeg, tu peux utiliser cette fonction :
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 function TailleImgJpg(Image : String) : TPoint ; // Dimensions en pixels du fichier Image // Uses Jpeg ... Var Jpeg1 : TJpegImage ; Ext : String ; IsJpg : Boolean ; Begin Result.X := 0 ; Result.Y := 0 ; // Test du fichier If not FileExists(Image) Then Exit ; Ext := UpperCase(ExtractFileExt(Image)) ; IsJpg := (Ext = '.JPG') or (Ext = '.JPEG') ; If not IsJpg Then Exit ; // Chargement et calcul de la Taille Jpeg1 := TJpegImage.Create; try Jpeg1.LoadFromFile(Image); Result.X := Jpeg1.Width ; Result.Y := Jpeg1.Height ; finally Jpeg1.Free; end; End ;
Largeur : TailleImgJpg(Image).X
Hauteur : TailleImgJpg(Image).Y

A+
Charly

Citation:

Envoyé par Charly910

pour faire plaisir à Patrick, voici la version "moderne" en D10.3 :

Je pense que pprem pensait plus à quelque chose comme ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
function CopyFolder(const aSource, aDest :string): boolean;
begin
  if not DirectoryExists(aSource) or
     aDest.IsEmpty                or
     not ForceDirectories(aDest)  then Exit(FALSE);
 
  var Files := TDirectory.GetFiles(aSource, '*.*', TSearchOption.soTopDirectoryOnly, function(const Path: string; const SearchRec: TSearchRec): Boolean
                                                                                     begin
                                                                                       Result := SearchRec.Size >= 250 *1024;
                                                                                     end);
  for var F in Files do
    TFile.Copy(F, TPath.Combine(aDest, TPath.GetFileName(F) +'.jpg'));
 
  Result := TRUE;
end;

16/11/2019, 14h02
Charly910

J'avais quand même TDirectory.GetFiles(FromFld, '*.*', LSearchOption) de bon ! :mouarf::mouarf:

Merci pour cette fonction qui pourra me resservir ;)

A+
Charly
16/11/2019, 14h07
tourlourou

Très belle version du code ! Chapeau... C'est comme en littérature : plus beau quand il n'y a rien de trop. Et que ce soit efficace, plus qu'un exercice de style à la Queneau.
16/11/2019, 14h31
Andnotor

Merci pour les :fleur::fleur:

;)
16/11/2019, 17h09
pprem

Citation:

Envoyé par Andnotor

Je pense que pprem pensait plus à quelque chose comme ceci

En effet, mais j'avais pas vu qu'il était en Delphi 6 et par conséquent cette solution hyper pratique ne passe pas puisque System.IOUtils n'est apparu que bien plus tard.

Voir 40 message(s) de cette discussion en une page