1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
| Private Sub Image6_Click() 'Fermer_Classeur_avec_PDF
' Protege le classeur
Dim Feuille As Worksheet
For Each Feuille In ThisWorkbook.Worksheets
If Feuille.Name <> "" Then Feuille.Protect "55", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowSorting:=True
Next
Dim Rep As Long, sFichier As String
Dim FSO As Object
sFichier = Feuil15.Range("C13")
If NomFichierValide(sFichier) Then
Rep = MsgBox("Voulez-vous vraiment quitter pour imprimer EN pdf" , vbYesNo)
If Rep = vbYes Then
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(ThisWorkbook.Path & "\" & sFichier & ".pdf") Then
Rep = MsgBox("Le fichier pdf existe déjà, confirmer son écrasement ?", vbYesNo)
If Rep = vbYes Then SavePDF_XLS ThisWorkbook.Path & "\" & sFichier
Else
SavePDF_XLS ThisWorkbook.Path & "\" & sFichier
End If
Set FSO = Nothing
End If
Else
Feuil15.Range("C13").Select
MsgBox "Nom de fichier invalide", vbCritical + vbOKOnly
End If
Unload MENU
End Sub
Private Function NomFichierValide(sChaine As String) As Boolean
Dim I As Long
Const CaracInterdits As String = """*/:<>?[\]|"
NomFichierValide = True
If Len(sChaine) = 0 Then
NomFichierValide = False
Exit Function
End If
For I = 1 To Len(CaracInterdits)
If InStr(sChaine, Mid$(CaracInterdits, I, 1)) > 0 Then
NomFichierValide = False
Exit Function
End If
Next I
End Function
Private Sub SavePDF_XLS(sNomFichier As String) ' Pour choisir les onglet en PDF
Dim Ar(1) As String
Ar(0) = "TOTO"
Ar(1) = "TITI"
Application.ScreenUpdating = False
Sheets(Ar).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sNomFichier & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
'Permer de ranger les cellule par defaut sur chaque onglet
Sheets("TOTO").Select
Range("C1").Select
Sheets("TITI").Select
Range("B1").Select
'
Sheets("TOTO").Visible = True
Sheets("TITI").Visible = False
Range("A2").Select
'
On Error Resume Next
ThisWorkbook.SaveCopyAs sNomFichier & ".xlsm"
On Error GoTo 0
Application.ScreenUpdating = True
Unload MENU
ActiveWorkbook.Save 'Fermeture Avec sauvegarde
CancelSortie = False 'reactive la croix de fermeture
ActiveWorkbook.Close
End Sub |
Partager