Probleme insertion signature courriel vba ==> Outlook
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:
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. :D
