Contrôle si dossier existe et si non le créé (avec 1 ou 2 partitions)

Le 14/11/2020 à 18:14

Hello, contrôle si dossier existe et si non crée une petite arborescence

Le code ci-dessous fonctionne très bien mais à la condition que l'utilisateur aie 2 partitions et que la 2ème soit bien D:
Ce que j'aimerais pouvoir faire, c'est de contrôler si D: existe et exécuter ma macro si OUI et si NON, alors créé la même arborescence mais sous C:
La raison, ce fichier va être utilisé par plusieurs personnes dont je ne gère pas leur PC, je ne sais donc pas s'ils auront ou pas 2 partitions.
Dans ces dossiers seront stockés des fichiers PDF créé par Excel par différents départements et il faudra ensuite les rassembler sur une seule machine pour gérer ensuite le toute.

PS : il y a sûrement moyen de simplifier le code ci-dessous, mais je ne suis pas un pro du tout et je tente d'adapter ce que je trouve sur la toile :) 

Sub Controle_dossier()
    Dim Rep1 As Object
    Dim Rep2 As Object
    Dim Rep3 As Object
    Dim Rep4 As Object
    Dim Rep5 As Object
    Dim Rep6 As Object
    Application.ScreenUpdating = False
    Set Rep1 = CreateObject("Scripting.FileSystemObject")
    If Rep1.FolderExists("D:\Documents\Auction-autos\_PDF") Then
'    MsgBox "Le dossier existe !", vbInformation, "Dossiers existants"
    Exit Sub
    Else
        Rep1.CreateFolder ("D:\Documents\Auction-autos\_PDF")
    Set Rep2 = CreateObject("Scripting.FileSystemObject")
        Rep2.CreateFolder ("D:\Documents\Auction-autos\_PDF\Vendeurs")
    Set Rep3 = CreateObject("Scripting.FileSystemObject")
        Rep3.CreateFolder ("D:\Documents\Auction-autos\_PDF\Acheteurs")
    Set Rep4 = CreateObject("Scripting.FileSystemObject")
        Rep4.CreateFolder ("D:\Documents\Auction-autos\_PDF\Vendeurs-Non")
    Set Rep5 = CreateObject("Scripting.FileSystemObject")
        Rep5.CreateFolder ("D:\Documents\Auction-autos\_PDF\Brocante")
    Set Rep6 = CreateObject("Scripting.FileSystemObject")
        Rep6.CreateFolder ("D:\Documents\Auction-autos\_PDF\Stands")
    MsgBox "Dossiers de sauvegardes créés avec succès ici D:\Documents\Auction-autos\_PDF", vbInformation, "Vos dossiers sont ici"
    End If
    Application.ScreenUpdating = True
End Sub
Le 14/11/2020 à 18:27

Bonjour,

Une solution plus universelle consiste à créer des sous dossiers dans le dossier que contient la macro (Thisworkbook.Path)

Le 15/11/2020 à 20:55

J'ai résolu mon soucis comme expliqué ci-dessous, c'est de l'adaptation de codes donc pour les puristes, soyez tolérants SVP

Le code qui permet de vérifier si D: existe, si oui, il crée l'arborescence sur D: et si non il crée presque la même structure mais sous C: , tout ça dans un module

Sub DriveExist()
    Dim drive As Object
    Set drive = CreateObject("Scripting.FileSystemObject")
    If drive.DriveExists("D:\") = True Then
    CreeDossierD
'       MsgBox "Le disque dur D: existe, c'est parfait !"
    Else
    CreeDossierC
    End If
End Sub

Sub CreeDossierD()
    Dim Rep1 As Object
    Dim Rep2 As Object
    Dim Rep3 As Object
    Dim Rep4 As Object
    Dim Rep5 As Object
    Dim Rep6 As Object
    Application.ScreenUpdating = False
    Set Rep1 = CreateObject("Scripting.FileSystemObject")
    If Rep1.FolderExists("D:\Documents\Auction-autos\_PDF") Then
'    MsgBox "Le dossier existe !", vbInformation, "Auction-Auto.ch - LMPC Informatique"
    Exit Sub
    Else
        Rep1.CreateFolder ("D:\Documents\Auction-autos\_PDF")
    Set Rep2 = CreateObject("Scripting.FileSystemObject")
        Rep2.CreateFolder ("D:\Documents\Auction-autos\_PDF\Vendeurs")
    Set Rep3 = CreateObject("Scripting.FileSystemObject")
        Rep3.CreateFolder ("D:\Documents\Auction-autos\_PDF\Acheteurs")
    Set Rep4 = CreateObject("Scripting.FileSystemObject")
        Rep4.CreateFolder ("D:\Documents\Auction-autos\_PDF\Vendeurs-Non")
    Set Rep5 = CreateObject("Scripting.FileSystemObject")
        Rep5.CreateFolder ("D:\Documents\Auction-autos\_PDF\Brocante")
    Set Rep6 = CreateObject("Scripting.FileSystemObject")
        Rep6.CreateFolder ("D:\Documents\Auction-autos\_PDF\Stands")
    MsgBox "Dossiers de sauvegardes créés avec succès ici D:\Documents\Auction-autos\_PDF", vbInformation, "Auction-Auto.ch - LMPC Informatique"
    End If
    Application.ScreenUpdating = True
End Sub

Sub CreeDossierC()
    Dim Rep11 As Object
    Dim Rep12 As Object
    Dim Rep13 As Object
    Dim Rep14 As Object
    Dim Rep15 As Object
    Dim Rep16 As Object
    Application.ScreenUpdating = False
    Set Rep11 = CreateObject("Scripting.FileSystemObject")
    If Rep11.FolderExists("C:\_PDF") Then
'    MsgBox "Le dossier existe !", vbInformation, "Auction-Auto.ch - LMPC Informatique"
    Exit Sub
    Else
        Rep11.CreateFolder ("C:\_PDF")
    Set Rep12 = CreateObject("Scripting.FileSystemObject")
        Rep12.CreateFolder ("C:\_PDF\Vendeurs")
    Set Rep13 = CreateObject("Scripting.FileSystemObject")
        Rep13.CreateFolder ("C:\_PDF\Acheteurs")
    Set Rep14 = CreateObject("Scripting.FileSystemObject")
        Rep14.CreateFolder ("C:\_PDF\Vendeurs-Non")
    Set Rep15 = CreateObject("Scripting.FileSystemObject")
        Rep15.CreateFolder ("C:\_PDF\Brocante")
    Set Rep16 = CreateObject("Scripting.FileSystemObject")
        Rep16.CreateFolder ("C:\_PDF\Stands")
    MsgBox "Dossiers de sauvegardes créés avec succès ici C:\_PDF", vbInformation, "Auction-Auto.ch - LMPC Informatique"
    End If
    Application.ScreenUpdating = True
End Sub

Dans ThisWorkBook, j'appelle la macro "DriveExist" qui s'exécute à l'ouverture de mon fichier et surtout, comme je dois faire une procédure d'utilisation pour les futurs utilisateurs, tous auront la même structure connue et qu'importe ou ils auront enregistré le fichier sur lequel ils travailleront

Sub workbook_open()
    Call DriveExist
End Sub

Et maintenant un exemple d'intégration dans une feuille à enregistrer au format PDF automatiquement sur la bonne partition et dans le bon dossier

Sub SaveToPDFVendeurs() 
Dim LaDate$, nom$, Rep$, RepPDF$, dossier$
Dim PDFD As Object
    Set PDFD = CreateObject("Scripting.FileSystemObject")
    If PDFD.FolderExists("D:\Documents\Auction-autos\_PDF") = True Then
        RepPDF = "D:\Documents\Auction-autos\_PDF\"
'        MsgBox "The folders in D: exists here : " & RepPDF 'pour test
    Else
        RepPDF = "C:\_PDF\"
'        MsgBox "The folders in C: exists here : " & RepPDF 'pour test
    End If
LaDate = Format(Now, "yymmdd_hhmm")
nom = "Lot " & f3.Range("G17") & " " & f3.Range("F31") & " CHF"
dossier = "Vendeurs\"
Rep = RepPDF & dossier    ' Chemin exact du répertoire
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    Rep & nom & " " & LaDate & ".pdf", Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    From:=1, To:=1, OpenAfterPublish:=False
End Sub

Testé sous O365 et windows 10 64 bits
Comme déjà dit, je ne fais qu'adapter des codes que je trouve et j'apprends petit à petit certaines astuces et manières de faire, actuellement c'est le résultat qui compte pour moi et pas forcément un code pur et dur !

Le 16/11/2020 à 01:59

Bonjour,

Voici un essai à tester où on agit sur D si ce lecteur existe et sur C sinon en exécutant un macro qui contrôle et le cas échéant crée tous les dossiers du chemin spécifié :

Sub LancerCreation()

Dim fso as FileSystemObject
dim dossiers
Dim repD$, repC$, repcible$, chemin$

repD = "D:\Documents\Auction-autos\_PDF" 'repertoire racine D
repC = "C:\_PDF" 'rep C
dossiers = array("Vendeurs", "Acheteurs", "Vendeurs-Non", "Brocante", "Stands") 'tableau des dossiers à controler/créer
Set fso = CreateObject("Scripting.FileSystemObject") 'instanciation filesystem

if fso.driveexists("D:\") then 'si lecteur D existe
    repcible = repD 'on agit sur repD
else
    repcible = repC 'sinon, cible = repC
end if

for i = 0 to ubound(dossiers) 'pour chaque dossier (chaque item de la liste ci-haut)
    chemin = repcible & "\" & dossiers(i) 'chemin concatène repcible et dossier en cours
    call CreerDossiers(chemin) '<<< EXECUTION MACRO CreerDossiers
next i

End Sub

Sub CreerDossiers(Chemin$) '<<<< MACRO EXECUTEE

Dim fso As FileSystemObject
Dim aFolders
Dim souschemin$
Dim j%

Set fso = CreateObject("Scripting.FileSystemObject") 'instanciation fso
aFolders = Split(Chemin, "\") 'divise le chemin : renvoie tableau qui va du lecteur (item 0) au dossier final (item ubound)

souschemin = aFolders(0) 'initialisation : souschemin = répertoire 0 (cad le lecteur)
for j = 1 to UBound(aFolders) 'pour chaque dossier du chemin (lecteur exclu)
    souschemin = souschemin & "\" & aFolders(j) 'souschemin concatène le dossier enfant
    If Not fso.FolderExists(souschemin) Then 'si ce répertoire n'existe pas
        MkDir (souschemin) 'création du répertoire
    End If
next

End Sub

A voir...

Cdlt,

Le 16/11/2020 à 08:05

@3GB Top, ça fonctionne tip top sauf que j'ai du modifier un petit truc ! Si je me souviens bien dans mes recherches c'est à cause que j'ai une version 64 bits, mais plus sûr

J'ai remplacer FileSystemObject par simplement Object dans les 2 macros et tout va bien

'Dim fso As FileSystemObject
Dim fso As Object

Merci à toi

Le 16/11/2020 à 08:51

Nickel !

Oui, j'y ai pensé. Ou peut-être que tu n'as pas ajouté la référence Microsoft Scripting Runtime (via Outils/Références) ?

Tant que ça marche, c'est super !

Cdlt,

Le 16/11/2020 à 09:09

Non je n'ai pas activé cette référence mais une question à ce sujet ?
Si je l'active, pas de soucis pour moi sur ma machine, par contre sur une autre machine si cette référence n'est pas activée, il y aura une erreur à l'exécution ou pas ?

Si il y a erreur, autant laisser comme ça et ne pas activer ?

Le 16/11/2020 à 09:22

C'est une bonne question dont je ne connais pas la réponse, que je ne peux pas chercher dans l'immédiat car je suis sur mac.

Mais je dirais que la référence porte sur le fichier et non sur l'ordinateur, à condition bien sûr que la référence soit disponible sur la version utilisée (et sur mac, par exemple, ce n'est pas possible). Mais si ça marche comme ça, autant laisser le type Object et ne pas activer. L'utilité de l'ajout de la référence est principalement d'avoir accès aux propriétés et méthodes lors de la saisie du code. Ici, tu n'en as pas besoin.

Rechercher des sujets similaires à "controle dossier existe cree partitions"