Creation dossier et sous dossier

En fait j'ai un classeur qui s'ouvre a l'ouverture.

Je vous joint le code complet de ThisWorkBook :

Private Sub Workbook_Open()
    Dim Verification As Boolean
    Dim MonClasseur As String

    Application.DisplayAlerts = False

    Pathname = "C:\Users\" & Environ("username") & "\Documents\LOGICIEL DEVIS\"
    Filename = "Base_donnée.xlsm"

    MonClasseur = Pathname & Filename

        'd'abord le test si le fichier existe
    If Len(Dir(MonClasseur)) = 0 Then 's'il n'existe pas, montrer un avertissement et quitter la macro
        MsgBox "ERREUR: Le Classeur: [" & MonClasseur & "] n'existe pas..."
        Exit Sub
    Else
    End If

    'si le Classeur existe, vérifier s'il est déjà ouvert
    Verification = EstClasseurOuvert(MonClasseur)

    If Verification = True Then Exit Sub

    Application.Workbooks.Open Filename:=Pathname & Filename, UpdateLinks:=0

    MsgBox "Bonjour, le Fichier Base Donnée va s'ouvrir", vbInformation, "LOGICIEL DEVIS"
  Me.Activate

  With ActiveSheet.PageSetup
        .CenterFooter = "&8Siret : " & Sheets("Base").Range("B3").Value & " / " & "&8TVA Intra : " & Sheets("Base").Range("B6").Value & Chr(10) & _
        "&8Tel : " & Sheets("Base").Range("B7").Value & " / " & "&8Mail : " & Sheets("Base").Range("B8").Value

    End With

    With Sheets("ACCUEIL")
    .EnableOutlining = True
    .Protect userInterfaceOnly:=True
End With
     Sheets("ACCUEIL").Activate

End Sub

Ce qui est surtout trés bizarre, c'est qu'il n'enregistre plus mes modifs, malgrés le mot de passe (Donc il n'y a plus le code de Thev)

Bonsoir,

Avec votre schéma d'utilisation du classeur, une possibilité via une astuce de procédure événementielle:

1- modifier le code ThisWorkBook de votre classeur "Base_donnée.xlsm" ainsi :

Public enreg_classeur As Boolean
Const mot_passe_enreg  As String = "provisoire"

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    enreg_classeur = True
    Cancel = True
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim mot_passe

    If Not enreg_classeur Then
        mot_passe = InputBox("Veuillez saisir le mot de passe pour enregistrer")
        If mot_passe <> mot_passe_enreg Then Cancel = True
    End If

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    If Not enreg_classeur Then
        ThisWorkbook.Saved = True
        MsgBox "classeur non enregistré"
    Else
        ThisWorkbook.Save
        MsgBox "classeur enregistré"
    End If

End Sub

2- modifier le code de la procédure "DEVIS_SP_Pdf" ainsi :

    '// contrôles
    If sh_devis_ht.Range("H4") = "" Then MsgBox ("Il n'y a pas de numéro de devis !")

    Dim enreg_pdf As Boolean: enreg_pdf = True
    If MsgBox("Voulez vous enregistrer le Devis sans prix en PDF ?", vbYesNo) = vbNo Then
        enreg_pdf = False
        If MsgBox("Voulez vous enregistrer le classeur ?", vbYesNo) = vbYes Then
            ActiveWorkbook.PrintPreview 'pour autoriser l'enregistrement du classeur
        Else
            Exit Sub
        End If
    End If

Alors je n'ai plus d'erreur, mais il m'affiche une Preview, mais n'enregistre pas le classeur dans les répertoires adéquat

mais il m'affiche une Preview

Vous n'avez pas dû intégrer cette procédure événementielle dans le ThisWorkBook de votre classeur "Base_donnée.xlsm"

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    enreg_classeur = True
    Cancel = True
End Sub

car l'instruction "Cancel = True" annule l'affichage de la Preview.

Non j'ai bien entièrement copié le code.

Où donc se trouve la procédure "DEVISHT_Pdf" ? dans quel classeur ? dans quelle feuille ou module ?

Alors oui, désolé pour le manque de précision.

J'ai un classeur "Logiciel Devis" qui contient toutes mes feuilles, dont celles que j'ai besoin d'editer en PDF.

Et ce classeur fait appel à un autre classeur "Base_donnée", qui lui n'a que comme seule macro, un enregistrement automatique.

Bonjour,

merci de ces précisions mas vous n'avez pas répondu à ma question, à savoir : Où se trouve la procédure "DEVISHT_Pdf"

Dans le classeur principale "Outils Devis"

1- modifier comme suit le code ThisWorkBook de votre classeur "Outils Devis" :

Public wb_base As Workbook

Private Sub Workbook_Open()
    Dim Verification As Boolean
    Dim MonClasseur As String

    Application.DisplayAlerts = False

    Pathname = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\LOGICIEL DEVIS\"
    Filename = "Base_donnée.xlsm"

    MonClasseur = Pathname & Filename

        'd'abord le test si le fichier existe
    If Len(Dir(MonClasseur)) = 0 Then 's'il n'existe pas, montrer un avertissement et quitter la macro
        MsgBox "ERREUR: Le Classeur: [" & MonClasseur & "] n'existe pas..."
        Exit Sub
    End If

    'si le Classeur existe, vérifier s'il est déjà ouvert
    'Verification = EstClasseurOuvert(MonClasseur)

    'If Verification = True Then Exit Sub

    Set wb_base = Workbooks.Open(Filename:=Pathname & Filename, UpdateLinks:=0)
    MsgBox "Bonjour, le Fichier Base Donnée va s'ouvrir", vbInformation, "LOGICIEL DEVIS"
    Me.Activate
    Exit Sub

    With ActiveSheet.PageSetup
        .CenterFooter = "&8Siret : " & Sheets("Base").Range("B3").Value & " / " & "&8TVA Intra : " & Sheets("Base").Range("B6").Value & Chr(10) & _
        "&8Tel : " & Sheets("Base").Range("B7").Value & " / " & "&8Mail : " & Sheets("Base").Range("B8").Value

    End With

    With Sheets("ACCUEIL")
        .EnableOutlining = True
        .Protect userInterfaceOnly:=True
    End With
    Sheets("ACCUEIL").Activate

End Sub

2- modifier comme suit le code de votre procédure "DEVISHT_Pdf"

    Dim enreg_pdf As Boolean: enreg_pdf = True
    If MsgBox("Voulez vous enregistrer le Devis sans prix en PDF ?", vbYesNo) = vbNo Then
        enreg_pdf = False
        If MsgBox("Voulez vous enregistrer le classeur ?", vbYesNo) = vbYes Then
            ThisWorkbook.wb_base.PrintPreview 'pour autoriser l'enregistrement du classeur
        Else
            Exit Sub
        End If
    End If

Bonjour,

Alors je n'ai plus d'erreur, mais il me fait un printpreview lorsque je répond "Oui" a l'enregistrement du classeur.

Ce que je souhaiterais c'est que lorsque je répond "Oui" à l'enregistrement du classeur, il enregistre le classeur avec le nom comme suit :

D1-N° devis-Nom client-Date du jour (Comme pour l'Edition PDF)

et qu'il enregistre le classeur dans les dossiers comme suit :

Mes docs > Logiciel Devis > Devis > "Année" > "Mois-Année" (Identique au pdf)

Je ne sais pas si j'ai été assez clair ?

Alors en fait je lance le classeur "OUTILS DEVIS" qui se situe dans le dossier Mesdocs > Logiciel Devis.

Celui-ci, en se lançant, fais appel au classeur "Base_Donnée", lui aussi dans le dossier Mesdocs > Logiciel Devis.

Le classeur que je souhaite enregistrer en PDF et/ou en Xlsm, est le classeur "OUTILS DEVIS"

Dans ce cas, aucun code associé au ThisWorkBook du classeur "Base_données.xlsm" n'est nécessaire. Il suffit alors de modifier la procédure ainsi :

Sub DEVIS_SP_Pdf()
    Dim Mes_Docs As String, LeRep_devis As String
    Dim LeRepY As String, LeRepS As String, LaDate As String, LeNom As String, nom_fichier As String
    Dim DEVIS
    Dim sh_devis_ht As Worksheet, sh_devis_sp As Worksheet
    Dim Fso As Object, dossier As Object

    '// assignation feuilles devis
    Set sh_devis_ht = Sheets("DEVIS HT"): Set sh_devis_sp = Sheets("DEVIS SP")

    '// contrôles
    If sh_devis_ht.Range("H4") = "" Then MsgBox ("Il n'y a pas de numéro de devis !")

    Dim enreg_pdf As Boolean: enreg_pdf = True
    Dim enreg_classeur As Boolean: enreg_classeur = False
    If MsgBox("Voulez vous enregistrer le Devis sans prix en PDF ?", vbYesNo) = vbNo Then
        enreg_pdf = False
        If MsgBox("Voulez vous enregistrer le classeur ?", vbYesNo) = vbYes Then
            enreg_classeur = True 'pour autoriser l'enregistrement du classeur
        Else
            Exit Sub
        End If
    End If

    '// définition dossiers et nom du fichier
    LaDate = Format(Date, "ddmmyyyy")                                                   'Date du jour
    DEVIS = sh_devis_sp.Range("H4").Value                                               'Numero du devis
    Mes_Docs = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")              'Dossier mes documents
    LeRep_devis = Mes_Docs & "\Logiciel Devis\Devis SP\"                                'Repertoire des devis
    LeRepY = LeRep_devis & UCase(Format(sh_devis_sp.Range("H5").Value, "yyyy")) & "\"   'Repertoire des devis année
    LeRepS = LeRepY & UCase(Format(sh_devis_sp.Range("H5").Value, "ww-yyyy")) & "\"     'Repertoire des devis sp
    LeNom = sh_devis_ht.Range("G11").Value                                              'Nom du client
    nom_fichier = LeRepS & "SP-" & DEVIS & "-" & LeNom & "-" & LaDate

    '// création objet FilesSystem
    Set Fso = CreateObject("Scripting.FilesystemObject")

    '// création dossier / sous-dossier
    Dim répertoire As String
    répertoire = Mes_Docs & "\Logiciel Devis\"
    If Not Fso.FolderExists(répertoire) Then Fso.CreateFolder (répertoire)
    répertoire = répertoire & "\Devis SP\"
    If Not Fso.FolderExists(répertoire) Then Fso.CreateFolder (répertoire)

    If Not Fso.FolderExists(LeRepY) Then Fso.CreateFolder (LeRepY)
    If Not Fso.FolderExists(LeRepS) Then Fso.CreateFolder (LeRepS): MsgBox "Le dossier " & LeRepS & " a été créé"

    '// création fichier PDF
    If enreg_pdf Then sh_devis_sp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nom_fichier & ".pdf", OpenAfterPublish:=True

    '// enregistrement éventuel du classeur OUTILS DEVIS
    If enreg_classeur Then ThisWorkbook.SaveCopyAs Filename:=nom_fichier & ".xlsm"

    '// libération objet FilesSystem
    Set Fso = Nothing

End Sub

MERCIIIIII

Ca fonctionne correctement et exactement comme je le voulais.

J'ai juste du enlever

& "\"

a la fin de :

LeRepS = LeRepY & UCase(Format(sh_devis_sp.Range("H5").Value, "ww-yyyy")) & "\"     'Repertoire des devis

Sinon il me m'était un chemin de dossier introuvable avec un "//"