Bonjour à tous,

Je me permets de venir vers vous car j'ai un problème que je ne parviens pas à résoudre. Mon collègue et moi même avons retravaillé une macro (bien aidé par la communauté developpez d'ailleurs) pour faire du publipostage.

La macro fonctionne bien de l'ensemble des postes sauf du mien. En effet...je ne parviens pas à insérer la signature dans la fin du courriel. J'ai été voir la gestion de la sécurité et des macros dans Outlook mais aucun problème à ce niveau la.

Existe-t-il une option qui pourrait "bloquer" cette action sur mon poste ? J'avoue n'avoir aucune idée sur la raison pr laquelle ça ne marche pas...

Voici le code rédigé :

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
Sub EnvoiMail()
'Dim appOutlook As Outlook.Application, message As Outlook.MailItem
'Dim email As String, MaPJ As Attachments
Dim Ficjoint As String
Dim adresse, envoi As Workbook
 
Set adresse = Application.Workbooks.Open(ThisWorkbook.Worksheets(1).TextBox4.Text)
REP = ThisWorkbook.Worksheets(1).TextBox6.Text
adresse.Activate
derligne = Range("A65535").End(xlUp).Row
For i = 2 To derligne
If Range("A" & i).Value <> vide Then
 
 
'sujet du mail
    suj = Range("E" & i).Value
'destinataire et fichier excel
    ' Ensemble des PJ
 
    fica = Range("F" & i).Value
    ficb = Range("G" & i).Value
    ficc = Range("H" & i).Value
    ficd = Range("I" & i).Value
    fice = Range("J" & i).Value
    Ficjoint = REP & "\" & Range("F" & i).Value
    Ficjointb = REP & "\" & Range("G" & i).Value
    Ficjointc = REP & "\" & Range("H" & i).Value
    Ficjointd = REP & "\" & Range("I" & i).Value
    Ficjointe = REP & "\" & Range("J" & i).Value
 
   dest = Range("C" & i).Value
   desta = Range("D" & i).Value
 
   'Envoi des mails
 
    Set appOutlook = CreateObject("outlook.application")
    Set Message = appOutlook.CreateItem(olMailItem)
    email = dest
    emaila = desta
 
    Set MaPJ = Message.Attachments
    If fica <> "" Then MaPJ.Add Ficjoint
    If ficb <> "" Then MaPJ.Add Ficjointb
    If ficc <> "" Then MaPJ.Add Ficjointc
    If ficd <> "" Then MaPJ.Add Ficjointd
    If fice <> "" Then MaPJ.Add Ficjointe
 
    ' Ecriture du corps du mail dans HTML BODY
    Debug.Print HtmlRCh(ThisWorkbook.Worksheets(1).TextBox5.Text)
 
 
 
    corps = "<HTML><body><b>" & Cells(i, 1) & " " & Cells(i, 2) & " ,<br><b></body><HTML>" & "<br>" '& ThisWorkbook.Worksheets(1).TextBox5.Text _
        & "<br><br>" & "<span style=""font-weight : Bold;"">"
 
    With Message
        .Subject = suj
        .BodyFormat = olFormatHTML
        .HTMLBody = ""
        .Display
        .BodyFormat = 2
        .GetInspector.CommandBars.Item("Insert").Controls("Signature").Controls(1).Execute
        .HTMLBody = corps & HtmlRCh(ThisWorkbook.Worksheets(1).TextBox5.Text) & .HTMLBody
        .Display
        .Recipients.Add (email)
        .CC = emaila
        .Send
    End With
    SendKeys "%{s}", True 'ne pas demander de confirmation d'envoi
 
 
 
End If
Next i
End Sub
Function HtmlRCh(t As String) As String
 
Dim v, i As Long
v = Split(t & Chr(10), Chr(10))
For i = 0 To UBound(v) - 1
    HtmlRCh = HtmlRCh & "<p>" & v(i) & "</p>"
Next
End Function
D'avance je vous remercie de votre aide.