Microsoft 365 Exporter une feuille graphique en pdf

[loul03]

Bonjour

J'ai un graphique sur une feuille spéciale graphique que j'aimerais exporter en pdf, et enregistrer automatiquement dans un dossier.

La formule employée habituellement ne fonctionne pas.

Savez vous quelles sont les dénominations à faire évoluer svp?

Sheets("Graphique").Select
Dim ladate As String, periode As String, lerep As String
ladate = Format(Date, "yyyymmdd")
periode = Worksheets("Rapport Actia").Range("p2").Value
lerep = ThisWorkbook.Path & "\Historique\"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=lerep & ladate & " - Conso gasoil - Période " & periode & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Sheets("Graphique").Select

Par avance merci beaucoup

bonne journée
loul

 

[loul03]

en fait cette formule fonctionne, c'est juste que ma valeur P2 contenait des /
merci à vous

 

[kiki29]

Salut, une version qui teste si le nom de fichier est valide, crée le dossier de sauvegarde, en plus les doublons éventuels sont gérés via un indice : (001) (002) etc.

Option Explicit

Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Long, 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 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

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function

Sub Tst()
Dim LaDate As String, Periode As String, LeRep As String
Dim sDossier As String, sFichier As String

    LaDate = Format(Date, "yyyymmdd")
    Periode = Worksheets("Rapport Actia").Range("p2").Text

    If NomFichierValide(Periode) = False Then
        MsgBox "Nom de fichier invalide !", vbOKCancel + vbCritical
        With Worksheets("Rapport Actia")
            .Activate
            .Range("p2").Select
        End With
        Exit Sub
    End If

    Application.ScreenUpdating = False

    LeRep = ThisWorkbook.Path
    sDossier = "Historique"

    CreationDossier (LeRep & "\" & sDossier)

    sFichier = LaDate & " - Conso gasoil - Période " & Periode & ".pdf"
    sFichier = RenommerFichier(LeRep & "\" & sDossier, sFichier)

    Graph1.ExportAsFixedFormat Type:=xlTypePDF, _
                               Filename:=sFichier, _
                               Quality:=xlQualityStandard, _
                               IncludeDocProperties:=True, _
                               IgnorePrintAreas:=False, _
                               OpenAfterPublish:=True
    Application.ScreenUpdating = True
End Sub