XL 2021 Comment créer un code VBA afin de création un chemin d'accès universel

AugusteP

XLDnaute Nouveau
Bonjour,

J'essai de créer un code VBA me permettant d'obtenir pour chaque utilisateur le même chemin dossier après enregistrement.
Le dossier où est enregistrée l'application sera enregistré sur le bureau de chaque ordi. De plus, dans ce dossier il y aura un sous-dossier appelé commande client. Ce que je cherche à faire c'est créer un chemin dossier universel utilisable par tout le monde. Pour le moment cela fonctionne mais avec un chemin propre à mon ordi.
Merci me m'apporter votre aide
Ci-dessous mes lignes de code
Cordialement


Private Sub EnregistrementBCde_Click()

'Déclaration des variables

Dim CheminDossier As String
Dim CheminsousDossier As String
Dim Commande As String
Dim Li As Byte

On Error GoTo 1

'Nom de dossier
CheminDossier = "C:\Users\beaud\OneDrive\Bureau\Application en cours de modif\Commande client\" '.................Chemin pour création du dossier
CheminsousDossier = CheminDossier & Me.LbNomClient & "\" '.....nom du sous dossier
Call test_repertoire(CheminsousDossier) '....créer un sous-dossier client s'il n'existe pas
Commande = Me.LbNomClient & " Commande client N° " & Me.Txtnumcde & " du " & Format(Date, "dd-mm-yyyy") & ".pdf" '...............Références de la commande à sauvegarder

If Me.LbNomClient = "" Then
Me.LbNomClient.SetFocus
Exit Sub
End If
Call test_repertoire(CheminDossier) '...................................................................vers procédure Test_repertoire (si le dossier n'existe pas il est créé)
'Enregistrement au format PDF
Application.ScreenUpdating = False '....................................................................désactivation de la mise à jour écran
Sheets("Cde client").ExportAsFixedFormat Type:=xlTypePDF, Filename:=CheminsousDossier & Commande, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, OpenAfterPublish:=False '................................sauvegarde du fichier au format pdf
Application.ScreenUpdating = True '.....................................................................réactivation de l'écran

Exit Sub

'Le traitement de l'erreur se p1ace en dessous d'un exit sub juste avant le end sub
1:
MsgBox "Erreur de traitement, sortie de formulaire"
Application.ScreenUpdating = True
End Sub
Sub test_repertoire(CheminDossier As String)
'
'*************************************************************************************
' fonctionne en lien avec la procédure Private Sub EnregistrementBCde_Click() *
'*************************************************************************************
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject") '................instanciation de la variable fs
If fs.FolderExists(CheminDossier) Then '.............................le repertoire existe donc rien à faire
Else: fs.CreateFolder CheminDossier '...................................le repertoire n'existe pas donc on le créait
End If
Set fs = Nothing '...................................................vide l'instanciation fs
End Sub
 

fanch55

XLDnaute Barbatruc
Bonsoir,
A main levé, à tester si cela répond à votre demande :
VB:
Sub EnregistrementBCde_Click()

'Déclaration des variables

Dim Dossier     As String
Dim SubDir      As String
Dim Fso         As Object

    If Me.LbNomClient = "" Then
        Me.LbNomClient.SetFocus
    Else
        ' Création des subdirectories si nécessaire
        Dossier = CreateObject("WScript.Shell").specialFolders("Desktop")
        Set Fso = CreateObject("Scripting.FileSystemObject")
            For Each SubDir In Array("Application en cours de modif", "Commande client", Me.LbNomClient)
                Dossier = Dossier & "\" & SubDir
                If Not Fso.FolderExists(Dossier) Then Fso.CreateFolder Dossier
            Next
        Set Fso = Nothing
       ' Sauvegarde du fichier au format pdf .........................
        Commande = Me.LbNomClient & " Commande client N° " & Me.Txtnumcde & " du " & Format(Date, "dd-mm-yyyy") & ".pdf" '...............Références de la commande à sauvegarder
        Sheets("Cde client").ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Dossier & "\" & Commande, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, OpenAfterPublish:=False
    End If

End Sub
 

AugusteP

XLDnaute Nouveau
Bonsoir,
A main levé, à tester si cela répond à votre demande :
VB:
Sub EnregistrementBCde_Click()

'Déclaration des variables

Dim Dossier     As String
Dim SubDir      As String
Dim Fso         As Object

    If Me.LbNomClient = "" Then
        Me.LbNomClient.SetFocus
    Else
        ' Création des subdirectories si nécessaire
        Dossier = CreateObject("WScript.Shell").specialFolders("Desktop")
        Set Fso = CreateObject("Scripting.FileSystemObject")
            For Each SubDir In Array("Application en cours de modif", "Commande client", Me.LbNomClient)
                Dossier = Dossier & "\" & SubDir
                If Not Fso.FolderExists(Dossier) Then Fso.CreateFolder Dossier
            Next
        Set Fso = Nothing
       ' Sauvegarde du fichier au format pdf .........................
        Commande = Me.LbNomClient & " Commande client N° " & Me.Txtnumcde & " du " & Format(Date, "dd-mm-yyyy") & ".pdf" '...............Références de la commande à sauvegarder
        Sheets("Cde client").ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Dossier & "\" & Commande, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, OpenAfterPublish:=False
    End If

End Sub
Bonjour, merci pour votre aide cependant un message d'erreur s'affiche concernant la variable de contrôle for each
1684551631096.png
 

AugusteP

XLDnaute Nouveau
Bonjour, merci pour votre aide cependant un message d'erreur s'affiche concernant la variable de contrôle for each
Regarde la pièce jointe 1170509
Re bonjour,

Je viens de changer mon chemin dossier et cela fonctionne, ci-dessous ma correction.

CheminDossier = Environ("userprofile") & "\OneDrive\Bureau\Application en cours de modif\Commande client\" '.................Chemin pour création du dossier

Merci et bonne journée
 

Discussions similaires

Réponses
0
Affichages
116
Réponses
6
Affichages
230

Statistiques des forums

Discussions
313 274
Messages
2 096 750
Membres
106 737
dernier inscrit
zaka