VBA Insérer pièce jointe à un mail outlook en cour - avec condition dans objet

**miathan22** · 04/03/2016, 21h52

Bonjour à tous, je suis débutante et je voulais faire affaire avec des pros donc je vais essayer de vous expliquer au mieux,

Les amis voici ce que je veux réaliser :

Quand j'écris un courriel auquel est déjà joint une soumission format pdf, si j'inscris le mot SOUMISSION dans objet, je voudrais insérer la pièce jointe DOC automatiquement avant d'envoyer mon courriel par la même occasion je voudrais envoyer une copie conforme à INFO@AAA.COM

J'ai trouvé ceci mais je n'arrive pas à le modifier correctement.

LE PROBLÈME c'est qu'un nouveau mail est créé, par contre le document se joint sans problème mais je veux rester dans mon courriel que je suis en train d'écrire. Par la même occasion je veux insérer les conditions.

Dans projet 1 - modules - module1

J'ai incrit :

Sub joindredoc()
'
'envoie un mail avec doc en pièce jointe
'
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myItem = Application.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments.Add Source:="C:\Users\Comptabilité\Documents\joindredoc.pdf"
myItem.Display

End Sub

J'espère recevoir une solution sous peu c'est tannant de répéter la même action à chaque courriel envoyé.

Merci à l'avance pour votre coup de main.

**Oliv-** · 07/03/2016, 17h54

Bonjour,
Si tu veux que l'ajout se déclenche automatiquement par la modification du sujet, il faut utiliser un Module de classe.

A METTRE dans THISOUTLOOKSESSION

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
 
 
 
Private m_MyEmails As VBA.Collection
Private m_lNextKeyEmails As Long
 
 
Private Sub Application_ItemLoad(ByVal item As Object)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemLoad
' Author    : Oliv
' Date      : 07/03/2016
' Purpose   : EMAIL WRAPPER / Receive Events of Multiple Emails
' BASED ON : http://www.vboffice.net/en/developers/inspector-wrapper-receive-events-of-multiple-emails/
'---------------------------------------------------------------------------------------
'
 
    Dim oMail As cMail
    If m_MyEmails Is Nothing Then Set m_MyEmails = New VBA.Collection
    Set oMail = New cMail
    If item.Class = olMail Then
        If oMail.Init(item, CStr(m_lNextKeyEmails)) Then
            m_MyEmails.Add oMail, CStr(m_lNextKeyEmails)
            m_lNextKeyEmails = m_lNextKeyEmails + 1
        End If
    End If
 
End Sub
 
Friend Property Get MyEmails() As VBA.Collection
    Set MyEmails = m_MyEmails
End Property

AJOUTER UN MODULE DE CLASSE et le nommer "cMail"

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
 
'---------------------------------------------------------------------------------------
' Module    : cMail
' Author    : Oliv
' Date      : 07/03/2016 17:49
' Purpose   : EMAIL WRAPPER / Receive Events of Multiple Emails
'---------------------------------------------------------------------------------------
 
 
Private WithEvents m_Mail As Outlook.MailItem
Private m_IsClosed As Boolean
Private m_sKey As String
 
Friend Function Init(oEmail As Outlook.MailItem, sKey As String) As Boolean
    Dim obj As Object
 
    If Not oEmail Is Nothing Then
 
        Set m_Mail = oEmail
        m_sKey = sKey
        Init = True
    End If
 
End Function
 
 
 
Private Sub Class_Terminate()
    CloseEmail
End Sub
 
Friend Sub CloseEmail()
    On Error Resume Next
    If m_IsClosed = False Then
        m_IsClosed = True
        ThisOutlookSession.MyEmails.Remove m_sKey
        Set m_Mail = Nothing
    End If
End Sub
 
 
 
Private Sub m_Mail_Close(Cancel As Boolean)
    CloseEmail
End Sub
 
Private Sub m_Mail_PropertyChange(ByVal Name As String)
'---------------------------------------------------------------------------------------
' Procedure : m_Mail_PropertyChange
' Author    : Oliv
' Date      : 07/03/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim pj
    Dim MyRecipientCC As Recipient, CC
    pj = "C:\Users\Comptabilité\Documents\joindredoc.pdf"
    'pj = "C:\temp\monpdf.pdf"
    CC = "INFO@AAA.COM"
 
    If Name = "Subject" Then
'ICI on test le sujet et on fait les ACTIONS
        If InStr(1, m_Mail.Subject, "SOUMISSION", vbTextCompare) Then    'non sensible à la casse
            'if instr(0, m_Mail.Subject,"SOUMISSION",vbBinaryCompare) then 'sensible à la casse
            If Dir(pj) <> "" Then
                m_Mail.Attachments.Add pj
            End If
 
            Set MyRecipientCC = m_Mail.Recipients.Add(CC)
            MyRecipientCC.Type = olCC
            MyRecipientCC.Resolve
        End If
    End If
End Sub

**miathan22** · 07/03/2016, 22h04

Bonjour Oliv,

Premièrement je veux vraiment te remercier de tout ce que tu as fait pour l'instant. Je vois que c'est beaucoup plus compliqué que je le pensais.

Premièrement j'ai copié le premier code dans Thisoutlooksssion et le deuxième au complet dans un module classe et j'ai réussi à changer le nom pour cMail.

Alors j'ai fait un test j'ai envoyé un mail et j'ai écrit soumission dans objet.

Avant de l'envoyer, je ne vois aucune copie conforme qui c'est inscrite et il n'y aucun fichier joint.

Quand c'est envoyé, dans ma boite d'envoi je vois aucune copie conforme et aucun fichier joint.

J'attend votre réponse

**Oliv-** · 08/03/2016, 09h46

Bonjour,
En principe, si ça marche c'est quand tu indiques SOUMISSION dans le sujet et que tu cliques dans le corps ou enter ou tab, que cela fait le job !
Il faut bien sûr que la PJ existe à l'emplacement indiqué !

**miathan22** · 08/03/2016, 14h59

Bonjour Oliv je veux vraiment te remercier pour ta patience.

Tout d'abord quand je crée un nouveau message dans Outlook et que j'inscris soumission dans l'objet la copie conforme ainsi que le fichier se joint et quand je l'envoie et que je regarde mon document envoyer je vois qu'il y a 2 copies conformes et 2 fichiers joints.

Par contre la problématique n'est pas là c'est :

Quand je fais ma soumission dans word je pèse sur ENVOYER, ENVOYER comme pièce jointe au format pdf alors ça ouvre un message Outlook avec mon fichier pdf joint et le nom de la soumission dans objet alors je tape le destinataire, la copie conforme ensuite je tape SOUMISSION dans l'objet à côté du nom et je tape le message et je joint mon fichier JOINDREDOC.pdf et j'envoie.

Quand je fais la même chose avec ton code il n'y a pas de copie conforme qui s'insère n'y pièce jointe qui se joint.

Je ne sais plus quoi faire.

**Oliv-** · 08/03/2016, 17h51

Effectivement dans ce cas là ça ne marche pas.

Tu as 3 solutions.

Créer un addin (une dll) mais c'est encore plus compliqué

Faire de l'automation de OUTLOOK à partir de WORD

à mettre dans un module de normal.dot par exemple

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 EnvoiDocParEmail()
 
    Set FichierDoc = Application.ActiveDocument
    If FichierDoc.Saved = True Then
        fichier = FichierDoc.FullName
        FichierDoc.Close
        Destinataire = InputBox("Destinataires (séparés par des ;)", _
                                "Envoi par Mail ")
        Sujet = InputBox("Objet du mail ?", "Envoi par Mail", _
                         "Test EMAIL SOUMISSION" & Application.Name)
 
        CorpsBrut = InputBox("Corps du message ?", "Envoi par Mail", _
                             "Lire le fichier joint")
 
        Call SendMailOUTLOOK(Destinataire, Sujet, CorpsBrut, fichier)
 
        Documents.Open fichier
        MsgBox "Mail envoyé"
    Else
 
        MsgBox "Vous devez enregistrer votre fichier avant de pouvoir l'envoyer" _
             , , "Erreur"
 
    End If
End Sub
 
 
Sub SendMailOUTLOOK(Destinataire, Sujet, CorpsBrut, fichier)
    Dim olApp
    Dim oMail
    Set olApp = CreateObject("outlook.application")
    Set oMail = olApp.createitem(0)
    oMail.Subject = Sujet
    oMail.body = CorpsBrut
    oMail.to = Destinataire
    oMail.attachments.Add fichier
    oMail.Display
 
End Sub

Enregistrer en brouillon ton Email créé par "envoyer en tant que pièce jointe", le fermer, le réouvrir à partir des BROUILLONS de Outlook et l'envoyer

Dans les 2 derniers cas tu peux utiliser l'événement Application_ItemSend

J'ai corrigé le code pour éviter les dooublons de pj et CC

A METTRE dans THISOUTLOOKSESSION

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
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OCTU
' Date      : 08/03/2016
' Purpose   : Envoi d'une PJ et destinataire CC Selon le sujet
'---------------------------------------------------------------------------------------
'
 
    Dim pj
    Dim MyRecipientCC As Recipient, CC
    Dim att As Attachment, rec As Recipient
    Dim tFileName
    Dim PjExiste As Boolean
    Dim CCExiste As Boolean
    Dim m_Mail As Outlook.MailItem
    Dim Confirmation
 
    pj = "C:\Users\Comptabilité\Documents\joindredoc.pdf"
    'pj = "C:\temp\monpdf.pdf"
    CC = "titi@toto.com"
 
    If Item.Class = olMail Then
        Set m_Mail = Item
        'ICI on test le sujet et on fait les ACTIONS
        If InStr(1, m_Mail.Subject, "SOUMISSION", vbTextCompare) Then    'non sensible à la casse
            'if instr(0, m_Mail.Subject,"SOUMISSION",vbBinaryCompare) then 'sensible à la casse
            If Dir(pj) <> "" Then
                PjExiste = False
                tFileName = Split(pj, "\", , vbBinaryCompare)
                For Each att In m_Mail.Attachments
                    If UCase(att.FileName) = UCase(tFileName(UBound(tFileName))) Then
                        PjExiste = True
                        Exit For
                    End If
                Next
                If Not PjExiste Then m_Mail.Attachments.Add pj
            End If
 
            CCExiste = False
            For Each rec In m_Mail.Recipients
                If LCase(GetSMTPAddressForRecipient(rec)) = LCase(CC) Then
                    CCExiste = True
                    Exit For
                End If
            Next
 
                If Not CCExiste Then
                    Set MyRecipientCC = m_Mail.Recipients.Add(CC)
                    MyRecipientCC.Type = olCC
                    MyRecipientCC.Resolve
                End If
 
                Confirmation = MsgBox("Etes-vous sûrs ?", vbQuestion + vbYesNo, "Envoi avec SOUMISSION")
                If Confirmation = vbNo Then Cancel = True
            End If
        End If
    End Sub

**miathan22** · 08/03/2016, 19h43

Bonjour Oliv,

le code que je dois copier dans Outlooksession m'inscrit erreur de compilation sub- ou function non défiie à (GetSMTPAddressForRecipient(rec)) et Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean devient en jaune.

je pars déjà d'un fichier excel pour faire ma soumission alors peut-être que les problèmes viennent de là :

Sub Ouvrir_Word_Onglet_Soumission()
Dim monWord As Word.Application
Dim WordDoc As Word.Document
Set monWord = New Word.Application
monWord.Visible = True
Set WordDoc = monWord.Documents.Open("C:\Users\Comptabilité\Desktop" & "\" & "Modèle Fax Soumission.docx")
WordDoc.MailMerge.OpenDataSource Name:="C:\Users\Comptabilité\Documents\Mes Sources de données\Liste de nom pour Fax soumission.mdb"

Dim Chemin
Chemin = "C:\Users\Comptabilité\Documents\Soumission\2016\2016-03 MARS\"

Dim MonFichier
MonFichier = Chemin & Range("C6").Value & " - " & Range("D6").Value & ".docx"

WordDoc.SaveAs Filename:=MonFichier, FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False

WordDoc.Bookmarks("Texte7").Select
var_soumnum = Cells(6, 1) '6e ligne 1e colonne
monWord.Selection.TypeText var_soumnum

WordDoc.Bookmarks("Texte3").Select
var_projet = Cells(6, 3) '2e ligne 3e colonne
monWord.Selection.TypeText var_projet & var_type

'monWord.PrintOut
End Sub

Par contre même les nouveaux messages dans Outlook ne fonctionne plus.

J'aimerais mieux ne pas avoir à sortir du document quand je suis dans mon message Outlook parce que souvent j'en ai une dizaine de soumission différente à envoyé, ça pourrait m'apporter des erreurs.

Merci

**Oliv-** · 08/03/2016, 20h35

il manque la fonction

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
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author    : Oliv-
' Date      : 21/01/2015
' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
    GetSMTPAddressForRecipient = ""
    On Error GoTo fin
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.PropertyAccessor
    'Debug.Print recip.Name & " SMTP=" _
     & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
fin:
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function

**miathan22** · 08/03/2016, 20h55

Salut oliv,

Je ne sais plus où mettre ce code

**Oliv-** · 08/03/2016, 21h34

DANS UN MODULE ce sera bien

**miathan22** · 08/03/2016, 22h52

WOW ÇA MARCHE,

youpiiii, je ne sais comment te remercier Oliv, tu es fantastique.

Demain sera agréable d'envoyer des soumissions.

Je suis trop contente merci mille fois.

Si tu trouves un moyen de le faire direct au lieu d'enregistrer les courriels et de retourner le chercher inscrit moi ta méthode.

**Oliv-** · 09/03/2016, 12h22

Bonjour,
La solution est dans l'automation de OUTLOOK (dans ce cas à partir de EXCEL)

ajoute à la fin de ta macro ouvrir_word_onglet_soumission

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
  Dim Destinataire, Sujet, CorpsBrut, fichier
        WordDoc.Save
        fichier = WordDoc.FullName
        'on ferme le fichier
        WordDoc.Close
        Destinataire = InputBox("Destinataires (séparés par des ;)", _
                                "Envoi par Mail ")
        Sujet = InputBox("Objet du mail ?", "Envoi par Mail", _
                         "SOUMISSION" & Application.Name)
 
        CorpsBrut = InputBox("Corps du message ?", "Envoi par Mail", _
                             "Lire le fichier joint")
 
        Call SendMailOUTLOOK(Destinataire, Sujet, CorpsBrut, fichier)
        'on réouvre le fichier
        monWord.Documents.Open fichier

et dans un module de EXCEL

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Sub SendMailOUTLOOK(Destinataire, Sujet, CorpsBrut, fichier)
    Dim olApp
    Dim oMail
    Set olApp = CreateObject("outlook.application")
    Set oMail = olApp.createitem(0)
    oMail.Subject = Sujet
    oMail.body = CorpsBrut
    oMail.to = Destinataire
    oMail.attachments.Add fichier
    oMail.Display
 
End Sub

Tu peux bien sûr préparer le corps de ton Email soit en brut ( oMail.body) ou en HTML (oMail.HTMLbody) dans ce cas avec des balise HTML.

**miathan22** · 09/03/2016, 16h36

Salut Oliv,

Quand j'insère le code dans à la fin de la macro ouvrir_word_onglet_soumission ça m'inscrit seul des commentaires peuvent apparaitre après en sub.

Et Est-ce que je vais pouvoir quand même choisir un nom à la fois dans mon word avec mon publibostage.

Merci à l'avance

**Oliv-** · 09/03/2016, 17h19

à la fin juste avant "end sub"

**miathan22** · 09/03/2016, 20h56

Salut Oliv,

Le code comme ça je ne peux pas parce que je dois transférer les infos de ma liste excel en ouvrant le document word et je dois choisir à qui je l'envoie dans mon publipostage et modifier mon modèle de soumission avant de l'imprimer pour chacun (l'enregistrer pour sortir une autre copie si besoin, à une autre personne pour la même soumission) et j'envoie par la suite un courriel à chacun de ceux que j'ai sélectionné dans mon publipostage en cliquant sur envoyer comme pièce jointe pdf sur chacun d'eux mais là je dois l'enregistrer avant de l'envoyer. Ça fonctionne quand même super bien par contre si je pourrais sauver cette étape et l'envoyer directement comme avant ça serait pas pire, c'est juste que maintenant je dois joindre un autre document à toute mes soumission mais au moins c'est le même document pour tous et envoyer ma copie conforme pour toute les soumissions.

Mes adresses courriels sont toutes enregistrées dans mon Outlook selon le nom que je suis pas certaine pour tous puisque j'ai des noms identiques pour différence compagnie et s'il n'y apparait pas y faut que je l'ajoute dans mon Outlook.

Merci d'avance

**Oliv-** · 10/03/2016, 09h54

Bonjour,
J'ai pas tout compris ce que tu devais faire, mais dans ce cas il faut créer dans WORD UN BOUT DE CODE comme au paragraphe #6 qui va envoyer ton fichier Word par Email

**miathan22** · 10/03/2016, 14h04

Bonjour Oliv,

Ce que je veux c'est à partir de la partie ou j'ai fini mon publipostage dans word et que ma soumission est prête à envoyer quand je pèse sur dans word sur ENVOYER, Envoyer comme pièce jointe pdf c'est là que je voudrais ajouter mon FICHIERDOC quand j'écris SOUMISSION. Je ne sais pas si je suis toujours dans word ou Outlook mais je voudrais sauter l'étape ou tu me fais enregistrer le brouillon pour le reprendre dans Outlook et l'envoyer, pour le moment c'est là qu'il ajoute mon fichier.

Tu m'avais parlé d'un dll je crois, Est-ce qu'on pourrait.

Merci beaucoup.

**miathan22** · 10/03/2016, 14h16

Salut Oliv,

À moyen que je puisse déclancher (joindre la pièce jointe FICHIERDOC et la copie conforme à mon autre pièce jointe soumission) en pèsant sur ENVOYER, envoyer comme pièce jointe pdf. Si ma deuxième pièce jointe pourrait se joindre à ce moment au lieu de quand j'écris SOUMISSION dans mon objet.

Merci

**Oliv-** · 10/03/2016, 16h29

C'est le cas si tu utilises ma macro Application_ItemSend soit avec l'option enregistrer en brouillon , soit avec la macro dans word EnvoiDocParEmail

**miathan22** · 10/03/2016, 19h36

Bonjour Oliv,

Je crois que je dois mal m'exprimer.

Quand j'ai fini ma soumission dans word je veux l'envoyer par courriel en format pdf AVEC MON AUTRE FICHIER pdf joint automatique ainsi que l'ajout de ma copie conforme.

Le problème c'est quand je fini ma soumission et que je pèse sur ENVOYER, Envoyer comme pièce jointe pdf. ma soumission est bien jointe mais c'est là que je voudrais ajouter mon FICHIERDOC et ma copie conforme avant de peser sur envoyer.

Je ne sais pas si je suis toujours dans word ou Outlook mais je voudrais sauter l'étape ou tu me fais enregistrer mon courriel dans Outlook, pour le reprendre dans Outlook et l'envoyer, pour le moment c'est là qu'il ajoute mon fichier.

Merci voici les codes que j'ai pour le moment dans Outlook j'ai mis dans ThisOutlookSession :

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author : OCTU
' Date : 08/03/2016
' Purpose : Envoi d'une PJ et destinataire CC Selon le sujet
'---------------------------------------------------------------------------------------
'

Dim pj
Dim MyRecipientCC As Recipient, CC
Dim att As Attachment, rec As Recipient
Dim tFileName
Dim PjExiste As Boolean
Dim CCExiste As Boolean
Dim m_Mail As Outlook.mailItem
Dim Confirmation

pj = "C:\Users\Comptabilité\Documents\Originaux\fichierdoc.pdf"
'pj = "C:\temp\monpdf.pdf"
CC = "info@aaa.ca

If Item.Class = olMail Then
Set m_Mail = Item
'ICI on test le sujet et on fait les ACTIONS
If InStr(1, m_Mail.Subject, "SOUMISSION", vbTextCompare) Then 'non sensible à la casse
'if instr(0, m_Mail.Subject,"SOUMISSION",vbBinaryCompare) then 'sensible à la casse
If Dir(pj) <> "" Then
PjExiste = False
tFileName = Split(pj, "\", , vbBinaryCompare)
For Each att In m_Mail.Attachments
If UCase(att.FileName) = UCase(tFileName(UBound(tFileName))) Then
PjExiste = True
Exit For
End If
Next
If Not PjExiste Then m_Mail.Attachments.Add pj
End If

CCExiste = False
For Each rec In m_Mail.Recipients
If LCase(GetSMTPAddressForRecipient(rec)) = LCase(CC) Then
CCExiste = True
Exit For
End If
Next

If Not CCExiste Then
Set MyRecipientCC = m_Mail.Recipients.Add(CC)
MyRecipientCC.Type = olCC
MyRecipientCC.Resolve
End If

Confirmation = MsgBox("Etes-vous sûrs ?", vbQuestion + vbYesNo, "Envoi avec SOUMISSION")
If Confirmation = vbNo Then Cancel = True
End If
End If
End Sub

TOUJOURS DANS OUTLOOK MAIS DANS MODULE1 :

Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author : Oliv-
' Date : 21/01/2015
' Purpose : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
GetSMTPAddressForRecipient = ""
On Error GoTo fin
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set pa = recip.PropertyAccessor
'Debug.Print recip.Name & " SMTP=" _
& pa.GetProperty(PR_SMTP_ADDRESS)
GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
fin:
If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function

ENSUITE DANS WORD DANS NORMAL - MICROSOFT WORD OBJET - THISDOCUMENT

Sub EnvoiDocParEmail()

Set FichierDoc = Application.ActiveDocument
If FichierDoc.Saved = True Then
fichier = FichierDoc.FullName
FichierDoc.Close
Destinataire = InputBox("Destinataires (séparés par des

", _
"Envoi par Mail ")
Sujet = InputBox("Objet du mail ?", "Envoi par Mail", _
"Test EMAIL SOUMISSION" & Application.Name)

CorpsBrut = InputBox("Corps du message ?", "Envoi par Mail", _
"Lire le fichier joint")

Call SendMailOUTLOOK(Destinataire, Sujet, CorpsBrut, fichier)

Documents.Open fichier
MsgBox "Mail envoyé"
Else

MsgBox "Vous devez enregistrer votre fichier avant de pouvoir l'envoyer" _
, , "Erreur"

End If
End Sub

Sub SendMailOUTLOOK(Destinataire, Sujet, CorpsBrut, fichier)
Dim olApp
Dim oMail
Set olApp = CreateObject("outlook.application")
Set oMail = olApp.createitem(0)
oMail.Subject = Sujet
oMail.body = CorpsBrut
oMail.To = Destinataire
oMail.attachments.Add fichier
oMail.Display

End Sub

MERCI DE ME REDIRIGER

VBA Insérer pièce jointe à un mail outlook en cour - avec condition dans objet

VBA Outlook

Discussions similaires

Partager

Partager