Nommer Fichier pour imprimer en PDF depuis un Listbox

Version imprimable

Bonjour a tous je cherche une âme charitable pour mon problème voir code
Merci d'avance.

La Feuil15 correspond a mes Données

Explication du code pour celui si correspond a une sauvegarde avec PDF du fichier en court mais moi je cherche pour une Sauvegarde simplement en PDF depuis la feuil15 en C13 ou j'ai déjà renseigner dans le code mais qui ne fonctionne pas .
Le UserForm avec la Listebox (oui actionne par image ) la pas de soucis je peux sélectionner les actions pour choisir les onglets.

Le But d'avoir un PDF différant que l'original .

Merci..:)

Code:

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

09/05/2017, 20h44
kiki29

Salut, quand tu sauras ce que tu veux ..... 1 2 etc
09/05/2017, 21h14
stef3700

Oui effectivement mais plus j'avance plus je me rencontres qu'il me faut des actions dans mon fichier. Car en final j'essaie de veroullier mon fichier pour éviter que les futurs utilisateurs m'apporte la pagaille. la possibilité d'imprimer en PDF nommés si dessus reste d'actualité.
J'essaie de me renseigner sur les tuto ,fofo .mais c'est vrai je suis novice puis ma femme râle pas mal.
Voilà ma situation à se jour.
Juste de l'aide SVP
Merci

Salut,

Code:

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
Option Explicit
 
Sub EnregistrementPDF()
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 ThisWorkbook.Path & "\" & sFichier
            Else
                SavePDF ThisWorkbook.Path & "\" & sFichier
            End If
            Set FSO = Nothing
        End If
    Else
        Feuil15.Range("C13").Select
        MsgBox "Nom de fichier invalide", vbCritical + vbOKOnly
    End If
 
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(sNomFichier As String)
Dim Ar(0) As String
 
    Ar(0) = Feuil15.Name
    Application.ScreenUpdating = False
    Sheets(Ar).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:=sNomFichier & ".pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
    With Feuil15
        .Select
        .Range("A2").Select
    End With
 
    Application.ScreenUpdating = True
End Sub

Merci presque ca ;)
pour avoir la possibilité depuis la sélection de la ListBox en si dessous en multi sélections .

Merci

Code:

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
Private Sub UserForm_Initialize()
Dim wk As Worksheet
    For Each wk In ThisWorkbook.Worksheets
    If wk.Name <> "Feuil01" Then
    If wk.Visible = True Then
    ListBox1.AddItem wk.Name
    End If
    End If
    Next
End Sub
Private Sub CommandButton1_Click()
'--- Déclaration des variables
Dim I As Integer
Dim Feuille() As Variant
Dim NbFeuille As Integer
'--- Impression des onglets sélectionnés
 With ListBox1
    For I = 0 To .ListCount - 1
      If .Selected(I) Then
        ReDim Preserve Feuille(NbFeuille)
        Feuille(NbFeuille) = .List(I)
        NbFeuille = NbFeuille + 1
      End If
    Next I
    End With
    '--- Impression des feuilles listées
  With Sheets(Feuille)
       .PrintOut
        'PrintPreview 'en preview Bug
  End With
    Unload Me
    End
End Sub

10/05/2017, 22h51
stef3700

Bonsoir j'ai besoins d"aide SVP
pour enregistré en PDF depuis la ListBox1 en sélection divers car je peux choisir dedans les différents onglets qui s’affiche puis avec comme nom en Feuil15.Range("C13")
car la je suis coincer je comprend plus rien après les test
Merci :cry:

1 pièce(s) jointe(s)

Re, même si ta demande s'avère quelque peu difficile à comprendre ( charabia )
Code UserForm

Code:

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
Option Explicit
 
Private Sub cmdAnnuler_Click()
    Unload Me
End Sub
 
Private Sub cmdImprimer_Click()
Dim i As Long, j As Long
    Erase Ar: j = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            ReDim Preserve Ar(j)
            Ar(j) = ListBox1.List(i)
            j = j + 1
        End If
    Next i
 
    If j > 0 Then
        EnregistrementPDF
        Unload Me
    Else
        ListBox1.SetFocus
        MsgBox "Sélectionner une feuille dans la liste"
    End If
End Sub
 
Private Sub UserForm_Initialize()
Dim Wsh As Worksheet
    ListBox1.Clear
    For Each Wsh In ThisWorkbook.Worksheets
        If Wsh.Name <> Feuil1.Name And Wsh.Visible = True Then
            ListBox1.AddItem Wsh.Name
        End If
    Next Wsh
End Sub

Code dans un module standard

Code:

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
Option Explicit
 
Public Ar() As String
 
Sub EnregistrementPDF()
Dim Rep As Long, sFichier As String
Dim FSO As Object
    sFichier = Feuil15.Range("C13").Text
    If NomFichierValide(sFichier) Then
        Rep = MsgBox("Voulez-vous sauvegarder 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 ThisWorkbook.Path & "\" & sFichier
            Else
                SavePDF ThisWorkbook.Path & "\" & sFichier
            End If
            Set FSO = Nothing
        End If
    Else
        With Feuil15
            .Activate
            .Range("C13").Select
        End With
        MsgBox "Nom de fichier invalide", vbCritical + vbOKOnly
    End If
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(sNomFichier As String)
    Application.ScreenUpdating = False
    Sheets(Ar).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:=sNomFichier & ".pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
    With Feuil1
        .Select
        .Range("A2").Select
    End With
    Application.ScreenUpdating = True
End Sub