Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Conversion sélection en PDF

Manho1

XLDnaute Nouveau
Bonjour les experts,

Je suis novice en VBA et j’ai besoin d’aide sur le code ci-dessous que j’ai trouvé sur Internet.

Le code est relié à un bouton de commande et il me sert à convertir une sélection en PDF, jusque-là tout marche bien. L’ennui c’est que, quand je clique sur le bouton de commande, le code supprime et remplace le précédent PDF créer alors que je souhaite qu’il les conserve tous en les renommant Devis 1, Devis 2, ...

Voilà le problème.

Merci de m’aider.

Code

Sub convert_selection_to_pdf() ActiveSheet.Range("A1:H150").Select Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ ThisWorkbook.Path & "\Devis.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ActiveSheet.Range("A1").Select End Sub
 

patricktoulon

XLDnaute Barbatruc
bonjour
ça n'est pas un problème c'est que le code fait exactement ce que tu a codé
pour une incrémentation il faudrait être un peu plus généreux sur le contexte
quel moyen dans la feuille nous permettrais d'indexer une partie du nom
si pas possible fait un dir sur le dossier pour compter les fichiers et ajouter 1 a chaque fois que tu sauve
 

patricktoulon

XLDnaute Barbatruc
re
on s'en doute je te demande pas ça
je te demande si il y a un moyen sur la feuille qui est exportée en pdf de chopper un indice qui nous permettrais d'indexer le nom de fichier
et tu capable de répondre a cette question ?
 

Manho1

XLDnaute Nouveau
re
on s'en doute je te demande pas ça
je te demande si il y a un moyen sur la feuille qui est exportée en pdf de chopper un indice qui nous permettrais d'indexer le nom de fichier
et tu capable de répondre a cette question ?
J'ai un niveau debu
re
on s'en doute je te demande pas ça
je te demande si il y a un moyen sur la feuille qui est exportée en pdf de chopper un indice qui nous permettrais d'indexer le nom de fichier
et tu capable de répondre a cette question ?
Je ne suis pas capable de donner une réponse à cette question
J'ai un niveau débutant en VBA
 

Rhysand

XLDnaute Junior
Bonjour à tous

deux solutions parmi tant d'autres possibles

copier les codes suivants dans un module standard


VB:
Option Explicit


Public Function convertColor(xText As String, Optional ByVal xFont As String, Optional xColor As Long, Optional xFontSize As Long) As String
' convertir ColorConstants en couleur "& K" pour ActiveSheet.PageSetup Couleur du texte de l'en-tête
Dim newColor As String
Dim newFontSize As String

If VBA.Len(xFont) Then xFont = "&""" & xFont & """"

If VBA.Abs(xFontSize) Then newFontSize = "&" & VBA.Abs(xFontSize)

If xColor <> 0 Then
    newColor = "&K" & VBA.Right("0" & VBA.Hex(xColor And &HFF), 2) & _
    VBA.Right("0" & VBA.Hex(xColor \ &H100 And &HFF), 2) & VBA.Right("0" & VBA.Hex(xColor \ &H10000 And &HFF), 2)
End If

convertColor = xFont & newFontSize & newColor & xText

End Function

Public Function FolderFilePDF() As String 'Un dossier PDF existe-t-il? sinon en créer un si c'est possible

Dim WshShell As Object
Dim FSO As Object
Dim SpecialPath As String

Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("scripting.filesystemobject")

'SpecialPath = ThisWorkbook.path & Application.PathSeparator & "BackupPDF"
SpecialPath = ThisWorkbook.Path

If Right(SpecialPath, 1) <> "\" Then
    SpecialPath = SpecialPath & "\"
End If

If FSO.FolderExists(SpecialPath & "BackupPDF") = False Then
    On Error Resume Next
    MkDir SpecialPath & "BackupPDF"
    On Error GoTo 0
End If

If FSO.FolderExists(SpecialPath & "BackupPDF") = True Then
    FolderFilePDF = SpecialPath & "BackupPDF"
Else
    FolderFilePDF = "Error"
End If

End Function


Public Function ValidFileName(FileName As String) As Boolean '

Dim CurrentFolder As String
Dim DirFile As String

CurrentFolder = FolderFilePDF & "\"

ValidFileName = False
'On Error GoTo InvalidFileName
    DirFile = CurrentFolder & FileName & ".pdf"
    If Len(Dir(DirFile)) <> 0 Then
    ValidFileName = False
    Else
    ValidFileName = True
End If

Exit Function
'InvalidFileName:
'    ValidFileName = False
End Function

Public Function FileExist(FilePath As String) As Boolean 'DÉTERMINER SI LE FICHIER EXISTE OU NON

Dim TestStr As String

On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0

If TestStr = "" Then
    FileExist = False
  Else
    FileExist = True
End If

End Function


première solution - choisissez le nom que vous souhaitez attribuer au fichier PDF)

insérer le code suivant dans un bouton de contrôle (userform ou feuille)
dans cette solution, le fichier PDF placé dans un dossier créé à cet effet au même emplacement que le classeur


VB:
Private Sub CommandButton1_Click()

Dim CurrentFolder As String
Dim FileName As String
Dim mypath As String
Dim UniqueName As Boolean
Dim UserAnswer As VbMsgBoxResult
Dim DirFile As String
Dim FolderName As String

UniqueName = False

If FolderFilePDF = "Error" Then ' folder exist (MACRO)
    MsgBox "Erreur critique:" & vbCrLf & vbCrLf & "• Le programme n'a pas pu localiser le dossier de destination et il n'a pas non plus été possible de créer le dossier!", vbCritical, "Erreur critique!"
    Exit Sub
End If

'myPath = ActiveWorkbook.FullName
CurrentFolder = FolderFilePDF & "\"

fromTheStart:

'FileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
'FileName = "My PDF " & Me.TextBox1.Text
FileName = Application.InputBox("Entrez un nom pour enregistrer le fichier!", "Veuillez confirmer", FileName, , , , , Type:=2)
If FileName = "" Then
    MsgBox "Erreur:" & vbCrLf & vbCrLf & "• Le nom n'est pas valide car aucune donnée n'a été saisie dans la zone de texte!", vbCritical, "Une erreur est survenue!"
    GoTo fromTheStart:
End If
If FileName Like "*[[/*\?!#$%&(),;:.=]*" Or FileName Like "*[]]*" Then ' ne pas autoriser les caractères invalides
    MsgBox "Erreur:" & vbCrLf & vbCrLf & "• Le nom que vous avez entré n'est pas valide car il contient des caractères interdits!", vbCritical, "Une erreur est survenue!"
    GoTo fromTheStart:
End If
If CStr(FileName) = CStr(False) Then Exit Sub

Do While UniqueName = False 'Le fichier existe déjà?
    DirFile = CurrentFolder & FileName & ".pdf"
    If Len(Dir(DirFile)) <> 0 Then
        UserAnswer = MsgBox("Un fichier PDF portant ce nom a été trouvé:" & VBA.Chr(10) & VBA.Chr(10) & "• Voulez-vous le remplacer par ce nouveau?", vbQuestion + vbYesNoCancel, "Veuillez confirmer!")
            If CStr(UserAnswer) = CStr(False) Then Exit Sub
            If UserAnswer = vbCancel Then Exit Sub
            If UserAnswer = vbYes Then
                UniqueName = True
            ElseIf UserAnswer = vbNo Then
ReTry:
Do
                FileName = Application.InputBox("Entrez un nom pour enregistrer le fichier!", "Veuillez confirmer", FileName, , , , , Type:=2)
                        If FileName = "" Then
                            UniqueName = False
                            MsgBox "Erreur:" & vbCrLf & vbCrLf & "• Le nom n'est pas valide car aucune donnée n'a été saisie dans la zone de texte!", vbCritical, "Une erreur est survenue!"
                            GoTo ReTry:
                        End If
                        If FileName Like "*[[/*\?!#$%&(),;:.=]*" Or FileName Like "*[]]*" Then ' ne pas autoriser les caractères invalides
                            UniqueName = False
                            MsgBox "Erreur:" & vbCrLf & vbCrLf & "• Le nom que vous avez entré n'est pas valide car il contient des caractères interdits!", vbCritical, "Une erreur est survenue!"
                            GoTo ReTry:
                        End If
                        If CStr(FileName) = CStr(False) Then Exit Sub
                        Loop While ValidFileName(FileName) = False
                        If ValidFileName(FileName) Then
                            UniqueName = True
                            GoTo nextstep:
                        End If
            End If
    Else
      UniqueName = True
    End If
Loop

nextstep:
'----------------------------------------------------
'*faites attention, changez l'orientation de la page et le numéro de la ligne de titre
'----------------------------------------------------
With ActiveSheet.PageSetup
    '----------------------------------------------------
    '* change header text color - option 1
    '----------------------------------------------------
'    .CenterHeader = "&K00007DMa ligne de texte - " & VBA.Now ' font.text= dark blue
    '----------------------------------------------------
    '----------------------------------------------------
    '* (MACRO) change header text color - option 2 (standard colors: vbBlack, vbRed, vbGreen, vbYellow, vbBlue, vbMagenta, vbCyan, or vbWhite)
    '----------------------------------------------------
    '----------------------------------------------------
    .CenterHeader = convertColor("Ma ligne de texte - " & VBA.Now, "Times New Roman,Regular", vbBlue, 8)
    '----------------------------------------------------
    '----------------------------------------------------
    .Orientation = xlPortrait 'désactiver si vous activez la ligne suivante
'    .Orientation = xlLandscape 'désactiver si vous activez la ligne précédente
    '----------------------------------------------------
    '* activer ou désactiver la ligne suivante, s'il est activé indiquer le numéro de ligne à répéter comme en-tête sur les feuilles d'impression suivantes
'    .PrintTitleRows = ActiveSheet.Rows(12).Address '(ligne 12) ... spécifie qu'une ligne est répétée comme ligne d'en-tête en haut de chaque page imprimée
    '----------------------------------------------------
    .Zoom = False
    .FitToPagesTall = False
    .FitToPagesWide = 1 ' mettre toutes les colonnes sur une seule page
End With
'----------------------------------------------------

On Error GoTo ProblemSaving:
ActiveSheet.Range("A1:H150").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, _
      FileName:=CurrentFolder & FileName & ".pdf", _
      Quality:=xlQualityStandard, IncludeDocProperties:=True, _
      IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error GoTo 0

ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Select

MsgBox "Le fichier PDF a été créé et enregistré avec succès dans:" & VBA.Chr(10) & VBA.Chr(10) & "• " & CurrentFolder & VBA.Chr(10) & VBA.Chr(10) & "Avec le nom suivant:" & VBA.Chr(10) & VBA.Chr(10) & "• " & FileName, vbInformation, "Information!"

resumeExit:
    Exit Sub
ProblemSaving:
    MsgBox "Accès refusé:" & VBA.Chr(10) & VBA.Chr(10) & "• Une erreur s'est produite et nous n'avons pas pu corriger!" & VBA.Chr(10) & VBA.Chr(10) & "• Le fichier PDF avec ce nom est ouvert, vous devez le fermer et réessayer!", vbCritical, "Erreur critique!"
    GoTo resumeExit:
End Sub


Deuxième solution - si le fichier existe, attribuez un numéro à la fin de la nouvelle version

insérer le code suivant dans un bouton de contrôle (userform ou feuille)
dans cette solution, le fichier PDF se trouve au même emplacement que le classeur

VB:
Private Sub CommandButton4_Click()

Dim FolderPath As String
Dim mypath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim myArray() As Variant

Saved = False
x = "1"

VersionExt = "Devis N° " & VBA.Day(VBA.Now) & "-" & VBA.Month(VBA.Now) & "-" & VBA.Year(VBA.Now) & "_"

On Error GoTo NotSavedYet
mypath = ActiveWorkbook.Path & "\" & VersionExt & ".pdf"
myfilename = Mid(mypath, InStrRev(mypath, "\") + 1, InStrRev(mypath, ".") - InStrRev(mypath, "\") - 1)
FolderPath = Left(mypath, InStrRev(mypath, "\"))
SaveExt = ".pdf"
On Error GoTo 0

If InStr(1, myfilename, VersionExt) > 1 Then
    myArray = Split(myfilename, VersionExt)
    SaveName = myArray(0)
  Else
    SaveName = myfilename
End If

'----------------------------------------------------
'*faites attention, changez l'orientation de la page et le numéro de la ligne de titre
'----------------------------------------------------
With ActiveSheet.PageSetup
    '----------------------------------------------------
    '* change header text color - option 1
    '----------------------------------------------------
'    .CenterHeader = "&K00007DMa ligne de texte - " & VBA.Now ' font.text= dark blue
    '----------------------------------------------------
    '----------------------------------------------------
    '* (MACRO) change header text color - option 2 (standard colors: vbBlack, vbRed, vbGreen, vbYellow, vbBlue, vbMagenta, vbCyan, or vbWhite)
    '----------------------------------------------------
    '----------------------------------------------------
    .CenterHeader = convertColor("Ma ligne de texte - " & VBA.Now, "Times New Roman,Regular", vbBlue, 8)
    '----------------------------------------------------
    '----------------------------------------------------
    .Orientation = xlPortrait 'désactiver si vous activez la ligne suivante
'    .Orientation = xlLandscape 'désactiver si vous activez la ligne précédente
    '----------------------------------------------------
    '* activer ou désactiver la ligne suivante, s'il est activé indiquer le numéro de ligne à répéter comme en-tête sur les feuilles d'impression suivantes
'    .PrintTitleRows = ActiveSheet.Rows(12).Address '(ligne 12) ... spécifie qu'une ligne est répétée comme ligne d'en-tête en haut de chaque page imprimée
    '----------------------------------------------------
    .Zoom = False
    .FitToPagesTall = False
    .FitToPagesWide = 1 ' mettre toutes les colonnes sur une seule page
End With
'----------------------------------------------------
        
Do While Saved = False
    If FileExist(FolderPath & SaveName & x & SaveExt) = False Then
        On Error GoTo ProblemSaving:
        ActiveSheet.Range("A1:H150").Select
        Selection.ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=FolderPath & SaveName & x, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
        On Error GoTo 0
      Saved = True
    Else
      x = x + 1
    End If
Loop

finalStep:
ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Select

MsgBox "• Fichier PDF enregistré avec succès avec la version: ( " & FolderPath & SaveName & x & SaveExt & " )", vbInformation, "Information!"

resumeExit:
    Exit Sub
ProblemSaving:
    MsgBox "Erreur:" & VBA.Chr(10) & VBA.Chr(10) & "• Une erreur s'est produite et nous n'avons pas pu corriger!" & VBA.Chr(10) & VBA.Chr(10) & "• Le fichier PDF avec ce nom est ouvert, vous devez le fermer et réessayer!", vbCritical, "Erreur critique!"
    GoTo resumeExit:
NotSavedYet:
    MsgBox Err.Description
    GoTo resumeExit:
End Sub

J'espère aider
 
Dernière édition:

Manho1

XLDnaute Nouveau
Merc
i
 

Manho1

XLDnaute Nouveau
Merc
i
 

Rhysand

XLDnaute Junior
Bonjour

juste quelques changements à l'option 2 que je vous ai donné


VB:
Private Sub CommandButton4_Click()

Dim FolderPath As String
Dim mypath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim myArray() As Variant
Dim iniExt As String, endExt As String

Saved = False
x = "1"

VersionExt = "Devis N° " & VBA.Day(VBA.Now) & "-" & VBA.Month(VBA.Now) & "-" & VBA.Year(VBA.Now)
iniExt = "("
endExt = ")"

On Error GoTo NotSavedYet
mypath = ActiveWorkbook.Path & "\" & VersionExt & ".pdf"
myfilename = Mid(mypath, InStrRev(mypath, "\") + 1, InStrRev(mypath, ".") - InStrRev(mypath, "\") - 1)
FolderPath = Left(mypath, InStrRev(mypath, "\"))
SaveExt = ".pdf"
On Error GoTo 0

If InStr(1, myfilename, VersionExt) > 1 Then
    myArray = Split(myfilename, VersionExt)
    SaveName = myArray(0)
  Else
    SaveName = myfilename
End If

'----------------------------------------------------
'*faites attention, changez l'orientation de la page et le numéro de la ligne de titre
'----------------------------------------------------
With ActiveSheet.PageSetup
    '----------------------------------------------------
    '* change header text color - option 1
    '----------------------------------------------------
'    .CenterHeader = "&K00007DMa ligne de texte - " & VBA.Now ' font.text= dark blue
    '----------------------------------------------------
    '----------------------------------------------------
    '* (MACRO) change header text color - option 2 (standard colors: vbBlack, vbRed, vbGreen, vbYellow, vbBlue, vbMagenta, vbCyan, or vbWhite)
    '----------------------------------------------------
    '----------------------------------------------------
    .CenterHeader = convertColor("Ma ligne de texte - " & VBA.Now, "Times New Roman,Regular", vbBlue, 8)
    '----------------------------------------------------
    '----------------------------------------------------
    .Orientation = xlPortrait 'désactiver si vous activez la ligne suivante
'    .Orientation = xlLandscape 'désactiver si vous activez la ligne précédente
    '----------------------------------------------------
    '* activer ou désactiver la ligne suivante, s'il est activé indiquer le numéro de ligne à répéter comme en-tête sur les feuilles d'impression suivantes
'    .PrintTitleRows = ActiveSheet.Rows(12).Address '(ligne 12) ... spécifie qu'une ligne est répétée comme ligne d'en-tête en haut de chaque page imprimée
    '----------------------------------------------------
    .Zoom = False
    .FitToPagesTall = False
    .FitToPagesWide = 1 ' mettre toutes les colonnes sur une seule page
End With
'----------------------------------------------------

If FileExist(FolderPath & SaveName & SaveExt) = False Then
    On Error GoTo ProblemSaving:
        ActiveSheet.Range("A1:H150").Select
        Selection.ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=FolderPath & SaveName, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
        On Error GoTo 0
        MsgBox "• Fichier PDF enregistré avec succès!", vbInformation, "Information!"    
       ActiveSheet.DisplayPageBreaks = False
        ActiveSheet.Select
        Exit Sub
End If
         
Do While Saved = False
    If FileExist(FolderPath & SaveName & iniExt & x & endExt & SaveExt) = False Then
        On Error GoTo ProblemSaving:
        ActiveSheet.Range("A1:H150").Select
        Selection.ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=FolderPath & SaveName & addExt & iniExt & x & endExt, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
        On Error GoTo 0
      Saved = True
    Else
      x = x + 1
    End If
Loop

finalStep:
ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Select

MsgBox "• Fichier PDF enregistré avec succès avec la version: < " & FolderPath & SaveName & addExt & iniExt & x & endExt & " >", vbInformation, "Information!"

resumeExit:
    Exit Sub
ProblemSaving:
    MsgBox "Erreur:" & VBA.Chr(10) & VBA.Chr(10) & "• Une erreur s'est produite et nous n'avons pas pu corriger!" & VBA.Chr(10) & VBA.Chr(10) & "• Le fichier PDF avec ce nom est ouvert, vous devez le fermer et réessayer!", vbCritical, "Erreur critique!"
    GoTo resumeExit:
NotSavedYet:
    MsgBox Err.Description
    GoTo resumeExit:
End Sub
 

Discussions similaires

Réponses
3
Affichages
751
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…