Discussion :

[Mechsangoku]

Bonjour à tous,

Je cherche a créer une macro qui me permette d'automatiser la création de dossier / sous dossier, etc... puis de déplacer un document dans ce nouveau dossier.

J'ai mes documents dans un dossier C:\Test\
Et j'ai dans un fichier xls, 4-5 colonnes avec pour les 4 premières des noms de dossier, sous dossier et sous sous dossier, et dans la 5ème le nom de document
Les premières cases sont des noms d'entitées et la 5ème le nom du document PDF

En gros, il faudrait que la macro fasse:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
For i to Line 
If  
Ai & "\" & Bi & "\" & Ci & "\" 
Exist then 
Move Di to Ai & "\" & Bi & "\" & Ci & "\" 
 
Else Then  
MKDir Ai & "/" & Bi & "/" & Ci & "/" 
Move Di to Ai & "/" & Bi & "/" & Ci & "/" 
 
End if 
Next

Je me rend compte qu'il faut s’assurer également que:

- Si le dossier existe, il faut passer au sous dossier suivant;
par exemple si j'ai créé EG / COM / TF / aga.pdf
et que je me retrouve sur la ligne EG / COM / GE / areu.pdf
il faut que le programme reconnaisse que les deux premiers niveaux existent mais créée le dossier GE au niveau 3...

- des dossiers de niveau 2 ou 3 peuvent ne pas exister, qu'il faut donc passer au suivant;
par exemple, je peux le retrouver avec une ligne type EG / "vide " / DES / Aplouf.pdf

J'ai commencé par la base, j'ai une idée de comment l'écrire et quoi utiliser, mais je suis rapidement perdu...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub create()
    Dim NouveauChemin As String
    Dim Origine As String
    Dim Ligne As Integer, i As Integer
 
    Ligne = ActiveSheet.UsedRange.Rows.Count
    Origine = Application.InputBox(Prompt:="Where are files ?" )
    Origine = Origine + "\"
    NouveauChemin = Application.InputBox(Prompt:="where to create foldertree" )
    NouveauChemin = NouveauChemin + "\"
 
    For i = 2 To Ligne
        MkDir NouveauChemin & Cells(i, 1) & Cells(i, 2) & Cells(i, 3) & Cells(i, 4)
        Filecopy "C:\PDF\" & Cells(i, 5)", "C:\Arbo\ & nouveauchemin &"\"& Cells(i, 5)"
 
  Next
End Sub

Tout aide est la bienvenue.

Merci !

[Invité]

regarde ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Sub test()
Dim WinXp As New clsWindowsExporer
WinXp.Creer_Repertoires "C:\toto\toto\toto\toto"
WinXp.Creer_Repertoires "C:\titi\titi\titi\titi"
msg = WinXp.Deplace_Repertoire("c:\titi", "c:\toto\")
If Trim("" & msg) <> "" Then MsgBox msg
End Sub

Code Classe clsWindowsExporer :

Sélectionner tout - Visualiser dans une fenêtre à part

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
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon False
Public Function Repertoires_Existe(Repertoires As String) As Boolean
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = Fso.FolderExists(Repertoires)
Set Fso = Nothing
End Function
'Taille d'un répertoire
Public Function Taille_Repertoire(Repertoire)
Dim Fso As Object
Dim Rep As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = Fso.GetFolder(Repertoire)
    Taille_Repertoire = Rep.Size
End Function
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires(NewRepertoires As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim t
Dim R As String
Dim I As Long
R = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t)
    If Trim("" & t(I)) <> "" Then
        R = R & Trim("" & t(I)) & "\"
        If Repertoires_Existe(R) = False Then Fso.CreateFolder "" & R
    End If
Next
Set Fso = Nothing
End Sub
 
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFolder Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Function Deplace_Repertoire(Source As String, Destination As String) As String
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Fso.MoveFolder Source, Destination
If Err > 0 Then Deplace_Repertoire = Err.Description
Err.Clear
On Error GoTo 0
Set Fso = Nothing
End Function
 
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire(DelRepertoire As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFolder DelRepertoire, True
Set Fso = Nothing
End Sub
'Taille d'un répertoire
Public Function Taille_Fichier(Fichier)
Dim Fso As Object
Dim Fich As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fich = Fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = Fso.FileExists(Fichier)
Set Fso = Nothing
End Function
'Retourne le nom du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_Name(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Name = Fso.GetBaseName(Fichier)
Set Fso = Nothing
End If
End Function
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = Fso.GetExtensionName(Fichier)
Set Fso = Nothing
End If
End Function
 
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFile Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.MoveFile Source, Destination
Set Fso = Nothing
End Sub
 
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier(DelFichier As String)
If Fichier_Exist(DelFichier) = True Then
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFile DelFichier, True
Set Fso = Nothing
End If
End Sub
Function AppendTxt(sFile, sText)
Dim Fso, NewFichier
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(sFile, 8)
 
NewFichier.Write sText
NewFichier.Close
 
Set NewFichier = Nothing
Set Fso = Nothing
 
End Function
 
Public Sub FichierLog(sFile, txt)
Dim FichierLog, Fso
 
FichierLog = sFile
 
 
''CreerPath FichierLog
 
Set Fso = CreateObject("Scripting.FileSystemObject")
 
If Fso.FileExists(FichierLog) = False Then EnteteFichier FichierLog
 
AppendTxt FichierLog, txt
 
Set Fso = Nothing
End Sub
 
Private Sub EnteteFichier(Fichier)
Dim txt, Fso, NewFichier
 
txt = "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & ""
txt = txt & vbCrLf
txt = txt & "   Date de création: " & Day(Now) & "/" & Month(Now) & "/" & Year(Now) & " " & Hour(Time) & ":" & Minute(Time) & vbCrLf
txt = txt & vbCrLf
txt = txt & "   " & Fichier
txt = txt & vbCrLf
txt = txt & "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & vbCrLf
txt = ""
 'WScript.Echo Fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write txt
NewFichier.Close
 
 
Set NewFichier = Nothing
Set Fso = Nothing
End Sub

[Mechsangoku]

Wow,

Merci rdurupt

J'ai même pas eu le temps d'éditer la question.
Je vais jeter un coup d'oeil, leecher un peu et je posterais le fruit de mes réfelxions

[Mechsangoku]

Re Moi,

Alors j'ai finalement réussi a composer ca:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Sub startCreating()
 
    Call CreateDirectory(2, 1)
 
End Sub
 
Sub CreateDirectory(ByVal row As Long, ByVal col As Long, Optional ByRef path As String)
 
    If (Len(ActiveSheet.Cells(row, col).Value) <= 0) Then
        Exit Sub
    End If
 
    Dim sDir As String
    Dim Source As String
    Dim Documentpath As String
    Dim File As String
    Dim Target As String
 
Documentpath = "E:\test mailing officiel\Output PDF\"
 
    If (Len(path) <= 0) Then
        path = ActiveSheet.Cells(row, col).Value
        sDir = "E:\test\" & path
    Else
        sDir = path & "\" & ActiveSheet.Cells(row, col).Value
    End If
 
 
    If (FileOrDirExists(sDir) = False) Then
        MkDir sDir
    End If
 
    If (Len(ActiveSheet.Cells(row, col + 1).Value) <= 0) Then
        Source = Documentpath & Cells(row, col + 2)
        File = Cells(row, col + 2)
            If (Len(File) <= 0) Then
            File = Cells(row, (col + 2) + 1)
            Source = Documentpath & Cells(row, (col + 2) + 1)
        Target = sDir & "\" & File
        FileCopy Source, Target
        Call CreateDirectory(row + 1, 1)
            Else
        Target = sDir & "\" & File
        FileCopy Source, Target
        Call CreateDirectory(row + 1, 1)
        End If
 
    Else
        Call CreateDirectory(row, col + 1, sDir)
    End If
 
End Sub
 
 
' Function thanks to: http://www.vbaexpress.com/kb/getarticle.php?kb_id=559
Function FileOrDirExists(PathName As String) As Boolean
     'Macro Purpose: Function returns TRUE if the specified file
     '               or folder exists, false if not.
     'PathName     : Supports Windows mapped drives or UNC
     '             : Supports Macintosh paths
     'File usage   : Provide full file path and extension
     'Folder usage : Provide full folder path
     '               Accepts with/without trailing "\" (Windows)
     '               Accepts with/without trailing ":" (Macintosh)
 
    Dim iTemp As Integer
 
     'Ignore errors to allow for error evaluation
    On Error Resume Next
    iTemp = GetAttr(PathName)
 
     'Check if error exists and set response appropriately
    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select
 
     'Resume error checking
    On Error GoTo 0
End Function

Ca marche pas mal sur les différents tests que j'ai fais, cela dis, j'aimerai bien ajouter un msgbox pour récuperer les dossier d'entré / sortie.
Mais les variables ne vont pas pouvoir traverser les subs que j'ai.

Une idée ?

Merci