[OL2021] REGLE et script transfert de mail

Version imprimable

1 pièce(s) jointe(s)

Bonjour la communauté

J'utilise tous les jours ce code, via un raccourci dans la barre d'outils, qui m'est fort pratique et je remercie encore la communauté pour l'aide apportée en son temps (vers 2017 à peu près):
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub SendUsingAccount() Set oOlSel = ActiveExplorer.Selection Dim oAccount As Outlook.account Set oAccount = Application.Session.accounts("christophe@be-ingetech.fr") If oAccount Is Nothing Then MsgBox "Compte non trouvé": Exit Sub For Each oOlItm In oOlSel If oOlItm.Class = olMail Then Set oOlFwd = oOlItm.Forward oOlFwd.Attachments.Add oOlItm, olEmbeddeditem oOlFwd.To = "maison@be-ingetech.fr" oOlFwd.SendUsingAccount oAccount oOlFwd.Recipients.ResolveAll ' oOlFwd.Display ' pour afficher oOlFwd.Send End If Next oOlItm End Sub
Je souhaite me servir de ce code avec l'utilisation de règles OUTLOOK (pour automatiser un peu en fonction de certains mots dans l'objet).

J'ai donc inséré ce code VBA dans le script TEST suivant:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub TEST(Mail As Outlook.MailItem) Set oOlSel = ActiveExplorer.Selection Dim oAccount As Outlook.account Set oAccount = Application.Session.accounts("christophe@be-ingetech.fr") If oAccount Is Nothing Then MsgBox "Compte non trouvé": Exit Sub For Each oOlItm In oOlSel If oOlItm.Class = olMail Then Set oOlFwd = oOlItm.Forward oOlFwd.Attachments.Add oOlItm, olEmbeddeditem oOlFwd.To = "maison@be-ingetech.fr" oOlFwd.SendUsingAccount oAccount oOlFwd.Recipients.ResolveAll ' oOlFwd.Display ' pour afficher oOlFwd.Send End If Next oOlItm End Sub
J'appelle donc ce script TEST lors du paramétrage de mes règles mais il fait n'importe quoi (genre il me transfère le mail précédent déjà lu ou bien ne me tranfère rien du tout)

Pièce jointe 637910

J'ai essayé plein de choses pour résoudre mon problème mais rien n'y fait:
- créer un nouveau profil dans OUTLOOK dans lequel je n'ai mis que mes comptes pop (pas d'imap ou de comptes gmail etc..)
- réparer mon fichier de données outlook
- tester un autre code en enlevant la condition objet pour l'appliquer à tous les messages entrants du compte en question:
Code:

1 2 3 4 Sub Arrive_NewMail(Mail As Outlook.MailItem) MsgBox "Arrivée du message :" & vbCr & Mail.Subject & vbCr & " de:" & Mail.SenderName End Sub
Et là ça fonctionne parfaitement avec ce script (qui m'affiche une fenêtre lors de la réception d'un message)

J'en déduis que c'est l'adaptation du code en script qui lui plait pas!

Qu en pensez vous?

07/03/2024, 14h10
toftrem

Bonjour à tous
Je déterre ce post car je n'ai pas eu de réponses et je n'arrive toujours pas a comprendre ce qui ne va pas...

une ame charitable peut elle m'aider svp?

Merci

Je résume vite fait mon post précedent:
j'ai une vba qui me donne entière satisfaction : SendUsingAccount()

Je souhaite automatiser son utilisation avec les règles outlook (en fonction de mots spécifiques dans l'objet)

Donc à la réception d'un mail --> si le mot est dans l'objet -->transfert du message (+copie du message en PJ) au destinataire défini dans la macro et en utilisant un compte précis dans mes nombreux comptes...

Merci pour votre précieuse aide!

Christophe

Bonjour à tous
je déterre ce sujet car en bidouillant j'ai trouvé une solution et celle ci peut servir à d'autres.....:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Sub SendUsingAccountF(oOlItm As Outlook.MailItem) Set oOlSel = ActiveExplorer.Selection Dim oAccount As Outlook.Account Set oAccount = Application.Session.Accounts("christophe@be-ingetech.fr") If oAccount Is Nothing Then MsgBox "Compte non trouvé": Exit Sub ' For Each oOlItm In oOlSel ' If oOlItm.Class = olMail Then Set oOlFwd = oOlItm.Forward oOlFwd.Attachments.Add oOlItm, olEmbeddeditem oOlFwd.To = "maison@be-ingetech.fr" oOlFwd.SendUsingAccount oAccount oOlFwd.Recipients.ResolveAll ' oOlFwd.Display ' pour afficher oOlFwd.Send ' End If ' Next oOlItm End Sub
J'ai donc bidouillé la ligne 1 et commenté les lignes 6-7-15 et 16.

Donc au final la solution fonctionne avec les règles OUTLOOK....: quand un message arrive sur ce compte avec des mots clefs dans l'objet le transfert se fait automatiquement :D

Par contre j'ai un souci sur la signature de ce message transféré: la signature par défaut du compte sélectionné Application.Session.Accounts("christophe@be-ingetech.fr") ne s'affiche pas: il me met toujours la signature du compte sur lequel le message est arrivé!

Est il possible de rajouter une ligne qui forcerait une signature vide par exemple? ou carrément sans signature?

Merci pour votre aide

24/04/2025, 10h28
toftrem

Bonjour
Help svp....

Je cherche juste à choisir une signature enregistrée dans mon OUTLOOK pour ma routine :?

Salut à tous (enfin à ceux qui se connectent encore à cette partie du forum...)

J'ai passé quelques heures pour enfin arriver à mes fins :)
J'ai réussi !

Bon ce code n'est pas parfait mais il fait le taf (j'en ai profité pour améliorer ma routine de base pour mes transferts internes...)

J'ai crée une signature vide que je déclare dans le code.
Voici le code final (avec les explications):

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 SendUsingAccount()
  Set oOlSel = ActiveExplorer.Selection
  Dim oAccount As Outlook.Account
 
  ' Choix du compte d'expedition:
  Set oAccount = Application.Session.Accounts("admin@be-ingetech.fr") 'choix du compte à utiliser
  If oAccount Is Nothing Then MsgBox "Compte non trouvé": Exit Sub
 
' Bloc Choix signature:
Dim SignaturePath As String
Dim Signature As String
Dim FSO As Object
Dim SignatureFile As Object
' Chemin vers le dossier des signatures
SignaturePath = Environ("appdata") & "\Microsoft\Signatures\"
' Vérifier si le dossier des signatures existe
If Dir(SignaturePath, vbDirectory) <> vbNullString Then
' Nom du fichier de la signature (remplacez "vide" par le nom de votre signature)
SignaturePath = SignaturePath & "vide.htm"
' Vérifier si le fichier de la signature existe
If Dir(SignaturePath) <> vbNullString Then
' Lire le contenu du fichier de la signature
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SignatureFile = FSO.OpenTextFile(SignaturePath, 1)
Signature = SignatureFile.ReadAll
SignatureFile.Close
Else
MsgBox "Le fichier de la signature n'a pas été trouvé.", vbExclamation
Exit Sub
End If
Else
MsgBox "Le dossier des signatures n'a pas été trouvé.", vbExclamation
Exit Sub
End If
' Fin Bloc Choix signature
 
' Bloc extraction données du mail selectionné:
Dim SelectedMail As MailItem
 Dim contenu As String
 Select Case TypeName(ActiveWindow)
    Case "Explorer"
        Set SelectedMail = ActiveExplorer.Selection.Item(1)
    Case "Inspector"
        Set SelectedMail = ActiveInspector.CurrentItem
End Select
With SelectedMail
Nom_Prenom = .SenderName
date_reception = CDate(Int(.ReceivedTime))
heure_reception = TimeValue(.ReceivedTime)
destinataires = .To
CC = .CC
objet = .Subject
' .HTMLBody pour conserver la mise en forme du message d'origine
contenu = .HTMLBody
End With
 
' Bloc transfert du mail avec incorporation des PJ et du mail lui même en PJ:
    For Each oOlItm In oOlSel
    If oOlItm.Class = olMail Then
      Set oOlFwd = oOlItm.Forward
      oOlFwd.Attachments.Add oOlItm, olEmbeddeditem
      ' Choix du  destinataire:
      oOlFwd.To = "admin@be-ingetech.fr" 'mail destinataire
      oOlFwd.SendUsingAccount oAccount
      oOlFwd.Recipients.ResolveAll
      oOlFwd.HTMLBody = "" & Signature _
                                      & " <span style= ""color:#ff0000""> Expéditeur: </span> " & Nom_Prenom _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Destinataires: </span> " & destinataires & "; " & CC _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Date réception: </span> " & date_reception _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Heure réception: </span> " & heure_reception _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Objet: </span> " & objet _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Message: </span> <br><br> " & contenu
      oOlFwd.Display
      oOlFwd.Send
    End If
   Next oOlItm
End Sub

et sa version adaptée pour intégrer le code à un script pour l'exécution automatique via les règles outlook:

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 SendUsingAccountP(oOlItm As Outlook.MailItem)
  Set oOlSel = ActiveExplorer.Selection
  Dim oAccount As Outlook.Account
 
  ' Choix du compte d'expedition:
  Set oAccount = Application.Session.Accounts("admin@be-ingetech.fr") 'choix du compte à utiliser
  If oAccount Is Nothing Then MsgBox "Compte non trouvé": Exit Sub
 
' Bloc Choix signature:
Dim SignaturePath As String
Dim Signature As String
Dim FSO As Object
Dim SignatureFile As Object
' Chemin vers le dossier des signatures
SignaturePath = Environ("appdata") & "\Microsoft\Signatures\"
' Vérifier si le dossier des signatures existe
If Dir(SignaturePath, vbDirectory) <> vbNullString Then
' Nom du fichier de la signature (remplacez "vide" par le nom de votre signature)
SignaturePath = SignaturePath & "vide.htm"
' Vérifier si le fichier de la signature existe
If Dir(SignaturePath) <> vbNullString Then
' Lire le contenu du fichier de la signature
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SignatureFile = FSO.OpenTextFile(SignaturePath, 1)
Signature = SignatureFile.ReadAll
SignatureFile.Close
Else
MsgBox "Le fichier de la signature n'a pas été trouvé.", vbExclamation
Exit Sub
End If
Else
MsgBox "Le dossier des signatures n'a pas été trouvé.", vbExclamation
Exit Sub
End If
' Fin Bloc Choix signature
 
' Bloc extraction données du mail selectionné:
Dim SelectedMail As MailItem
 Dim contenu As String
' Select Case TypeName(ActiveWindow)
'    Case "Explorer"
'        Set SelectedMail = ActiveExplorer.Selection.Item(1)
 '   Case "Inspector"
       Set SelectedMail = oOlItm
'End Select
With SelectedMail
Nom_Prenom = .SenderName
date_reception = CDate(Int(.ReceivedTime))
heure_reception = TimeValue(.ReceivedTime)
destinataires = .To
CC = .CC
objet = .Subject
' .HTMLBody pour conserver la mise en forme du message d'origine
contenu = .HTMLBody
End With
 
' Bloc transfert du mail avec incorporation des PJ et du mail lui même en PJ:
  '  For Each oOlItm In oOlSel
  '  If oOlItm.Class = olMail Then
      Set oOlFwd = oOlItm.Forward
      oOlFwd.Attachments.Add oOlItm, olEmbeddeditem
      ' Choix du  destinataire:
      oOlFwd.To = "admin@be-ingetech.fr" 'mail destinataire
      oOlFwd.SendUsingAccount oAccount
      oOlFwd.Recipients.ResolveAll
      oOlFwd.HTMLBody = "" & Signature _
                                      & " <span style= ""color:#ff0000""> Expéditeur: </span> " & Nom_Prenom _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Destinataires: </span> " & destinataires & "; " & CC _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Date réception: </span> " & date_reception _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Heure réception: </span> " & heure_reception _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Objet: </span> " & objet _
                                      & "<br><br> " _
                                      & " <span style= ""color:#ff0000""> Message: </span> <br><br> " & contenu
      oOlFwd.Display
      oOlFwd.Send
 '   End If
 '  Next oOlItm
End Sub

05/05/2025, 19h45
Nain porte koi

Merci pour le retour, ça peut servir à d'autres