Ajout de signature OUTLOOK dans macro copier de cellule

Le 01/08/2017 à 11:49

Bonjour,

Suite à de nombreux tests, recherches sur internet etc..., je me tourne vers vous car je n'arrive vraiment pas à trouver la solution.

Voici mon problème, je souhaite intégrer ma signature de mail OUTLOOK au sein de ma macro qui envoi des mails grace à une loop insérer dans le code.

J'ai déjà le fichier HTM correspondant à la signature que je souhaite intégrer mais toutes les possibilités de code que j'ai essayé ont échoué.

Peut être avez-vous une solution

Voici le code :

Sub Mail_Selection_Range_Outlook_Body()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next

    Set rng = Sheets("ANNONCE").Range("A1:G33").SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly

    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Sheets("BDD TRANSPORTEURS").Activate
 ActiveSheet.Range("A1").Select

Do
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = "exploitation centrale france"
        .To = ActiveCell.Value
        .CC = ""
        .BCC = ""
        .Subject = " OFFER LOADS W" & Worksheets("ANNONCE").Range("C12").Value & ""
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    ActiveCell.Offset(1, 0).Select
    Loop Until IsEmpty(ActiveCell)

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Merci par avance de votre aide !

Bonne journée

Le 01/08/2017 à 12:27

Bonjour,

Théoriquement on doit pouvoir comme ceci :

.HTMLBody = "bla bla" & "<br>" & Signature

en allant chercher sa signature par GetBoiler

    ' récupération de la signature
    ' attention sign.htm à modifier si besoin
    SigString = Environ("appdata") & "\Microsoft\Signatures\sign.htm"
    ' si l'image ne peut pas être récupérée :
    ' SigString = Environ("appdata") & "\Microsoft\Signatures\sign.txt"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
        ' uniquement si l'image peut être récupérée :
        Signature = Replace(Signature, "src=""sign_fichiers/", "src=""" & Environ("appdata") & "\Microsoft\Signatures\" & "sign_fichiers\")
    Else
        Signature = ""
    End If

et

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

ça c'est la théorie ! essaie, chez moi cela n'a jamais fonctionné !!

je peux te donner d'autres solutions de contournement ... à suivre

Le 01/08/2017 à 16:14

Bonjour Steelson,

Merci pour ta réponse

Par contre la partie 2 & 3 du code, je ne vois pas ou les insérer dans mon code actuel ?

Tu aurais des indications ?

Le 01/08/2017 à 16:46

Finalement j'ai réussi à diviser les fonctions pour les faire fonctionner

Ca fonctionne à 70%, en effet les images qui devraient s'insérer ne le sont pas

Voici le message à la place des images :

Impossible d'afficher liée. Le fichier a peut-être déplacé, renommée ou supprimé. Vérifiez que la liaison pointe vers le fichier et l'emplacement corrects.

Le 01/08/2017 à 17:39
VINCENTPRRT a écrit :

Bonjour Steelson,

Merci pour ta réponse

Par contre la partie 2 & 3 du code, je ne vois pas ou les insérer dans mon code actuel ?

Tu aurais des indications ?

Voici un exemple ...

Option Explicit
Sub envoi()

Dim messagerie As Object
Dim email As Object
Dim nompdf As String
Const olFormatHTML As Long = 2

Dim SigString As String
Dim Signature As String

    ' récupération de la signature
    ' attention sign.htm à modifier si besoin
    SigString = Environ("appdata") & "\Microsoft\Signatures\sign.htm"
    ' si l'image ne peut pas être récupérée :
    ' SigString = Environ("appdata") & "\Microsoft\Signatures\sign.txt"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
        ' uniquement si l'image peut être récupérée :
        Signature = Replace(Signature, "src=""sign_fichiers/", "src=""" & Environ("appdata") & "\Microsoft\Signatures\" & "sign_fichiers\")
    Else
        Signature = ""
    End If

    ' création fichier et stockage dans le dossier temporaire du PC
    nompdf = Environ("Temp") & "\" & "Consignes"
    Sheets("Consignes").ExportAsFixedFormat Type:=xlTypePDF, Filename:=nompdf & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

    Set messagerie = CreateObject("Outlook.Application")
    Set email = messagerie.CreateItem(0)
    With email
        .To = [B1]
        .CC = [B2]
        .Bcc = [B3]
        .Subject = [B4]
        .BodyFormat = olFormatHTML
        .HTMLBody = texthtml([B6:B12]) & "<br>" & Signature
        ' si l'image ne peut pas être récupérée :
        ' .HTMLBody = "bla bla bla" & "<br>" & Replace(Signature, vbCrLf, "<br/>")
        .Attachments.Add nompdf & ".pdf"
        .display ' ou .send pour envoi direct
    End With

    ' suppression du fichier temporaire
    Kill Environ("Temp") & "\" & "Consignes" & ".pdf"

End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
Le 01/08/2017 à 18:05
VINCENTPRRT a écrit :

Ca fonctionne à 70%, en effet les images qui devraient s'insérer ne le sont pas

Voici le message à la place des images :

Impossible d'afficher liée. Le fichier a peut-être déplacé, renommée ou supprimé. Vérifiez que la liaison pointe vers le fichier et l'emplacement corrects.

Pas étonnant car les images sont stockées "à part" du texte ...

La seule solution que j'ai trouvée et qui est un peu limitative (il vaut mieux n'envoyer qu'un seul mail à la fois) est de faire un copier/coller par sendkeys.

Voici un exemple

114envoi-email-copie-sendkeys-bis.xlsm (60.76 Ko)
Le 08/08/2017 à 12:03

Merci pour ton retour

Je n'arrive pas à comprendre quelle partie de ton code permet de copier/coller l'image voulue ?

Le 08/08/2017 à 12:23

Salut steelson, VINCENTPRRT

Alors je participe à ce sujet, étant donné que j'utilise la macro de steelson (qui m'avait dépanné sur le sujet)

Voici la partie du code qui sert à copier / coller.

    Range("corpsdumail").Copy
    email.display
    Application.Wait (Now + TimeValue("0:00:01"))
'ajout de cette ligne pour copier dans le corps de mail
    Application.SendKeys "{TAB 3}", True
'sans cette ligne, chez moi cela va coller dans la partie destinataire.
   SendKeys "^v", True
    'Application.CutCopyMode = False

    Set email = Nothing
    Set messagerie = Nothing

Bonne journée

Le 08/08/2017 à 15:12

Merci nonesofar13,

cela fait plaisir en effet de voir que tu t'es approprié le code

curieux, je n'ai eu besoin de tabuler qu'avec la partie agenda d'outlook pour ma part

Le 15/08/2017 à 11:59

@VINCENTPRRT

IL y a peut-être une solution comme suit :

    With OutMail
        .Display
        .SentOnBehalfOfName = "exploitation centrale france"
        .To = ActiveCell.Value
        .CC = ""
        .BCC = ""
        .Subject = " OFFER LOADS W" & Worksheets("ANNONCE").Range("C12").Value & ""
        .HTMLBody = RangetoHTML(rng) & "<br>" & .HTMLBody
        .Display
   End With
Rechercher des sujets similaires à "ajout signature outlook macro copier"