XL 2016 VBA - problème de code

Smercierj · 9 Août 2022

Bonjour à tous,

Voici le code que j'ai pour enregistrer un fichier PDF dans mon dossier automatiquement:

VB:

Sub pdf()

SousDossier = "Ecart de tri"
nomdossier = Application.InputBox("Dossier d'enregistrement", "Enregistrer en PDF....!", "Bon de livraison")

dossier = ThisWorkbook.Path & "/" & nomdossier & "/" & SousDossier & "/"

On Error Resume Next

If dossier = True Then

GetAttr (dossier) And vbDirectory

Else

MkDir (dossier)

End If

ActiveSheet.ExportAsFixedFormat Type:=xltypdf, _
Filename:=dossier & Range("F2").Value & "_" & "BL N°" & " " & Range("F3").Value & ".pdf", _
quality:=xlQualityStandard, ignoreprintareas:=False, _
includedocproperties:=True, _
from:=1, to:=1, _
openafterpublish:=False

Toutefois, lorsque j'ai apporté certaines modifications à mon document, désormais, il crée toujours un sous-dossier: Bon de livraison avec le sous-dossier nommé en "ecart de tri".

J'ai déjà le dossier Bon de livraison, j'ai seulement besoin qu'il enregistre le document dans le sous-dossier approprié. Ça fonctionnait bien avant que je fasses mes modifications.

Quelqu'un peut m'aider svp?

Aussi, j'aimerais que mon (filename) soit nommé seulement: BL N° & Range ("F3"). Si j'efface : dossier & Range ("F2").Value & "_" &, ça ne fonctionne pas.

Merci pour votre aide c'est très apprécié!

TooFatBoy · 9 Août 2022

Bonjour,

Est-ce que tes modifications n'aurait pas été faites à ce niveau :

Smercierj à dit:
If dossier = True

Si oui, est-ce qu'il n'y avait pas une instruction Dir ?

ps : tu devrais utiliser la balise "code" pour que ta macro soit plus lisible.

Smercierj · 9 Août 2022

TooFatBoy à dit:
Bonjour,

Est-ce que tes modifications n'aurait pas été faites à ce niveau :

Si oui, est-ce qu'il n'y avait pas une instruction Dir ?

ps : tu devrais utiliser la balise "code" pour que ta macro soit plus lisible.

Non, depuis le début c'est ainsi.

kiki29 · 9 Août 2022

salut, corrige déjà xltypdf en xlTypePDF, remplace "/" par "\", passe on error resume next en commentaire.

Smercierj · 9 Août 2022

kiki29 à dit:
salut, corrige déjà xltypdf en xlTypePDF, remplace "/" par "\", passe on error resume next en commentaire.

Je viens de faire les modifications que tu m'as mentionnés, mais du coup, j'ai plus le # de BL lors de l'enregistrement:

et le problème est toujours là (voir la liste des dossiers en image ci-jointe)

kiki29 · 9 Août 2022

Re, à toi de poursuivre

VB:

Option Explicit

Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
    If InStr(sChemin, ":") = 0 Then
        Ar = Split(CurDir & "\" & sChemin, "\")
    Else
        Ar = Split(sChemin, "\")
    End If

    sTmp = Ar(0)
    ChDrive sTmp

    For i = LBound(Ar) + 1 To UBound(Ar)
        If Ar(i) <> "" Then
            sTmp = sTmp & "\" & Ar(i)
            On Error Resume Next
            MkDir sTmp
            On Error GoTo 0
        End If
    Next i

    If Dir$(sChemin, vbDirectory) = vbNullString Then
        CreationDossier = False
    Else
        CreationDossier = True
    End If
End Function

Private Function NomValide(ByVal sChaine As Variant) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?\|"
    NomValide = True
    If Len(sChaine) = 0 Then
        NomValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, i, 1)) > 0 Then
            NomValide = False
            Exit Function
        End If
    Next i
End Function

Sub Test_03()
Dim SousDossier As String
Dim NomDossier As Variant
Dim Dossier As String

    SousDossier = "Ecart de tri"
    NomDossier = Application.InputBox("Dossier d'enregistrement", "Enregistrement en PDF", "Bon de livraison")
    If NomDossier = False Then Exit Sub

    Dossier = ThisWorkbook.Path & "\" & NomDossier & "\" & SousDossier & "\"

    If NomValide(Range("F2")) = False Then
        MsgBox "Nom de Fichier invalide", vbCritical + vbOKOnly
        Range("F2").Select
        Exit Sub
    End If

    If NomValide(Range("F3")) = False Then
        MsgBox "Nom de Fichier invalide", vbCritical + vbOKOnly
        Range("F3").Select
        Exit Sub
    End If

    If CreationDossier(Dossier) = True Then
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=Dossier & Range("F2") & "_" & "BL N°" & " " & Range("F3"), _
                                        quality:=xlQualityStandard, _
                                        ignoreprintareas:=False, _
                                        includedocproperties:=True, _
                                        from:=1, To:=1, _
                                        openafterpublish:=False
    End If
End Sub

TooFatBoy · 10 Août 2022

Smercierj à dit:
Non, depuis le début c'est ainsi.

Ah bon... vu que tu disais avoir fait des modifs mais que tu ne nous disais pas lesquelles, j'essayais de deviner.

Smercierj · 10 Août 2022

kiki29 à dit:

Re, à toi de poursuivre

VB:

Option Explicit

Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
    If InStr(sChemin, ":") = 0 Then
        Ar = Split(CurDir & "\" & sChemin, "\")
    Else
        Ar = Split(sChemin, "\")
    End If

    sTmp = Ar(0)
    ChDrive sTmp

    For i = LBound(Ar) + 1 To UBound(Ar)
        If Ar(i) <> "" Then
            sTmp = sTmp & "\" & Ar(i)
            On Error Resume Next
            MkDir sTmp
            On Error GoTo 0
        End If
    Next i

    If Dir$(sChemin, vbDirectory) = vbNullString Then
        CreationDossier = False
    Else
        CreationDossier = True
    End If
End Function

Private Function NomValide(ByVal sChaine As Variant) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?\|"
    NomValide = True
    If Len(sChaine) = 0 Then
        NomValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, i, 1)) > 0 Then
            NomValide = False
            Exit Function
        End If
    Next i
End Function

Sub Test_03()
Dim SousDossier As String
Dim NomDossier As Variant
Dim Dossier As String

    SousDossier = "Ecart de tri"
    NomDossier = Application.InputBox("Dossier d'enregistrement", "Enregistrement en PDF", "Bon de livraison")
    If NomDossier = False Then Exit Sub

    Dossier = ThisWorkbook.Path & "\" & NomDossier & "\" & SousDossier & "\"

    If NomValide(Range("F2")) = False Then
        MsgBox "Nom de Fichier invalide", vbCritical + vbOKOnly
        Range("F2").Select
        Exit Sub
    End If

    If NomValide(Range("F3")) = False Then
        MsgBox "Nom de Fichier invalide", vbCritical + vbOKOnly
        Range("F3").Select
        Exit Sub
    End If

    If CreationDossier(Dossier) = True Then
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=Dossier & Range("F2") & "_" & "BL N°" & " " & Range("F3"), _
                                        quality:=xlQualityStandard, _
                                        ignoreprintareas:=False, _
                                        includedocproperties:=True, _
                                        from:=1, To:=1, _
                                        openafterpublish:=False
    End If
End Sub

Avec ceci ça fonctionnera?

kiki29 · 10 Août 2022

re, ici cela fonctionne sans problèmes, dans ton bazar je n'en sais rien.

Smercierj · 10 Août 2022

Smercierj à dit:
Avec ceci ça fonctionnera?

kiki29 à dit:
re, ici cela fonctionne sans problèmes, dans ton bazar je n'en sais rien.

Je viens de copier et de coller, ça ne fonctionne pas 🙁

bastring · 11 Août 2022

Bonjour le monde,
Smercierj faisait des demandes pour le même sujet sur un autre forum ... quel mauvais garçon ...

Quoi qu'il en soit ... son souci semble résolu à ce que j'en ai lu ...
Il utilisait OneDrive ...
Dans ce cas, il faut utiliser Application.FileDialog(msoFileDialogFilePicker) tout simplement.

bastr

XL 2016 VBA - problème de code

Smercierj

XLDnaute Nouveau

TooFatBoy

XLDnaute Barbatruc

Smercierj

XLDnaute Nouveau

kiki29

XLDnaute Barbatruc

Smercierj

XLDnaute Nouveau

kiki29

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

Smercierj

XLDnaute Nouveau

kiki29

XLDnaute Barbatruc

Pièces jointes

Smercierj

XLDnaute Nouveau

bastring

XLDnaute Nouveau

Discussions similaires

XL 2016 VBA - problème de code

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Nouveau

Discussions similaires

Privacy & Transparency

Privacy & Transparency