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 |
Partager