VBA - Création de dossier et rangement de PDF

Bonjour à tous,

J'ai un petit sujet VBA, si quelqu'un peux m'aider ce serait top, je ne m'y connais pas du tout en VBA de traitement de dossier / fichier.

J'ai un dossier (dossiers A) dans lequel j'ai X sous-dossiers (dossiers B). Dans ces sous-dossiers j'ai Y raccourci pointant vers d'autres dossiers (dossiers C). Dans ces dossiers C j'ai un PDF (parmi d'autres fichiers).

J'aimerais trouver une formule VBA qui rentre dans chaque dossiers B, puis dans chaque dossiers C, qui copie le PDF à l'intérieur des dossiers C, et le colle dans les dossiers B.

S'il y a moyen de supprimer les raccourci par la suite je ne dis pas non ^^.

Merci d'avance pour votre aide !

Iwo

Bonjour,

Est-ce que les dossiers B et leurs enfants contiennent des fichiers autres que ce PDF ?

Cdlt,

Bonjour 3GB !

Merci pour ton aide.

Les dossiers B ne contiennent que les raccourcis (avant le collage des PDF cependant grâce à la fameuse macro). Les dossiers C contiennent 1 unique PDF ainsi que d'autres dossiers et autre fichier de type diverse.

J'espère que cela répond à ta question, sinon je reste à disposition :)

Ok, alors voici un premier :

sub test()
spath$ = "moncheminDossierA" 'sans antislash de fin !!!
set fso = createobject("Scripting.filesystemobject")
for each sfd in fso.getfolder(spath).subfolders
    Sonder sfd.path
next sfd
end sub

Sub Sonder(srepdest$, optional srepsrc$)
if srepsrc = "" then srepsrc = srepdest
set fso = createobject("Scripting.filesystemobject")
set fd = fso.getfolder(srepsrc)
if fd.files.count = 1 then
    for each fil in fd.files
        fso.copyfile fil.path, srepdest & "\" & fil.name: exit sub
    next fil
end if
for each sfd in fd.subfolders
    Sonder srepdest, sfd.path
next fd
end sub

Je ne garantis rien car c'est toujours assez délicat ce genre de problèmes...

Cdlt,

Merci beaucoup pour ton aide 3GB, ça marche nickel quand je change le Next fd -> Next sfd.

Cependant ça marche uniquement si dans le dossier B j'ai directement le dossier C, sauf que la il ne s'agit pas du dossier mais d'un raccourcis, et dans ce dernier cas il ne se passe rien.

De plus je vois que si j'ai plusieurs fichiers dans le dossier C (d'extensions variées), le PDF du dossier C en question n'est pas copié, il passe directement au dossier suivant.

Penses-tu pouvoir faire ces modifs ? :)

Pour le type de fichier, ça me semble possible. Pour le problème du raccourci, il faut que je regarde plus attentivement mais je ne suis pas sûr de trouver la solution.

Je reviens vers toi dès que possible.

Hello,

Voici un code qui ouvre tous les fichiers excel sous format raccourcis dans un dossier.

Il faudra l'adapter au pdf & au code de 3gb.

Par contre pourquoi passer par des dossiers + sous dossiers + raccourcis et non par le chemin exact du fichier pdf directement ?

++

Sub BoucleDir()
Dim Chemin As String, Fichier As String
    Chemin = "C:\Users\EXCEL_VBA\"
    Fichier = Dir(Chemin & "*.lnk")
    If Fichier <> "" Then
        Do
            Workbooks.Open Chemin & Fichier
            Fichier = Dir
        Loop While Fichier <> ""
    End If
End Sub

Bonjour à vous deux !

@Rag0700 merci beaucoup pour ce code mais je t'avoue que je n'ai pas les compétences pour l'adapter à mon sujet :/

La structure windows dans lesquels se trouvent les PDF sont ainsi rangés, c'est pourquoi il y a cette contrainte de structuration : de dossier A -> dossiers B -> raccourcis dossier C -> PDF (parmi d'autres fichiers)

@3GB merci beaucoup j'attends donc ton retour :)

Bonjour iwo, Salut Rag02700,

Voici un nouvel essai (pas testé) :

Sub test()
spath$ = "moncheminDossierA" 'sans antislash de fin !!!
Set fso = CreateObject("Scripting.filesystemobject")
For Each sfd In fso.getfolder(spath).subfolders
    Sonder sfd.Path
Next sfd
End Sub

Sub Sonder(srepdest$, Optional srepsrc$)
If srepsrc = "" Then srepsrc = srepdest
Set fso = CreateObject("Scripting.filesystemobject")
Set fd = fso.getfolder(srepsrc)
For Each fil In fd.Files
    If fil.Name Like "*.pdf" Then
        fso.copyfile fil.Path, srepdest & "\" & fil.Name: Exit Sub
    ElseIf fil.Type = "Raccourci" and not fil.name like "*.*.*" Then 'If fil.Name Like "*.lnk" Then
        Sonder srepdest, GetTargetPath(fil.Path)
    End If
Next fil
For Each sfd In fd.subfolders
    Sonder srepdest, sfd.Path
Next sfd
End Sub

Function GetTargetPath(lnkFolderPath As String) As String
GetTargetPath = CreateObject("Wscript.Shell").CreateShortcut(lnkFolderPath).targetpath
End Function

J'espère que ça marchera. Bien entendu, il faut avoir accès aux dossiers cibles des raccourcis...

Cdlt,

Génial 3GB ça marche comme sur des roulettes :)

Merci beaucoup et bonne journée à vous !

Nickel !

Merci, bonne journée à toi également !

Rebonjour 3GB !

au risque d'abuser de ta gentillesse ... Penses-tu qu'il serait possible d'ajouter quelques lignes de code pour supprimer les raccourcis, et autres dossiers et fichiers contenu dans les dossiers C ?

tout en gardant les PDF ayant été copié bien sur :)

Sinon c'est pas grave, la solution que tu m'as apporté est déjà très bien et me fera gagner un temps fou ^^

Re iwo,

Voici un nouvel essai, à bien tester sur des copies bien séparées pour éviter toute surprise !!!

Sub test()
spath$ = "moncheminDossierA" 'sans antislash de fin !!!
Set fso = CreateObject("Scripting.filesystemobject")
For Each sfd In fso.getfolder(spath).subfolders
    Sonder sfd.Path
Next sfd
End Sub

Sub Sonder(srepdest$, Optional srepsrc$)
If srepsrc = "" Then srepsrc = srepdest
Set fso = CreateObject("Scripting.filesystemobject")
Set fd = fso.getfolder(srepsrc)
For Each fil In fd.Files
    If fil.Name Like "*.pdf" Then
        fso.copyfile fil.Path, srepdest & "\" & fil.Name: Exit Sub
    ElseIf fil.Type = "Raccourci" and not fil.name like "*.*.*" Then 'If fil.Name Like "*.lnk" Then
        sTargetpath$ = GetTargetPath(fil.Path)
        if fso.folderexists(sTargetpath) then
            Sonder srepdest, sTargetpath
            fso.deletefolder sTargetpath, true 'pour supprimer les dossiers cibles après copie pdf
            fso.deletefile fil.path, true 'suppression raccourci
        end if
    End If
Next fil
For Each sfd In fd.subfolders
    Sonder srepdest, sfd.Path
Next sfd
End Sub

Function GetTargetPath(lnkFolderPath As String) As String
GetTargetPath = CreateObject("Wscript.Shell").CreateShortcut(lnkFolderPath).targetpath
End Function

Le code est censé supprimé le dossier cible des raccourcis (c'est à dire C si j'ai bien suivi) puis le raccourci lui-même, après la copie du pdf ou après achèvement d'une vaine recherche de celui-ci.

Je n'ai pas testé et il est fort probable qu'il y ait un probable lors de la suppression du raccourci car on supprime un élément d'une collection pendant qu'on boucle dessus...

A voir,

Hello 3GB !

Merci beaucoup pour ton aide, le code marche très bien :)

Par contre je me suis trompé, il faut supprimer les raccourcis qui sont dans les dossiers B uniquement (et non pas ceux des dossiers C, il ne faut justement rien supprimer dans ceux-ci qui sont les dossiers sources pour nos données). Et il faudrait également supprimer tous les autres dossiers (non pas les fichiers car je peux avoir des excel également que je souhaiterais garder) contenu dans les dossiers B.

Si tu pouvais me faire ces dernières modifs ce serait top :)

Salut iwo,

Désolé, je ne connais pas assez bien ton arborescence pour bien comprendre . Pour les raccourcis, ça va (il suffit d'enlever une ligne au code) :

Sub test()
spath$ = "moncheminDossierA" 'sans antislash de fin !!!
Set fso = CreateObject("Scripting.filesystemobject")
For Each sfd In fso.getfolder(spath).subfolders
    Sonder sfd.Path
Next sfd
End Sub

Sub Sonder(srepdest$, Optional srepsrc$)
If srepsrc = "" Then srepsrc = srepdest
Set fso = CreateObject("Scripting.filesystemobject")
Set fd = fso.getfolder(srepsrc)
For Each fil In fd.Files
    If fil.Name Like "*.pdf" Then
        fso.copyfile fil.Path, srepdest & "\" & fil.Name: Exit Sub
    ElseIf fil.Type = "Raccourci" and not fil.name like "*.*.*" Then 'If fil.Name Like "*.lnk" Then
        sTargetpath$ = GetTargetPath(fil.Path)
        if fso.folderexists(sTargetpath) then
            Sonder srepdest, sTargetpath
            fso.deletefile fil.path, true 'suppression raccourci
        end if
    End If
Next fil
For Each sfd In fd.subfolders
    Sonder srepdest, sfd.Path
Next sfd
End Sub

Function GetTargetPath(lnkFolderPath As String) As String
GetTargetPath = CreateObject("Wscript.Shell").CreateShortcut(lnkFolderPath).targetpath
End Function

A ce propos, le code n'occasionne aucun bug ?!?

Pour le reste, il faut que tu me réexpliques mieux. Est-ce qu'il faut supprimer tous les dossiers contenus dans les dossiers C, cibles des raccourcis, sans toucher aux fichiers ? Le petit problème, c'est que la méthode deletefolder supprime un dossier sans tenir compte de son contenu. Donc Faut-il tester qu'un dossier contienne des fichiers avant de supprimer ?

Hello 3GB

Aucun problème, ce doit être moi qui ne suis pas clair ;)

Pour répondre a ta petite question le code n'occasionne aucun bug ^^

Pour clarifier l'arborescence :

Description du dossier A : contenant des dossier B

Description des dossiers B : Contenant des raccourci qui vont vers les dossiers C + des fichiers excel (à garder) + des dossiers windows (à supprimer via le code) + les PDF à termes (qui seront importé des dossiers C via le code)

Description des dossiers C : contenant de nos données de base (dont les PDF à extraire et copier dans le dossier B) - il ne faut rien supprimer dans ce dossier qui peut contenir des fichiers pdf / excel / solidworks / autre raccourci / autre dossiers

J'espère que j'ai pu clarifier la demande :)

Sinon n'hésites pas à me demander des précisions

Salut iwo,

D'accord, donc si je comprends bien, on garde la macro telle qu'elle est et on supprime les dossiers contenus en B.

Voici un essai (avec toujours la même incertitude vu qu'on supprime des éléments d'une collection pendant une boucle sur celle-ci) :

Sub test()
spath$ = "moncheminDossierA" 'sans antislash de fin !!!
Set fso = CreateObject("Scripting.filesystemobject")
For Each sfd In fso.getfolder(spath).subfolders
    for each ssfd in sfd.subfolders 'boucle de suppression des sous-dossiers de B
        fso.deletefolder ssfd.path, true
    next ssfd
    Sonder sfd.Path 'lancement de la fonction de copie des pdf contenus dans les cibles des raccourcis présents en B
Next sfd
End Sub

Sub Sonder(srepdest$, Optional srepsrc$)
If srepsrc = "" Then srepsrc = srepdest
Set fso = CreateObject("Scripting.filesystemobject")
Set fd = fso.getfolder(srepsrc)
For Each fil In fd.Files
    If fil.Name Like "*.pdf" Then
        fso.copyfile fil.Path, srepdest & "\" & fil.Name: Exit Sub
    ElseIf fil.Type = "Raccourci" and not fil.name like "*.*.*" Then 'If fil.Name Like "*.lnk" Then
        sTargetpath$ = GetTargetPath(fil.Path)
        if fso.folderexists(sTargetpath) then
            Sonder srepdest, sTargetpath
            fso.deletefile fil.path, true 'suppression raccourci
        end if
    End If
Next fil
For Each sfd In fd.subfolders
    Sonder srepdest, sfd.Path
Next sfd
End Sub

Function GetTargetPath(lnkFolderPath As String) As String
GetTargetPath = CreateObject("Wscript.Shell").CreateShortcut(lnkFolderPath).targetpath
End Function

Encore une fois, ce code est à tester sur une arborescence sans contenu important afin d'éviter toute mauvaise surprise !

Hello 3GB,

Ca marche du tonnerre et toujours pas de bug ^^

Juste un petit truc qui que je ne comprends pas :

Imaginons que j'ai 2 dossiers B (B1 et B2)

Sur le B1, le dossier C1 est lié à ce dossier B1par un raccourci contenu dans B1. Dans ce dossier C1 j'ai également un raccourci, celui-ci ne se supprime pas (C'est OK car c'est ce que je veux).

Sur le B2, le dossier C2 est lié à ce dossier B2 par un raccourci contenu dans B2. Dans ce dossier C2 j'ai également un raccourci, celui-ci par contre se supprime. Et je voudrais que dans ce dossier le raccourci ne soit pas supprimé.

Mis à part ça c'est tout simplement parfait :)

Oui, j'y ai pensé en modifiant le code... Soit le fichier n'est pas à la même racine selon les cas, soit il s'agit d'un problème au niveau de la récursivité (je n'ai pas testé les derniers codes).

Voici ce que je propose qui devrait éviter le problème :

Sub test()
spath$ = "moncheminDossierA" 'sans antislash de fin !!!
Set fso = CreateObject("Scripting.filesystemobject")
For Each sfd In fso.getfolder(spath).subfolders
    for each ssfd in sfd.subfolders 'boucle de suppression des sous-dossiers de B
        fso.deletefolder ssfd.path, true
    next ssfd
    Sonder sfd.Path 'lancement de la fonction de copie des pdf contenus dans les cibles des raccourcis présents en B
    for each fil in ssfd.files 'boucle de suppression des raccourcis en B
        If fil.Type = "Raccourci" and not fil.name like "*.*.*" Then 'If fil.Name Like "*.lnk" Then
            fso.deletefile fil.path, true 'suppression raccourci
        end if
    next fil
Next sfd
End Sub

Sub Sonder(srepdest$, Optional srepsrc$)
If srepsrc = "" Then srepsrc = srepdest
Set fso = CreateObject("Scripting.filesystemobject")
Set fd = fso.getfolder(srepsrc)
For Each fil In fd.Files
    If fil.Name Like "*.pdf" Then
        fso.copyfile fil.Path, srepdest & "\" & fil.Name: Exit Sub
    ElseIf fil.Type = "Raccourci" and not fil.name like "*.*.*" Then 'If fil.Name Like "*.lnk" Then
        sTargetpath$ = GetTargetPath(fil.Path)
        if fso.folderexists(sTargetpath) then Sonder srepdest, sTargetpath
    End If
Next fil
For Each sfd In fd.subfolders
    Sonder srepdest, sfd.Path
Next sfd
End Sub

Function GetTargetPath(lnkFolderPath As String) As String
GetTargetPath = CreateObject("Wscript.Shell").CreateShortcut(lnkFolderPath).targetpath
End Function

Génial ! Merci pour le code et pour ta réactivité :)

C'est tout bon pour moi, ça marche nickel :)

J'arrête de t'embêter et te souhaites un très bon week-end !