XL 2013 Macro pour enregistrer en PDF

[SERRANO]

Bonjour à toutes et à tous,

Voici un fichier que j'ai construis mais je bloque sur la macro.

Je souhaiterai que dans l'onglet formulaire grâce au petit bouton le fichier excel s'enregistre en PDF.

Dans un lieu bien précis comme indiqué, et que le nommage corresponde à la cellule K1.

Sauf que le nommage bloque sur ma macro.

Merci à vous pour votre aide.

 

[kiki29]

re,

Option Explicit

Sub Créer_PDF_05()
Dim monDossier As String, monFichier As String
Dim sCommande As String, FSO As Object
Dim Deb As Currency

    Deb = Timer
    Application.StatusBar = ""

    monDossier = "M:\O_DIP\6_Execution_comptable\liquidation_lyon\Bons_commande\Demande\Fiche liaisons et devis" & "\" & Feuil2.Range("K1")
    monDossier = Replace(monDossier, " ", "_"))

    monFichier = Feuil2.Range("K1")

    sCommande = Environ("comspec") & " /c mkdir " & monDossier
    Shell sCommande, 0

    Delai 250

    If NomFichierValide(monFichier) = False Then
        Feuil2.Range("K1").Select
        MsgBox "Nom de Fichier Invalide", vbOKOnly + vbCritical
        Exit Sub
    End If

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not (FSO.FolderExists(monDossier)) Then
        MsgBox "Dossier : " & monDossier & " n'existe pas", vbOKOnly + vbCritical
        Exit Sub
    End If
    Set FSO = Nothing

    With Feuil2
        .PageSetup.BlackAndWhite = False
        .ExportAsFixedFormat Type:=xlTypePDF, _
                             Filename:=monDossier & "\" & monFichier, _
                             Quality:=xlQualityStandard, _
                             IncludeDocProperties:=True, _
                             IgnorePrintAreas:=False, _
                             OpenAfterPublish:=False
    End With

   Application.StatusBar = "Terminé : " & Format(Timer - Deb, "0.000 s")
End Sub

Private Function Delai(ByVal ms As Long)
    Delai = Timer + ms / 1000
    While Timer < Delai: DoEvents: Wend
End Function

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

 

[SERRANO]

re,

Option Explicit

Sub Créer_PDF_04()
Dim monDossier As String, monFichier As String
Dim sCommande As String, FSO As Object
 
    monDossier = "M:\O_DIP\6_Execution_comptable\liquidation_lyon\Bons_commande\Demande\Fiches_liaisons_et_devis" & "\" & Feuil2.[k1]
    monDossier = NomDossierValide(monDossier)

    monFichier = Feuil2.[k1]

    sCommande = Environ("comspec") & " /c mkdir " & monDossier
    Shell sCommande, 0

    Delai 250

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not (FSO.FolderExists(monDossier)) Then
        MsgBox "Dossier : " & monDossier & " n'existe pas", vbOKOnly + vbCritical
        Exit Sub
    End If
    Set FSO = Nothing

    If NomFichierValide(monFichier) = False Then
        Feuil2.[k1].Select
        MsgBox "Nom de Fichier Invalide", vbOKOnly + vbCritical
        Exit Sub
    End If

    With Feuil2
        .PageSetup.BlackAndWhite = False
        .ExportAsFixedFormat Type:=xlTypePDF, _
                             Filename:=monDossier & "\" & monFichier, _
                             Quality:=xlQualityStandard, _
                             IncludeDocProperties:=True, _
                             IgnorePrintAreas:=False, _
                             OpenAfterPublish:=False
    End With
End Sub

Private Function Delai(ByVal ms As Long)
    Delai = Timer + ms / 1000
    While Timer < Delai: DoEvents: Wend
End Function

Private Function NomDossierValide(sChaine As String) As String
Dim i As Long
    For i = 1 To Len(sChaine)
        sChaine = Replace(sChaine, Mid$(" ", i, 1), "_")
    Next i
    NomDossierValide = sChaine
End Function

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

Presque presque

re,

Option Explicit

Sub Créer_PDF_04()
Dim monDossier As String, monFichier As String
Dim sCommande As String, FSO As Object
 
    monDossier = "M:\O_DIP\6_Execution_comptable\liquidation_lyon\Bons_commande\Demande\Fiches_liaisons_et_devis" & "\" & Feuil2.[k1]
    monDossier = Replace(monDossier, " ", "_"))

    monFichier = Feuil2.[k1]

    sCommande = Environ("comspec") & " /c mkdir " & monDossier
    Shell sCommande, 0

    Delai 250

    If NomFichierValide(monFichier) = False Then
        Feuil2.[k1].Select
        MsgBox "Nom de Fichier Invalide", vbOKOnly + vbCritical
        Exit Sub
    End If

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not (FSO.FolderExists(monDossier)) Then
        MsgBox "Dossier : " & monDossier & " n'existe pas", vbOKOnly + vbCritical
        Exit Sub
    End If
    Set FSO = Nothing

    With Feuil2
        .PageSetup.BlackAndWhite = False
        .ExportAsFixedFormat Type:=xlTypePDF, _
                             Filename:=monDossier & "\" & monFichier, _
                             Quality:=xlQualityStandard, _
                             IncludeDocProperties:=True, _
                             IgnorePrintAreas:=False, _
                             OpenAfterPublish:=False
    End With
End Sub

Private Function Delai(ByVal ms As Long)
    Delai = Timer + ms / 1000
    While Timer < Delai: DoEvents: Wend
End Function

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

Bonjour,

Je vais pas y arriver.... Erreur de compilation

 

[SERRANO]

Bonjour kiki29, Ça fonctionne merci merci merci. Par contre je l'ai copier sans comprendre !!!!

 

[Kan]

Bonjour Kiki29,
je reprends le fil de ce sujet Enregistre en PDF :
cette formule fonctionne très bien chez moi (avec C:\User\ etc...)

mais lorsque je mets le lien qui concerne un fichier public : il n'y a rien qui s'enregistre...

Option Explicit

Sub Créer_PDF()
Dim monDossier As String, monFichier As String
Dim sBDC As String, FSO As Object
 
    monDossier = "\\Xsmlssso10\mls_LCD\public\6- ADMINISTRATIF\0 Commande LCD\commandes passées\" & "\" & Feuil6.[C7]
    monDossier = (Replace(monDossier, " ", "_"))

    monFichier = Feuil6.[C7]

    sBDC = Environ("comspec") & " /c mkdir " & monDossier
    Shell sBDC, 0

    Delai 250

    If NomFichierValide(monFichier) = False Then
        Feuil6.[C7].Select
        MsgBox "Nom de Fichier Invalide", vbOKOnly + vbCritical
        Exit Sub
    End If

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not (FSO.FolderExists(monDossier)) Then
        MsgBox "Dossier : " & monDossier & " n'existe pas", vbOKOnly + vbCritical
        Exit Sub
    End If
    Set FSO = Nothing

    With Feuil6
        .PageSetup.BlackAndWhite = False
        .ExportAsFixedFormat Type:=xlTypePDF, _
                             Filename:=monDossier & "\" & monFichier, _
                             Quality:=xlQualityStandard, _
                             IncludeDocProperties:=True, _
                             IgnorePrintAreas:=False, _
                             OpenAfterPublish:=False
    End With
End Sub

Private Function Delai(ByVal ms As Long)
    Delai = Timer + ms / 1000
    While Timer < Delai: DoEvents: Wend
End Function

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

Pouvez vous m'aider ?

d'avance merci pour votre aide !

Kan