Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum. Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !

Sujet : Ne pas copier les fichiers ou rép existants [ Archives Visual Basic / Fichier / Disque ] (lmb19)

lundi 28 novembre 2005 à 10:14:51 | Ne pas copier les fichiers ou rép existants

lmb19

Bonjour,

J'ai réalisé un petit programme pour copier le contenu d'un répertoire (fichiers+sous-répertoires) cf ci-dessous

quelles lignes de commande dois-je ajouter si je ne veux pas que celui-ci copie les fichiers ou répertoires déjà existants.

merci d'avance
----------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim FichOuRep As String
Dim i As Integer
Dim j As Integer
Dim Tab1() As String
Dim Tab2() As String

x = 0

InitDir = "D:\CEM\"
TargetDir = "C:\AA\"

If Right(InitDir, 1) <> "\" Then InitDir = InitDir & "\"
If Right(TargetDir, 1) <> "\" Then TargetDir = TargetDir & "\"

FichOuRep = Dir(InitDir, vbDirectory + vbArchive)

On Error Resume Next 'problème avec certains fichiers comme pagefile.sys
Do While FichOuRep <> ""
If FichOuRep <> "." And FichOuRep <> ".." Then
If (GetAttr(InitDir & FichOuRep) And vbDirectory) = vbDirectory Then
i = i + 1
ReDim Preserve Tab1(i)
Tab1(i) = FichOuRep
Else
j = j + 1
ReDim Preserve Tab2(j)
Tab2(j) = FichOuRep
End If
End If
FichOuRep = Dir
Loop
On Error GoTo 0

For i = 1 To UBound(Tab1)
ProgressBar1 = (i * 50) / UBound(Tab1)
If FichierExist(TargetDir & Tab1(i) & "\") = False Then
MkDir TargetDir & Tab1(i)
End If
If FichierExist(TargetDir & Tab1(i)) = False Then
CopieRep InitDir & Tab1(i), TargetDir & Tab1(i)
End If
Next
For j = 1 To UBound(Tab2)
ProgressBar1 = 50 + ((j * 50) / UBound(Tab2))
If FichierExist(TargetDir & Tab2(j)) = False Then
FileCopy InitDir & Tab2(j), TargetDir & Tab2(j)
x = x + 1
Label1.Caption = x
Label1.Refresh
End If
Next
End Sub
---------------------------------------------------------------------------------------
Private Sub CopieRep(InitDir As String, TargetDir As String)

Dim FichOuRep As String
p = 0
If Right(InitDir, 1) <> "\" Then InitDir = InitDir & "\"
If Right(TargetDir, 1) <> "\" Then TargetDir = TargetDir & "\"

FichOuRep = Dir(InitDir, vbDirectory + vbArchive)

Do While FichOuRep <> ""

If FichOuRep <> "." And FichOuRep <> ".." Then
If (GetAttr(InitDir & FichOuRep) And vbDirectory) = vbDirectory Then

MkDir TargetDir & FichOuRep
CopieRep InitDir & FichOuRep, TargetDir & FichOuRep

Else

FileCopy InitDir & FichOuRep, TargetDir & FichOuRep
x = x + 1
Label1.Caption = x
Label1.Refresh

End If
End If

FichOuRep = Dir

Loop
End Sub



lundi 28 novembre 2005 à 12:32:56 | Re : Ne pas copier les fichiers ou rép existants

Gobillot

il reste à gérer la ProgressBar et les erreurs.
comme je sais pas d'avance combien il va y avoir de fichiers à copier ...
tout le traitement se fait dans une seule boucle.
et une seule Table suffit.



Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long

Dim initdir   As String
Dim targetdir As String

Private Sub Command1_Click()
    Dim i         As Integer
    Dim j         As Integer
    Dim Path      As String
    Dim Path1     As String
    Dim Path2     As String
    Dim FichOuRep As String
    Dim Tab1()    As String
   
    initdir = "D:\CEM\"
    targetdir = "C:\AA\"
  
    i = 1
    ReDim Tab1(1): Tab1(1) = ""
   
While j < i
    j = j + 1
    Path = Tab1(j)
    Path1 = initdir & Path
    Path2 = targetdir & Path
   
    If GetFileAttributes(Path2) = -1 Then MkDir Path2
   
    FichOuRep = Dir$(Path1 & "*.*", vbDirectory)
   
    Do While FichOuRep <> ""
       If FichOuRep <> "." And FichOuRep <> ".." Then
          If (GetAttr(Path1 & FichOuRep) And vbDirectory) = vbDirectory Then
              i = i + 1
              ReDim Preserve Tab1(i)
              Tab1(i) = Path & FichOuRep & "\"
              Else
              If GetFileAttributes(Path2 & FichOuRep) = -1 Then
                 FileCopy Path1 & FichOuRep, Path2 & FichOuRep
                 End If
             End If
          End If
       FichOuRep = Dir$()
       Loop
   
Wend
   
End Sub


Daniel

lundi 28 novembre 2005 à 13:37:03 | Re : Ne pas copier les fichiers ou rép existants

Gobillot

"quelles lignes de commande dois-je ajouter si je ne veux pas que celui-ci copie les fichiers ou répertoires déjà existants."
j'ai seulement vérifier l'existence comme indiqué dans la question.
donc si le fichier a été modifié depuis, il ne sera pas recopié.


il faudrait utiliser l'attribut Archive qui est fait pour ça.
en cas de copie: mettre l'attribut Archive du fichier à copier à zéro
tout changement du fichier repositionnera l'attribut Archive.
ensuite il suffit de tester:
si attribut Archive il faut recopier le fichier même si existe déjà.

Daniel

lundi 28 novembre 2005 à 23:11:00 | Re : Ne pas copier les fichiers ou rép existants

lmb19

Bonjour Daniel,

Tout d'abord respect ! J'ai testé ton code, nickel !

Par contre comme tu le dis, si certains fichier sont modifiés, ils ne seront pas recopiés.

j'ai relu plusieurs fois ton explication sur l'ATTRIBUT :" il faudrait utiliser l'attribut Archive qui est fait pour ça. En cas de copie: mettre l'attribut Archive du fichier à copier à zéro tout changement du fichier repositionnera l'attribut Archive.
ensuite il suffit de tester: si attribut Archive il faut recopier le fichier même si existe déjà
." mais je n'arrive pas à mettre ça en place.

d'après l'aide Visual Basic, j'ai
vbArchive    32    File has changed since last backup
donc j'utilise la commande : Result = GetAttr(Path2 & FichOuRep) And vbArchive
mais je ne vois pas ce que tu entends par "mettre l'attribut Archive du fichier à copier à zéro tout changement du fichier repositionnera l'attribut Archive"

J'ai donc encore besoin de ton aide
merci


lundi 28 novembre 2005 à 23:36:11 | Re : Ne pas copier les fichiers ou rép existants

Gobillot

un fichier nouvellement créé a l'attribut Archive (=32)

on teste le Fichier s'il est à copier
source = Path1 & FichOuRep
If GetAttr(source And vbArchive) Then
   'le Fichier est à copier  (nouveau ou modifié)
   Else
   'on ne fait rien
   End If

s' il existe déjà, on le tue
destination = Path2 & FichOuRep
If GetFileAttributes(destination) <> -1 Then Kill destination

ensuite on le copie
FileCopy source, destination

et enfin on supprime l'Attribut Archive
SetAttr source, 0   ' j'ai ignoré les autres attributs caché, système, read only, ...

si le fichier est ensuite modifié, renommé, l'Attribut Archive sera automatiquement remis par le système.

NB: il reste un problème, les fichiers supprimés sont pas détectés.

Daniel

mardi 29 novembre 2005 à 10:12:54 | Re : Ne pas copier les fichiers ou rép existants

lmb19

J'ai mis en place ce que tu m'as expliqué, mais j'ai déjà un problème à la ligne :
If GetAttr(source And vbArchive) Then

j'ai donc remplacé par If (GetAttr(Source) And vbArchive) Then
le code n'a plus d'erreur, mais il ne copie même plus les fichiers que je supprime.

voici le code :

Private Sub Command1_Click()
    Dim i         As Integer
    Dim j         As Integer
    Dim Path      As String
    Dim Path1     As String
    Dim Path2     As String
    Dim FichOuRep As String
    Dim Tab1()    As String
  
    j = 0
    initdir = "D:\CEM\"
    targetdir = "C:\AA\"
    i = 1
    ReDim Tab1(1): Tab1(1) = ""
  
While j < i
    j = j + 1
    Path = Tab1(j)
    Path1 = initdir & Path
    Path2 = targetdir & Path
  
    If GetFileAttributes(Path2) = -1 Then MkDir Path2
  
    FichOuRep = Dir$(Path1 & "*.*", vbDirectory)
  
    Do While FichOuRep <> ""
       If FichOuRep <> "." And FichOuRep <> ".." Then
          If (GetAttr(Path1 & FichOuRep) And vbDirectory) = vbDirectory Then
              i = i + 1
              ReDim Preserve Tab1(i)
              Tab1(i) = Path & FichOuRep & "\"
              Else
              'on teste le Fichier s'il est à copier
              Source = Path1 & FichOuRep

              If (GetAttr(Source) And vbArchive) Then

              'le Fichier est à copier  (nouveau ou modifié)
              's' il existe déjà, on le tue
              destination = Path2 & FichOuRep
              If GetFileAttributes(destination) <> -1 Then Kill destination

              'ensuite on le copie
              FileCopy Source, destination

              'et enfin on supprime l'Attribut Archive
              SetAttr Source, 0   ' j'ai ignoré les autres attributs caché,système,read only

              Else
              'on ne fait rien
  
              End If
             End If
          End If
       FichOuRep = Dir$()
       Loop
  
Wend


mardi 29 novembre 2005 à 13:06:08 | Re : Ne pas copier les fichiers ou rép existants

Gobillot

Réponse acceptée !
voilà j'ai tout refait.
apparition de nouvelles variables: Attribut et Copie.




Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long

Dim initdir   As String
Dim targetdir As String

Private Sub Command1_Click()
    Dim i           As Integer
    Dim j           As Integer
    Dim Attribut    As Long
    Dim Path        As String
    Dim Path1       As String
    Dim Path2       As String
    Dim FichOuRep   As String
    Dim Tab1()      As String
    Dim Source      As String
    Dim Destination As String
    Dim Copie       As Boolean
   
    initdir = "D:\CEM\"
    targetdir = "C:\AA\"
   
    i = 1
    ReDim Tab1(1): Tab1(1) = ""
   
    While j < i
        j = j + 1
        Path = Tab1(j)
        Path1 = initdir & Path
        Path2 = targetdir & Path
       
        If GetFileAttributes(Path2) = -1 Then MkDir Path2
       
        FichOuRep = Dir$(Path1 & "*.*", vbDirectory)
       
        Do While FichOuRep <> ""
           If FichOuRep <> "." And FichOuRep <> ".." Then
              Source = Path1 & FichOuRep
              Attribut = GetAttr(Source)
              If Attribut And vbDirectory Then
                  i = i + 1
                  ReDim Preserve Tab1(i)
                  Tab1(i) = Path & FichOuRep & "\"
                  Else
                  Destination = Path2 & FichOuRep
                 
              '   si fichier n'existe pas on le copie
                  If GetFileAttributes(Destination) = -1 Then
                     Copie = True
                     Else
              '   sinon on teste s'il a été modifié ou pas
                     If Attribut And vbArchive Then
                     '  on le tue d'abord avant de le copier
                        Kill Destination
                        Copie = True
                        End If
                     End If
                    
                 If Copie Then
                    FileCopy Source, Destination
                 '  et enfin on supprime l'Attribut Archive
                    SetAttr Source, Attribut And 31
                    End If
                   
                 End If
              End If
           FichOuRep = Dir$()
           Loop
       
        Wend
   
End Sub


Daniel

mardi 29 novembre 2005 à 13:11:34 | Re : Ne pas copier les fichiers ou rép existants

Gobillot

oups !!
il manque la remise à False du Boolean



                 If Copie Then
                    FileCopy Source, Destination
                 '  et enfin on supprime l'Attribut Archive
                    SetAttr Source, Attribut And 31
                    Copie = False
                    End If


Daniel

mardi 29 novembre 2005 à 20:01:35 | Re : Ne pas copier les fichiers ou rép existants

lmb19

j'ai testé ça fonctionne parfaitement.

Merci encore beaucoup cette aide

A+


mercredi 30 novembre 2005 à 16:53:09 | Re : Ne pas copier les fichiers ou rép existants

ouzzinfall

Salut
j'ai votre discution c'est vraiment passionnent
je vient de débuter le vb6.0
j'aimerai être comme vous.


1 2

Cette discussion est classé dans : end, tab1, initdir, fichourep, targetdir


Répondre à ce message

Sujets en rapport avec ce message

Copy Repertoire ! [ par castor62 ] BOnjour !J'ai tenter de faire le code suivant pour copier un repertoire mais j'ai un bug au niveau du DIR qd il y a trop de chose ...Private Sub Comm pb avec une sgbd et la propriete Filter [ par nilmar ] bonjour, je prépare un projet sous vb avec une base de données oracle en support. J'ai réussi à faire le lien entre la base et le datagrid ainsi que l Sauvegarder document Excel et Word au format PDF, sans intervention [ par ggenier ] Bonjour,N'ayant pas réussi à faire des pdf en ligne de commande, voici un petit code (selon le logiciel utilisé) qui remplira la fenêtre qui s'ouvre a Salut, je suis débutant, j'ai besoin d'aide. [ par link78180 ] Salut.Tout d'abord, je tiens à vous dire que je viens de débuter dans la programmation en Visual Basic (il y a à peine une heure), et avant, j'avais t Treeview : classement alphabétique [ par PHILOUVB ] J'utilise un Treeview pour afficher les différents répertoires et fichier de mon ordinateur.Or l'affichage ne se fait pas avec un classement alphabéti tri par insertion [ par breton53 ] Je dois évrire la procédure de tri par insertion des données suivantes contenu dans un fichier excel:Nb_villes 5Nb_jours 4Angers 18,5 17,9 18,9 18,1To ouvrir un fichier texte enregistrer sous un repertoire et sous repertoire [ par cmelmel ] bonjour à tous,je ne parviens pas à ouvrir unfichier texte enregistré dans un répertoire puis sous repertoire etc....je joins le code pour enregistrer A Delphiprog, ReplaceDialog et RichEdit [ par Jean-Pierre ] Bonjour,Encore merci du code ci-dessous que tu as eu la gentillesse de réaliser l'autre fois.Il fonctionne impec avec un Memo.Or là, je viens de voir Utilisation de timers [ par yoyo_29 ] Bonjour,après avoir appris (essayé) à utiliser les timers grace en partie à ce site, j'ai essayé de refaire un porgramme de la meme sorte qu'un que j' requet avec adodb [ par sernams ] slt a tou le monde,j'ai un probleme avec la requete suivante Set MonRs = New ADODB.Recordset MonRs.open "select * from CPL where end cnn1 est v


Nos sponsors

Sondage...

CalendriCode

Juillet 2009
LMMJVSD
  12345
6789101112
13141516171819
20212223242526
2728293031  

Consulter la suite du CalendriCode

Téléchargements

Logiciels à télécharger sur le même thème :

Comparez les prix Nouvelle version


HTC Magic

Entre 429€ et 429€


Photothèque Nouveau !



Développement réalisé par Nicolas SOREL (Nix) avec l'aide de : Cyril DURAND et Emmanuel (EBArtSoft), Merci à Vincent pour ses précieux conseils
CodeS-SourceS.com© Toute reproduction même partielle est interdite sauf accord écrit du Webmaster
CodeS-SourceS.com© est une marque déposée tous droits réservés
Temps d'éxécution de la page : 3,260 sec

Google Coop CodeS-SourceS Google Coop CodeS-SourceS


Certaines images présentes sur le site (notament certains avatars) sont issues des collections IconShock, donc si vous souhaitez utiliser ces icons vous devez les acheter, ne les copiez pas et ne utilisez pas dans vos sites et applications sans les avoir commandé.