Discussion :

[maxtormaxtor]

Bonjour,
J'ai besoin de pouvoir inserer, à l'impression, une entête de page avec les premiers caracteres de l'entête du message.

J'ai adapté un code qui permet d'imprimer un message avec ses pièces jointes. J'essaye en vain d'ajouter des bouts de code mais rien ne probant.
je me rends compte qu'il faut que je passe par word mais je suis completement perdu.
Merci pour votre aide.

[Oliv-]

Bonjour,
C'est effectivement ce qu'il y a de plus efficace d'utiliser Word en Automation

Pour exporter au format Word

Code :

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

objCurrentMessage.SaveAs strName, OlSaveAsType.olDoc

Pour Traiter avec Word, soit tu ajoutes une "références" à ta version de Word soit tu déclares les constantes Word que tu utilises

Voici un exemple qui ajoute le nom et le nombre de pages

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
Sub Traitement_WORD(path_MSG)
'CONSTANTES WORD
    Const wdHeaderFooterPrimary = 1
    Const wdCollapseEnd = 0
    Const wdFieldPage = 33
    Const wdFieldNumPages = 26
 
    Dim WordApp As Object
    Set WordApp = CreateObject("Word.application")
    WordApp.Visible = True
 
    Dim WdDoc As Object    'Word.Document
    'OUVERTURE DU DOCUMENT
    Set WdDoc = WordApp.Documents.Open(path_MSG)
    DoEvents
 
 
    Dim pdp As Object
    With WordApp.activedocument.Sections(1)
        '
        .Footers(wdHeaderFooterPrimary).Range.InsertAfter Text:=WdDoc.Name & Space(1)
        DoEvents
        Set pdp = .Footers(wdHeaderFooterPrimary).Range
        pdp.Collapse Direction:=wdCollapseEnd
        pdp.Fields.Add Range:=pdp, Type:=wdFieldPage
        .Footers(wdHeaderFooterPrimary).Range.InsertAfter Text:="/"
        Set pdp = .Footers(wdHeaderFooterPrimary).Range
        pdp.Collapse Direction:=wdCollapseEnd
 
        pdp.Fields.Add pdp, wdFieldNumPages
    End With
 
    'impression:
    WdDoc.PrintOut
 
    'quitter
    WdDoc.Close False
    WordApp.Quit
End Sub

[maxtormaxtor]

Bonjour,
merci pour cette réponse rapide.
Mon faible niveau me permet généralement d'adapter un code qui marche déjà; là je galere...
Mais je cherche.

[maxtormaxtor]

Bonjour,
Après "quelques heures" de bidouillage; j'arrive à un bout de procédure qui fonctionne.
Il est évident que ca doit forcément pouvoir mieux s'écrire lol

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
Dim objMail As Outlook.MailItem
    Dim strFileName As String
    Dim strWordDocument As String
    Dim objWordApp As Word.Application
    Dim objWordDocument As Word.Document
    Dim objDocumentRange As Word.Range
 
     On Error Resume Next
    'Export the email as Word document
    '
    Set objMail = Outlook.Application.ActiveExplorer.Selection(1)
    'remplace les caracteres non autorisés pour le nom d'un fichier
    strFileName = Replace(objMail.Subject, "/", " ")
    strFileName = Replace(strFileName, "\", " ")
    strFileName = Replace(strFileName, ":", "")
    strFileName = Replace(strFileName, "?", " ")
    strFileName = Replace(strFileName, Chr(34), " ")
    'définit le nom du fichier
    strWordDocument = Environ("Temp") & "\" & strFileName & ".doc"
 
    ' Oldoc spécifie le format de fichier -  Microsoft Office Word format (.doc)
    objMail.SaveAs strWordDocument, olDoc
 
    Set objWordApp = CreateObject("Word.Application")
    Set objWordDocument = objWordApp.Documents.Open(strWordDocument)
 
    objWordApp.ScreenUpdating = False
 
 
   With objWordDocument.Sections(1).Headers(wdHeaderFooterPrimary)
                'la ligne ci-dessous ajoute un numéro de page centré à droite
                '.PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight
 
        .Range.Text = Left(objMail.Subject, 6)
        '.Range.Bold = True
        .Range.Font.Name = "Calibri"
        .Range.Font.Size = "40"
        .Range.ParagraphFormat.Alignment = wdAlignParagraphRight
 
    End With
 
     objWordApp.Visible = True
     objWordApp.ScreenUpdating = True
 
     objWordApp.PrintOut
 
 
    '//// * ****************        début du bout de programme qui cherche le mot fournisseur et le remplace par TOTO
 
    'Clearformatting supprime les attributs de mise en forme des critères de recherche
    objWordApp.Selection.Find.ClearFormatting
    'Replacement.ClearFormatting supprime les attributs de mise en forme des critères de recherche et remplacer
    objWordApp.Selection.Find.Replacement.ClearFormatting
 
    '
    With objWordApp.Selection.Find
        .Text = "Fournisseur"
        .Replacement.Text = "TOTO"
        'WRAP Cette propriété renvoie ou définit ce qui se passe si la recherche commence à un point autre que le début du document et que la fin du document est atteinte (ou inversement, si Forward a la valeur false) ou si le texte recherché est introuvable dans la sélection ou la plage spécifiée. En lecture/écriture WdFindWrap.
        .Wrap = wdFindContinue
    End With
    ' valide le remplacement de TOTO par fournisseur
    objWordApp.Selection.Find.Execute Replace:=wdReplaceAll
 
    'MsgBox "ok"
    Set objDocumentRange = objWordDocument.Range()
 
    objDocumentRange.Font.Name = "Calibri"
    objDocumentRange.Font.Size = 10
 
    '//// * ****************        fin du bout de programme qui cherche le mot fournisseur et le remplace par TOTO
 
 
    objWordDocument.Close True
    objWordApp.Quit
    Kill strWordDocument