Discussion :

[bladinium]

Bonjour,

Je n'ai pas réussi avec les couleurs du coup j'ai modifier le truc sur l'imprimante, par contre j'essais de mettre la mise en page en paysage mais je n'y arrive pas... L'imprimante est configurer en paysage mais ça ne fonctionne pas

Et dans le script j'ai tenté également avec :
.Orientation = wdOrientLandscape

Mais ça ne fonctionne pas non plus !

[bladinium]

Bonjour,

Avec la référence word activé ça va mieux...

Le hic que je n'arrive pas a résoudre, c'est au niveau de la marge du bas qui est de 7Cm...

Voici 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
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
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), 5) = ".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:=""
 
                AppWord.DisplayAlerts = -1    'wdAlertsAll
                AppWord.ScreenUpdating = True
 
                'mise en page
                With AppWord.ActiveDocument.PageSetup
                    .LineNumbering.Active = False
                    .Orientation = wdOrientLandscape
                    .TopMargin = AppWord.CentimetersToPoints(0.1)
                    .BottomMargin = 36
                    .LeftMargin = AppWord.CentimetersToPoints(0.1)
                    .RightMargin = AppWord.CentimetersToPoints(0.1)
                    .Gutter = 0
                    .HeaderDistance = AppWord.CentimetersToPoints(0.1)
                    .FooterDistance = AppWord.CentimetersToPoints(0.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:=1, _
                PrintZoomRow:=1, _
                PrintZoomPaperWidth:=0.75 * (8.5 * 1440), _ 'Réduire la taille pour le tableau
                PrintZoomPaperHeight:=0.75 * (11 * 1440), _
                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

Je vous remercie d'avance

[carden752]

Bonjour,

Il s'agit de cette ligne pour fixer la marge du bas dans With pagesetup

Code :

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

.BottomMargin = CentimetersToPoints(nombre de centimètres souhaités)