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
