XL 2016 VBA - problème de code

[Smercierj]

Bonjour à tous,

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

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]

Bonjour,

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

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]

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]

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

 

[Smercierj]

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]

Re, à toi de poursuivre

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]

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]

Re, à toi de poursuivre

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]

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

 

[Smercierj]

Avec ceci ça fonctionnera?

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]

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