Signature commune pour outlook

Question

Bonjour

  J'ai développé une macro pour outlook afin de rajouter une signature commune a tout les utilisateurs, le principe est de rajouter le code html d'un fichier ainsi que les images qui sont dans un repertoire sur le reseau.
  Je post ce message afin de trouver des améliorations à ce script, notamment je n'ai pas trouver comment inserer ma signature entre la fin du message et le message d'origine dans le cas d'une reponse ou un transfert. Pour paufiner je pense qu'il y a plus simple pour savoir si le message est une reponse ou un transfert, et aussi sur mon test sur le type de fichier.

Eric

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMsg As Outlook.MailItem
Dim Path As String
'Chemin et nom de fichier de la signature
Path = "D:\signature"
File = Path & "\signature.html"

If TypeOf Item Is Outlook.MailItem Then
    Set objMsg = Item
    'Test si le message est un nouveau message
    If objMsg.BodyFormat olFormatHTML And objMsg.Subject objMsg.ConversationTopic Then
        Dim fso As New FileSystemObject
        Dim ts As TextStream
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(File) Then
            Dim colAttach As Outlook.Attachments
            Dim oAttach As Outlook.Attachment
            Set colAttach = objMsg.Attachments
            With fso.GetFolder(Path) 'Liste les fichiers du répertoire
                For Each NomFich In .Files
                    'Ajout les images JPG dans le message
                    If LCase(Right(NomFich.Name, 3)) = "jpg" Then
                        Set oAttach = colAttach.Add(NomFich.Path)
                    End If
                Next
            End With
            
            'Ajout de la signature
            Set ts = fso.GetFile(File).OpenAsTextStream(1, -2)
            objMsg.HTMLBody = objMsg.HTMLBody & "
" & ts.readall
            ts.Close
        End If
    End If
End If
Set objMsg = Nothing
End Sub

ucfoutu · Answer

Bonjour,
ces 4 lignes

Dim fso As New FileSystemObject
        Dim ts As TextStream
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(File) Then
s'écrivent en 1 seule avec dir (et sans alourdir avec FSO) !
à main levée 
If len(dir(file)) > 0 then
pareil pour la suite (dir est plus avantageux, moins indirect et plus léger).
____________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches d'autres forumeurs.
Pas d'aide en ligne installée ? ==> ne comptez pas sur moi pour simplement vous dire ce qu'elle contient

NHenry · Answer

Bonjour, 

Es-tu bien en .NET, j'ai un doute, merci de confirmer.

En .NET, il y a System.IO.File.Exists pour vérifier l'existence et System.IO.Directory.* pour les dossiers.

---------------------------------------------------------------------
[list=ordered][*]Pour poser correctement une question et optimiser vos chances d'obtenir des réponses, pensez à lire le règlement CS, ce lien ou encore celui-ci[*]Quand vous postez un code, merci d'utiliser la coloration syntaxique (3ième icône en partant de la droite : )
[*]Si votre problème est résolu (et uniquement si c'est le cas), pensez à mettre "Réponse acceptée" sur le ou les messages qui vous ont aidés./list
---
Mon site

cs_sinex · Answer

Ucfoutu a raison, la fonction dir est certe limitée mais amplement suffisante pour mon cas et ne demande pas de reference externe.

cs_sinex · Answer

J'ai fait quelques modifications
- boucle pour tester si un destinataire est exterieur au domaine pour ne pas mettre de signature sur les messages internes
- recherche dans le corps de message de la ligne de separation du message d'origine pour inserer la signature avant

Eric

Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMsg As Outlook.MailItem
Dim Path As String
Dim HtmlBody As String
Dim Position As Integer

HtmlBody = ""

'Chemin et nom de fichier de la signature
Path = "\SRVDONNEES\users\Commun\Outlook\Signature"
File = Path & "\signature.html"

If TypeOf Item Is Outlook.MailItem Then 'Test si l'élément est un message
    Set objMsg = Item
    If objMsg.BodyFormat = olFormatHTML Then 'Test si le message est un nouveau message
        For Each recip In objMsg.Recipients
            If InStr(1, UCase(recip.Address), "SINEX") = 0 Then 'Test si un destinataire n'est pas dans l'organisation SINEX
                Dim fso As New FileSystemObject
                Dim ts As TextStream
                Set fso = CreateObject("Scripting.FileSystemObject")
                If fso.FileExists(File) Then 'test si la signature existe
                    Dim colAttach As Outlook.Attachments
                    Dim oAttach As Outlook.Attachment
                    Set colAttach = objMsg.Attachments
                    
                    With fso.GetFolder(Path) 'Liste les fichiers du répertoire
                        For Each NomFich In .Files
                            'Ajout les images JPG dans le message
                            If LCase(Right(NomFich.Name, 3)) = "jpg" Then
                                Set oAttach = colAttach.Add(NomFich.Path)
                            End If
                        Next NomFich
                    End With
                    
                    'Ajout de la signature
                    Set ts = fso.GetFile(File).OpenAsTextStream(1, -2)
                    HtmlBody = objMsg.HtmlBody
                    Position = InStr(1, HtmlBody, "
")
                    If Position <> 0 Then 'Si transfert ou reponse insertion avant message d'origine
                        objMsg.HtmlBody = Mid(HtmlBody, 1, Position - 1) & "
" & ts.readall & "
" & Mid(HtmlBody, Position)
                    Else
                        objMsg.HtmlBody = objMsg.HtmlBody & "
" & ts.readall
                    End If
                    ts.Close
                End If
                Exit For 'Sort de la boucle de test de destinataire
            End If
        Next recip
    End If
End If
Set objMsg = Nothing
End Sub

Signature commune pour outlook

4 réponses

Votre réponse

Discussions similaires