[VB] Copie de fichiers

Fermé
sophie26 - 22 avril 2008 à 14:53
 Alerte20012 - 28 juil. 2008 à 16:44
Bonjour,
J'ai un petit soucie avec mon code, en effet je l'ai battis grâce à des sources et des cours sur vbfrance et developpez.com et j'ai surement mal compris un bout de code ce qui me blok dans mon développement.
En effet j'aimerai pouvoir copier l'ensemble d'un fichier dans un autre que ci ce fichier est présent dans un autre (lors de la comparaison) et que ce fichier est plus récent. Si c'est le cas je voudrais copier l'ensemble des dossiers et sous dossiers

Je vous propose le code avec lequelle je suis en train de me débattre ^^.
N'hésitez pas à critiquer le tout ou à me fair part d'informations

Dim fso As New FileSystemObject
Dim fld As Folder
Dim Etape As Byte
Dim v As Boolean

Private Sub Command1_Click()

Dim Flag As Byte

On Error GoTo GestErreur

' *** CHOIX DES REPERTOIRES A COMPARER ***

Flag = 0

CHOIXREP:

If Flag = 0 Then
szTitle = "Selectionner le répertoire à comparer :"
ElseIf Flag = 1 Then
szTitle = "Selectionner le répertoire à mettre à jour :"
Else
GoTo Exit_Sub
End If

With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)

If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
If Flag = 0 Then
ValRep1 = sBuffer
If DirectoryExist(ValRep1) = True Then
Flag = 1
GoTo CHOIXREP
Else
MsgBox "Répertoire incorrect !", vbCritical, "recommencez"
GoTo Exit_Sub
End If
ElseIf Flag = 1 Then
ValRep2 = sBuffer
If DirectoryExist(ValRep2) = False Then
MsgBox "Répertoire incorrect !", vbCritical, "recommencez"
GoTo Exit_Sub
End If
End If
End If

If MsgBox("Voulez-vous mettre à jour le répertoire " & ValRep2 & " avec " & ValRep1 & " ?", vbInformation + vbYesNo, "Question") = vbNo Then Exit Sub

MousePointer = 11

FindFile ValRep1, "*.*"

MousePointer = 0

MsgBox "Mise à jour terminée !", vbInformation, "Fin"


Exit_Sub:
MousePointer = 0
Exit Sub

GestErreur:
MsgBox Err.Description, vbExclamation, Err
Resume Exit_Sub

End Sub

Function FindFile(ByVal sFol As String, sFile As String)

Dim tFld As Folder
Dim FileName As String
Dim FileVerif As String
Dim FileTrouve As String
Dim Pos As Long
Dim k As Integer
Dim j As Integer
j = 0
k = 0
Set fld = fso.GetFolder(sFol)

FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or vbHidden Or vbSystem Or vbReadOnly)


While Len(FileName) <> 0

FileTrouve = fso.BuildPath(fld.Path, FileName)

Pos = Len(ValRep1)

FileVerif = ValRep2 & Right(FileTrouve, Len(FileTrouve) - Pos)

If FileExist(FileVerif) = False Then

Else
If FileDateTime(FileTrouve) > FileDateTime(FileVerif) Then
CopyFile FileTrouve, FileVerif, 0
List1.AddItem FileVerif, k
k = k + 1
End If
End If
CopyFile FileTrouve, FileVerif, 0
List2.AddItem FileTrouve, j
j = j + 1
FileName = Dir() ' Get next file
DoEvents

Wend

If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
Pos = Len(ValRep1)
If DirectoryExist(ValRep2 & Right(tFld, Len(tFld) - Pos)) = False Then
MkDir ValRep2 & Right(tFld, Len(tFld) - Pos)
End If
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile)
Next
End If

End Function
A voir également:

1 réponse

Franchement,
moi je lis rien, tu devrais apprendre à documenter ton code source
0