Discussion :

[kiki29]

Le but de ce code est de pouvoir générer un fichier Pdf via Distiller en nommant le fichier comme on l'entend,
et en le sauvant dans un dossier de son choix : choix autre que celui assigné par défaut lors de l'installation de la suite Acrobat.

Testé sous Excel XP ( 2002 SP3 ) / Acrobat 6.0.6 Pro / Distiller 6.0.1
Early Binding
sous VBE Menu Outils | Références cocher Acrobat Distiller

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
Dim sNomPortReseau As String
 
Sub Tst_Adobe_PDF_03()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim PDFDist As PdfDistiller
Dim PrinterDefault As String
 
    '   Sur un PC "Personnel" : a priori choix libre du Nom
    '   et de l'emplacement du fichier de sortie, on est logué en 
    '   Administrateur sur son PC
    '
    '   Sur un PC "Entreprise" :
    '   Il faut être logué en Administrateur ou en
    '   Avoir les droits pour utiliser Distiller
    '   Les chemins PS PDF LOG devront être de la forme :
    '       "C:\Documents and Settings\UserName\.....\....."
 
    '   Si l'on a plusieurs imprimantes il faut :
    '       Sélectionner l'imprimante virtuelle Adobe PDF tout en conservant
    '           trace de l'imprimante utilisée par défaut
    '   Le N° de port réseau NeXY varie suivant le PC sur lequel la macro tourne
 
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly+vbCritical, "Achtung"
        Exit Sub
    End If
 
    ' Ici le cas d'un PC "Personnel"
    sNomFichierPS = ThisWorkbook.Path & "\" & "Essai_AdobbePDF.ps"
    sNomFichierPDF = ThisWorkbook.Path & "\" & "Essai_AdobbePDF.pdf"
    sNomFichierLOG = ThisWorkbook.Path & "\" & "Essai_AdobbePDF.log"
 
    '   Impression d'une zone nommée
    ActiveSheet.Range("Zone").PrintOut Copies:=1, Preview:=False, _
                                       ActivePrinter:=sNomPortReseau , PrintToFile:=True, _
                                       Collate:=True, PrToFilename:=sNomFichierPS
 
    Set PDFDist = New PdfDistiller
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLOG
 
    Application.ActivePrinter = PrinterDefault
End Sub
 
Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    ' 11 imprimantes réseau
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

Dans une configuration d'Entreprise avec de multiples utilisateurs et les droits attenants il peut être nécessaire de connaitre son nom de login ( qui n'a rien à voir avec Application.UserName de VBA )

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
...
Dim sUserName As String
    sUserName = Environ("USERNAME")
...

Ou si l'on préfère connaître le chemin "C:\Documents and Settings\UserName"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
...
Dim sUserProfile as string
    sUserProfile = Environ("USERPROFILE")
...

Dans ce cas l'exemple ci-dessus deviendra qqch comme :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Dim sNomPortReseau As String
 
Sub Tst_Adobe_PDF()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim PDFDist As PdfDistiller
Dim PrinterDefault As String
Dim sUserProfile As String
 
    sUserProfile = Environ("USERPROFILE")
 
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly+vbCritical, "Achtung"
        Exit Sub
    End If
 
    ' Ici le cas d'un PC "Entreprise"
    sNomFichierPS = sUserProfile & "\" & "Essai_AdobbePDF.ps"
    sNomFichierPDF = sUserProfile & "\" & "Essai_AdobbePDF.pdf"
    sNomFichierLOG = sUserProfile & "\" & "Essai_AdobbePDF.log"
 
    ActiveSheet.Range("Zone").PrintOut Copies:=1, Preview:=False, _
                                       ActivePrinter:=sNomPortReseau , PrintToFile:=True, _
                                       Collate:=True, PrToFilename:=sNomFichierPS
 
    Set PDFDist = New PdfDistiller
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLOG
 
    Application.ActivePrinter = PrinterDefault
End Sub
 
Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    ' 11 imprimantes réseau
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

Impression de certaines Feuilles d'un classeur via un tableau dans un seul Pdf résultant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
Dim sNomPortReseau As String
 
Sub Tst4()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLog As String
Dim PDFDist As PdfDistiller, PrinterDefault As String
Dim i As Long, Cpt As Long
Dim Ar() As String
 
    sNomFichierPS = ThisWorkbook.Path & "\" & "Tableau.ps"
    sNomFichierPDF = ThisWorkbook.Path & "\" & "Tableau.pdf"
    sNomFichierLog = ThisWorkbook.Path & "\" & "Tableau.log"
 
    Cpt = 0
    For i = 1 To ThisWorkbook.Sheets.Count
        If Left(Sheets(i).Name, 2) = "RF" Or Left(Sheets(i).Name, 2) = "RC" Then
            ReDim Preserve Ar(Cpt)
            Ar(Cpt) = Sheets(i).Name
            Cpt = Cpt + 1
        End If
    Next i
    If Cpt = 0 Then Exit Sub
 
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly + vbCritical, "Achtung"
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
    Sheets(Ar).PrintOut copies:=1, Preview:=False, _
                        ActivePrinter:=sNomPortReseau, PrintToFile:=True, _
                        PrToFileName:=sNomFichierPS
 
    Set PDFDist = New PdfDistiller
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLog
 
    Application.ScreenUpdating = True
    Application.ActivePrinter = PrinterDefault
    Sheets("Feuil1").Select
End Sub
 
Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    ' 11 imprimantes réseau
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

en Late Binding ( sans référence à cocher )

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit

Dim sNomPortReseau As String

Sub Tst_Adobe_PDF()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim PDFDist As Object
Dim PrinterDefault As String
Dim sUserProfile As String
 
    sUserProfile = Environ("USERPROFILE")
    
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly + vbCritical, "Achtung"
        Exit Sub
    End If
   
    sNomFichierPS = sUserProfile & "\" & "LateBinding_AdobePDF.ps"
    sNomFichierPDF = sUserProfile & "\" & "LateBinding_AdobePDF.pdf"
    sNomFichierLOG = sUserProfile & "\" & "LateBinding_AdobePDF.log"
 
    ActiveSheet.Range("Zone").PrintOut Copies:=1, Preview:=False, _
                                       ActivePrinter:=sNomPortReseau, PrintToFile:=True, _
                                       Collate:=True, PrToFilename:=sNomFichierPS
 
    Set PDFDist = CreateObject("PdfDistiller.PdfDistiller")
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLOG
 
    Application.ActivePrinter = PrinterDefault
End Sub

Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

Sous Excel 2007, moyennant le téléchargement d'un complément qui rend possible l'enregistrement en Pdf (ou Xps)
http://www.microsoft.com/downloads/d...displaylang=fr
Le SP2 intègre ce complément
Impression de certaines Feuilles d'un classeur via un tableau dans un seul Pdf résultant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Tst_2007()
Dim sNomFichierPDF As String
Dim i As Long, Cpt As Long
Dim Ar() As String
 
    sNomFichierPDF = ThisWorkbook.Path & "\" & "Tableau2007.pdf"
 
    Cpt = 0
    For i = 1 To ThisWorkbook.Sheets.Count
        If Left(Sheets(i).Name, 2) = "RF" Or Left(Sheets(i).Name, 2) = "RC" Then
            ReDim Preserve Ar(Cpt)
            Ar(Cpt) = Sheets(i).Name
            Cpt = Cpt + 1
        End If
    Next i
    If Cpt = 0 Then Exit Sub
 
    Application.ScreenUpdating = False
    Sheets(Ar).Select
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNomFichierPDF _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
    Sheets("Feuil1").Select
    Application.ScreenUpdating = True
End Sub