[XL-2007] Création d'une série de répertoire sur le bureau [Résolu]

[Jeromeric]

Bonjour à tous,

Une fois de plus, je fais appelle à votre expérience pour ce petit problème que je me pose.

Je viens d'adapter deux macros :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'Créer sur le bureau un nouveau dossier nommé : "Planning  S+ n°sem"
Sub MacroDossierSem()
Dim NumSem As Byte
 
NumSem = DatePart("ww", Date, 2, 2)
 
Const Cible = &H10 'Bureau
Dim objShell As Object
Dim objFolder As Object, objFolderItem As Object
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(Cible)
Set objFolderItem = objFolder.Self
 
MkDir objFolderItem.Path & "\" & "Planning S" & NumSem
 
End Sub

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
'Créer sur le bureau un nouveau dossier nommé comme l'onglet actif
Sub MacroPlanning()
Dim NumSem As Byte
Dim NomFeuille As String
 
NumSem = DatePart("ww", Date, 2, 2)
NomFeuille = ActiveSheet.Name
 
Const Cible = "C:\Users\Jerome\Desktop"
Dim objShell As Object
Dim objFolder As Object, objFolderItem As Object
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(Cible)
Set objFolderItem = objFolder.Self
 
MkDir objFolderItem.Path & "\" & NomFeuille
 
End Sub

Ces deux macros fonctionnent bien séparément mais comment faire pour les mixer en un seul code ? Je voudrais que le répertoire "NomOngletActif" soit créé dans le repertoire "Planning SX" sur le bureau.

J'ai bien essayé : Const Cible = "C:\Users\Jerome\Desktop\Planning S & NumSem"
Mais ça ne fonctionne pas (ça m'aurait étonné car il doit cherché un dossier intitulé exactement "Planning S & NumSem" non ?)

En écrivant ces lignes, je me rends compte qu'un autre problème se posera ensuite. Je serai amené à créer plusieurs repertoires dans "Planning SX", comment faire dans ce cas pour ne créer ce dossier que s'il n'existe pas ?

Auriez-vous une solution par hasard ?

Merci d'avance.

[Jeromeric]

Je viens de trouver

En fouillant un peu (beaucoup) sur le net, je suis tombé sur ce bout de code que je viens de finir d'adapter.

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
'Créer un répertoire et ses répertoires parents
Function MakeDirEx(DirPath$) As Boolean
Dim i%, tmp, Arr
 
If InStr(1, DirPath, ":") = 0 Then
Arr = Split(CurDir & DirPath, "\")
Else: Arr = Split(DirPath, "\")
End If
 
tmp = Arr(0)
For i = LBound(Arr) + 1 To UBound(Arr)
If Arr(i) <> "" Then
tmp = tmp & "\" & Arr(i)
On Error Resume Next
MkDir tmp
On Error GoTo 0
End If
Next
 
If Dir(DirPath, vbDirectory) = "" Then
On Error Resume Next
RmDir Arr(0) & "\" & Arr(1)
On Error GoTo 0
Else
MakeDirEx = True
End If
 
End Function
 
Sub MacroPlanning()
Dim NumSem As Byte
Dim CheminBureau As String, NomDossier As String, NomFeuille As String
 
CheminBureau = "C:\Users\Jerome\Desktop\"
NumSem = DatePart("ww", Date, 2, 2)
NomDossier = "Planning S" & NumSem
NomFeuille = ActiveSheet.Name
 
dossier$ = CheminBureau & "\" & NomDossier & "\" & NomFeuille
MakeDirEx (dossier)
End Sub

Cela aidera peut-être quelqu'un un jour.

A+