Macro imprimer les pièces jointes séléctionnées

**bladinium** · 25/04/2015, 02h01

Bonjour,

Je recherche une macro me permettant d’imprimer les pièces jointes des mails sélectionné.

J'en ai vu quelque une sur le web, mais cela me dit qu'elle ne sont pas valide en 64b.

Si une bonne âme voulait bien m'en faire une ?

Merci d'avance

**bladinium** · 26/04/2015, 20h56

Bonsoir,

Pas de bonne âme ? :=) une mauvaise âme dans ce cas ?

**Oliv-** · 27/04/2015, 12h45

Salut,
c'est un sujet a la fois simple et complexe.
En fait, cela dépend en partie du type de pièces jointes et vers quelle imprimante tu veux les envoyer.

**bladinium** · 28/04/2015, 17h24

Bonjour,

Merci pour votre réponse!

En faite, le fichier est un fichier HTML (un bon de commande) et l'imprimante se trouve en réseau \\PC-DE-AUDREY USB HP Officejet 4500 G510n-z

Je vous remercie de votre aide.

Cordialement

**Oliv-** · 28/04/2015, 17h36

Bjr,
voici pour imprimer vers l'imprimante par défaut

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
Sub ImprimePDFdeTouteLaSelection()
'---------------------------------------------------------------------------------------
' Procedure : ImprimeTouteLaSelection
' Author    : Oliv'
' Date      : 28/04/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim MonOutlook As Outlook.Application
    Dim Mail As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    Dim Res As Long
    Dim chemin_de_MaPj As String
    Dim LeFichier
    Dim Repertoire, N

    Repertoire = "c:\temp\PRINTtemp\"
    For Each LeMail In LesMails
        Dim pj As Attachment
        For Each pj In LeMail.Attachments
            If Right(UCase(pj.FileName), 4) = ".HTM" Then


                'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
                Dim MemPath, PathNomExport
                N = 1
                MemPath = Replace(pj.FileName, "€", "euro")
                PathNomExport = MemPath
                While Dir(Repertoire & PathNomExport) <> ""
                    PathNomExport = "(" & N & ")" & MemPath
                    N = N + 1
                Wend
                LeFichier = Repertoire & PathNomExport

                pj.SaveAsFile (LeFichier)
                'là tu mets ta fonction pour imprimer
                Do Until Dir(LeFichier, vbNormal) = PathNomExport
                    DoEvents
                Loop

                Res = ShellExecute(0, "print", LeFichier, "", "", 1)

                DoEvents
                'Kill LeFichier    'supprime le fichier
            End If
        Next pj

    Next LeMail
    Set LesMails = Nothing
    MsgBox "Opération terminée"
End Sub

**bladinium** · 28/04/2015, 20h06

Bonjour,

Cela me met une erreur :
Nom : 5286b5cc8d.png
Affichages : 1732
Taille : 161,4 Ko

Cdlt

**joe.levrai** · 29/04/2015, 08h08

Bonjour,

il faut déclarer la fonction en haut du module (avant ta procédure)

Code :

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

1
2
3
4
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ 
    (ByVal hwnd As Long, ByVal lpOperation As String, _ 
    ByVal lpFile As String, ByVal lpParameters As String, _ 
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

**Oliv-** · 29/04/2015, 08h45

C'est bien cela merci Joe

**bladinium** · 29/04/2015, 12h51

Bonjour,

Merci à vous,

Apriori, j'ai du faire une modification pour le 64bits, cependant maintenant j'obtient bien la msgbox, cependant rien ne s'imprime et rien a l'air de bouger.

mon code :

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
 
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If
 
 
Sub ImprimePDFdeTouteLaSelection()
 
    Dim MonOutlook As Outlook.Application
    Dim Mail As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    Dim Res As Long
    Dim chemin_de_MaPj As String
    Dim LeFichier
    Dim Repertoire, N
 
    Repertoire = "c:\temp\PRINTtemp\"
    For Each LeMail In LesMails
        Dim pj As Attachment
        For Each pj In LeMail.Attachments
            If Right(UCase(pj.FileName), 4) = ".HTM" Then
 
 
                'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
                Dim MemPath, PathNomExport
                N = 1
                MemPath = Replace(pj.FileName, "€", "euro")
                PathNomExport = MemPath
                While Dir(Repertoire & PathNomExport) <> ""
                    PathNomExport = "(" & N & ")" & MemPath
                    N = N + 1
                Wend
                LeFichier = Repertoire & PathNomExport
 
                pj.SaveAsFile (LeFichier)
                'là tu mets ta fonction pour imprimer
                Do Until Dir(LeFichier, vbNormal) = PathNomExport
                    DoEvents
                Loop
 
                Res = ShellExecute(0, "print", LeFichier, "", "", 1)
 
                DoEvents
                'Kill LeFichier    'supprime le fichier
            End If
        Next pj
 
    Next LeMail
    Set LesMails = Nothing
    MsgBox "Opération terminée"
End Sub

cordialement

**Oliv-** · 29/04/2015, 14h12

SAlut,
Vérifie si ta pj à bien l’extension .htm sinon modifie le code en conséquence, tu peux aussi enlever le test ( If Right(UCase(pj.FileName), 4) = ".HTM" Then)
mais du coup cela peut imprimer toutes PJ y compris les images incorporées dans le corps du Mail.

Chez moi cela fonctionne, j'ai cependant une boite de dialogue me demandant de choisir l'imprimante.
En fait l'impression se fait comme lorsque l'on fait clic droit sur un document puis imprimer.
cela utilise le programme par défaut pour ce type d'extention. (ici IE8)

En testant avec chrome, il ne semble pas y avoir d'option imprimer lors du clic droit c'est peut être cela ton pb

**bladinium** · 29/04/2015, 14h33

Bonjour,

L'extension est en "HTML" Je l'ai modifier.

En décryptant la procédure, il créer un fichier et ensuite utilise la fonction "Print", j'ai tenter de reproduire manuellement la macro, cependant lorsque je fait clique droit puis print rien ne ce passe... j'essais de trouver des infos mais je n'en trouve pas sur cette fameuse option "Print"... Je pense que le problème est là

**Oliv-** · 29/04/2015, 15h08

Manuellement il faut utiliser l'exporateur windows pour cliquer bouton droit sur le fichier exporté.

Quel est ton navigateur par défaut ?

Est ce que tu dois diffuser ta macro sur d'autres postes ?

Je vois 2 autres méthodes pour imprimer ton fichier HTML, soit tu "pilotes WORD", soit tu "pilotes INTERNET EXPLORER" pour ouvrir ce fichier et l'imprimer.

Est ce que ton fichier html comporte du simple texte ou des tableaux ?

**bladinium** · 29/04/2015, 15h20

Par default c'est Firefox

Mon fichier utilise des tableaux il est présenté comme ceci
Nom : b3efbd222c.png
Affichages : 1557
Taille : 53,1 Ko

cdlt

**Oliv-** · 29/04/2015, 16h44

Essaye avec cà,
si les tableaux débordent il faudra changer la mise en page en PAYSAGE.

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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
Sub ImprimeHTMLdeTouteLaSelectionWORD()
'---------------------------------------------------------------------------------------
' Procedure : ImprimeHTMLdeTouteLaSelectionWORD
' Author    : octu
' Date      : 29/04/2015
' Purpose   : Impression PJ des Emails seléctionné avec WORD
'---------------------------------------------------------------------------------------
'
 
    Dim MonOutlook As Outlook.Application
    Dim Mail As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    Dim Res As Long
    Dim chemin_de_MaPj As String
    Dim LeFichier
    Dim Repertoire, N
 
    Repertoire = "C:\temp\PRINTtemp\"
    For Each LeMail In LesMails
        Dim pj As Attachment
        For Each pj In LeMail.Attachments
            If Right(UCase(pj.FileName), 4) = ".HTM" Then
 
 
                'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
                Dim MemPath, PathNomExport
                N = 1
                MemPath = Replace(pj.FileName, "€", "euro")
                PathNomExport = MemPath
                While Dir(Repertoire & PathNomExport) <> ""
                    PathNomExport = "(" & N & ")" & MemPath
                    N = N + 1
                Wend
                LeFichier = Repertoire & PathNomExport
 
                pj.SaveAsFile (LeFichier)
                'là tu mets ta fonction pour imprimer
                Do Until Dir(LeFichier, vbNormal) = PathNomExport
                    DoEvents
                Loop
 
                Set AppWord = CreateObject("Word.Application")
 
                On Error GoTo 0
 
 
 
                AppWord.Visible = True
                Boucle = 0
                'GoTo debut
                'ouvre le mail
 
                AppWord.DisplayAlerts = 0    ' wdAlertsNone
                AppWord.Documents.Open FileName:= _
                                       LeFichier, _
                                       ConfirmConversions:=False, ReadOnly:=True, AddToRecentFiles:=False, _
                                       PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                                       WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                                       wdOpenFormatAuto, XMLTransform:=""
                AppWord.DisplayAlerts = -1    'wdAlertsAll
                AppWord.ScreenUpdating = True
 
                'mise en page
                With AppWord.ActiveDocument.PageSetup
                    .LineNumbering.Active = False
                    .Orientation = 0    'wdOrientPortrait
                    .TopMargin = AppWord.CentimetersToPoints(1)
                    .BottomMargin = AppWord.CentimetersToPoints(1)
                    .LeftMargin = AppWord.CentimetersToPoints(1)
                    .RightMargin = AppWord.CentimetersToPoints(1)
                    .Gutter = 0
                    .HeaderDistance = AppWord.CentimetersToPoints(1)
                    .FooterDistance = AppWord.CentimetersToPoints(1)
                    .FirstPageTray = 0    'wdPrinterDefaultBin
                    .OtherPagesTray = 0    'wdPrinterDefaultBin
                    .SectionStart = 2    'wdSectionNewPage
                    .OddAndEvenPagesHeaderFooter = False
                    .DifferentFirstPageHeaderFooter = False
                    .VerticalAlignment = 0    'wdAlignVerticalTop
                    .SuppressEndnotes = False
                    .MirrorMargins = False
                    .TwoPagesOnOne = False
                    .BookFoldPrinting = False
                    .BookFoldRevPrinting = False
                    .BookFoldPrintingSheets = 1
                    .GutterPos = 0    'wdGutterPosLeft
                End With
 
                Const wdPrintAllDocument = 0
                Const wdPrintDocumentContent = 0
                Const wdPrintAllPages = 0
                AppWord.PrintOut FileName:="", Range:=wdPrintAllDocument, item:= _
                                 wdPrintDocumentContent, copies:=1, Pages:="", PageType:=wdPrintAllPages, _
                                 ManualDuplexPrint:=False, Collate:=True, Background:=False, PrintToFile:= _
                                 False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=11907, _
                                 PrintZoomPaperHeight:=16839, Append:=False
                DoEvents
                AppWord.ActiveDocument.Close SaveChanges:=0    'wdDoNotSaveChanges
 
 
                On Error Resume Next
                If Not "" = Dir(LeFichier) Then
                    Kill LeFichier
                    DoEvents
                End If
                '   appWord.application.Quit
                AppWord.DisplayAlerts = -1    ' wdAlertsAll
                AppWord.Visible = False
                If AppWord.Documents.Count = 0 Then AppWord.Quit
                Set AppWord = Nothing
            End If
        Next pj
 
    Next LeMail
    Set LesMails = Nothing
    MsgBox "Impressions terminées"
End Sub

**bladinium** · 29/04/2015, 17h12

Bonjour,

Là ça devient dur, je n'ai pas de message d'erreur mais cela ne fonctionne toujours pas

Cordialement

**Oliv-** · 29/04/2015, 18h11

IL FAUT TESTER EN MODE PAS à PAS avec F8

**bladinium** · 29/04/2015, 18h32

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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
       (ByVal hwnd As Long, _
                                       ByVal lpszOp As String, _
                                       ByVal lpszFile As String, _
                                       ByVal lpszParams As String, _
                                       ByVal lpszDir As String, _
                                       ByVal FsShowCmd As Long) As Long
Sub ImprimeHTMLdeTouteLaSelectionWORD()
'---------------------------------------------------------------------------------------
' Procedure : ImprimeHTMLdeTouteLaSelectionWORD
' Author    : octu
' Date      : 29/04/2015
' Purpose   : Impression PJ des Emails seléctionné avec WORD
'---------------------------------------------------------------------------------------
'
 
    Dim MonOutlook As Outlook.Application
    Dim Mail As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    Dim Res As Long
    Dim chemin_de_MaPj As String
    Dim LeFichier
    Dim Repertoire, N
 
    Repertoire = "C:\temp\PRINTtemp\"
    For Each LeMail In LesMails
        Dim pj As Attachment
        For Each pj In LeMail.Attachments
            If Right(UCase(pj.FileName), 4) = ".HTML" Then
 
 
                'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
                Dim MemPath, PathNomExport
                N = 1
                MemPath = Replace(pj.FileName, "€", "euro")
                PathNomExport = MemPath
                While Dir(Repertoire & PathNomExport) <> ""
                    PathNomExport = "(" & N & ")" & MemPath
                    N = N + 1
                Wend
                LeFichier = Repertoire & PathNomExport
 
                pj.SaveAsFile (LeFichier)
                'là tu mets ta fonction pour imprimer
                Do Until Dir(LeFichier, vbNormal) = PathNomExport
                    DoEvents
                Loop
 
                Set AppWord = CreateObject("Word.Application")
 
                On Error GoTo 0
 
 
 
                AppWord.Visible = True
                Boucle = 0
                'GoTo debut
                'ouvre le mail
 
                AppWord.DisplayAlerts = 0    ' wdAlertsNone
                AppWord.Documents.Open FileName:= _
                                       LeFichier, _
                                       ConfirmConversions:=False, ReadOnly:=True, AddToRecentFiles:=False, _
                                       PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                                       WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                                       wdOpenFormatAuto, XMLTransform:=""
                AppWord.DisplayAlerts = -1    'wdAlertsAll
                AppWord.ScreenUpdating = True
 
                'mise en page
                With AppWord.ActiveDocument.PageSetup
                    .LineNumbering.Active = False
                    .Orientation = 0    'wdOrientPortrait
                    .TopMargin = AppWord.CentimetersToPoints(1)
                    .BottomMargin = AppWord.CentimetersToPoints(1)
                    .LeftMargin = AppWord.CentimetersToPoints(1)
                    .RightMargin = AppWord.CentimetersToPoints(1)
                    .Gutter = 0
                    .HeaderDistance = AppWord.CentimetersToPoints(1)
                    .FooterDistance = AppWord.CentimetersToPoints(1)
                    .FirstPageTray = 0    'wdPrinterDefaultBin
                    .OtherPagesTray = 0    'wdPrinterDefaultBin
                    .SectionStart = 2    'wdSectionNewPage
                    .OddAndEvenPagesHeaderFooter = False
                    .DifferentFirstPageHeaderFooter = False
                    .VerticalAlignment = 0    'wdAlignVerticalTop
                    .SuppressEndnotes = False
                    .MirrorMargins = False
                    .TwoPagesOnOne = False
                    .BookFoldPrinting = False
                    .BookFoldRevPrinting = False
                    .BookFoldPrintingSheets = 1
                    .GutterPos = 0    'wdGutterPosLeft
                End With
 
                Const wdPrintAllDocument = 0
                Const wdPrintDocumentContent = 0
                Const wdPrintAllPages = 0
                AppWord.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
                                 wdPrintDocumentContent, copies:=1, Pages:="", PageType:=wdPrintAllPages, _
                                 ManualDuplexPrint:=False, Collate:=True, Background:=False, PrintToFile:= _
                                 False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=11907, _
                                 PrintZoomPaperHeight:=16839, Append:=False
                DoEvents
                AppWord.ActiveDocument.Close SaveChanges:=0    'wdDoNotSaveChanges
 
 
                On Error Resume Next
                If Not "" = Dir(LeFichier) Then
                    Kill LeFichier
                    DoEvents
                End If
                '   appWord.application.Quit
                AppWord.DisplayAlerts = -1    ' wdAlertsAll
                AppWord.Visible = False
                If AppWord.Documents.Count = 0 Then AppWord.Quit
                Set AppWord = Nothing
            End If
        Next pj
 
    Next LeMail
    Set LesMails = Nothing
    MsgBox "Impressions terminées"
End Sub

Voici les erreurs jaunes que ça me retourne en F8

**Oliv-** · 30/04/2015, 09h15

Bonjour,
Le mode pas à pas ne retourne pas forcement d'erreur, il permet d’exécuter chaque instruction avec une pause pour voir ce qui se passe.

Les vrais erreurs feront stopper ton code même sans cela !

Par contre ça permet de voir si un test ou une boucle se fait bien et on peut consulter les variables locales et/ou mettre des espions.

Je te conseille de lire ces articles ils ne sont pas forcèment propre à Outlook mais une grosse partie du VBA est commune à l'ensemble d'office.
http://cafeine.developpez.com/access...ebugprint/#LIV

http://silkyroad.developpez.com/VBA/DebuterMacros

http://dolphy35.developpez.com/article/outlook/vba/

Ton problème vient de là

Code :

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

  If Right(UCase(pj.FileName), 4) = ".HTML" Then

à remplacer par

Code :

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

  If Right(UCase(pj.FileName), 5) = ".HTML" Then

**Oliv-** · 30/04/2015, 10h07

Pour tester l'extension de fichier tu peux utiliser cette fonction

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
Function get_File_extension(file As String, Optional Majuscule As Boolean) As String
'---------------------------------------------------------------------------------------
' Procedure : get_File_extension
' Author    : octu
' Date      : 30/04/2015
' Purpose   : retrouve l'extension d'un fichier
'---------------------------------------------------------------------------------------
'
    Dim revFile As String
    Dim PositionPoint As Long
    get_File_extension = ""
    revFile = StrReverse(file)
    PositionPoint = InStr(1, revFile, ".", vbTextCompare)
    get_File_extension = StrReverse(Mid(revFile, 1, PositionPoint))
    If Majuscule = True Then get_File_extension = UCase(get_File_extension)
End Function

ce qui donne

Code :

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

If get_File_extension(pj.FileName, true) = ".HTML" Then

Déclinable comme cela

Code :

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

If get_File_extension(pj.FileName, true) = ".HTML" or get_File_extension(pj.FileName, true) =".HTM" Then

**bladinium** · 30/04/2015, 12h43

Bonjour!

Super ça fonctionne! J'ai essayer de trouver pour imprimer en qualité brouillons et en réduisant les marges, mais il y a un bug avec la qualités brouillons. J'utilise cette variable : .PrintQuality = 100 (testé avec -1 et 600)

je l'ai inclus a la fin de : With AppWord.ActiveDocument.PageSetup

Cependant il me dit que ça bug. je pense qu'il s'agit de la variable pour excel mais pas pour word, et je n'arrive pas a trouver cette fonction pour word.

Cordialement! Un grand merci déjà

Macro imprimer les pièces jointes séléctionnées

VBA Outlook

Discussions similaires

Partager

Partager