XL 2013 Macro pour enregistrer en PDF

SERRANO

XLDnaute Nouveau
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.
 

Pièces jointes

  • Demande de BC V2.xlsm
    44.5 KB · Affichages: 22

kiki29

XLDnaute Barbatruc
re,
VB:
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
 
Dernière édition:

SERRANO

XLDnaute Nouveau
re,
VB:
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

1655131852819.png

re,
VB:
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
 

Kan

XLDnaute Nouveau
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...


VB:
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
 

Discussions similaires

Statistiques des forums

Discussions
311 735
Messages
2 082 024
Membres
101 873
dernier inscrit
excellllll