Microsoft 365 Mise en page mail/vba

D

Dju1

XLDnaute Occasionnel
Bonjour à tous,
je suis à la fin d'une VBA, avec une grosse aide d'un membre du forum, mais je bloque sur la mise en page. J'aimerai inséré une image, ma vba "fonctionne" mais je ne comprend pas pourquoi l'image ne s'affiche pas (j'ai un cadre que je peux redimensionner mais rien dedans)
Et j'aurais aussi aimer intégrer des espaces avant la date.
Merci d'avance

VB: 
      Txt = " <p> Bonjour, <p> Suite à notre entretien téléphonique je vous confirme le rendez-vous pour le début de votre chantier le <p> <b>"
      Txt = Txt & Format(Dat, "dddd dd/mm/yyyy") & _
        " à partir de 7h30 </b> <p> A noter que nos poseurs sont habilités à réceptionner le chantier et à percevoir le solde restant dû, merci de " & _
        "prendre vos dispositions afin que cela soit respecté à la fin des travaux. "
      With m
        .Subject = "Confirmation de rendez-vous"
        .htmlBody = "<img src=C:\Users\adv.\Downloads\logo.jpg\>" & Txt
        .Recipients.Add Target.Offset(, -1)
        .display
 
Dernière édition:
Solution
mromain
Dju1 à dit:
Bonjour Romain,
merci pour le coup de main, ça fonctionne parfaitement pour le décrochage sur la droite, je vais avoir besoin d'ajouter d'autres espaces mais je devrais m'en sortir.
Ne me reste plus que la signature, mais là je t'avoue que ça devient complexe pour moi. Je mets le code si jamais quelqu'un peut prendre le temps de m'apporter un peu d'aide

Merci d'avance

VB: 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim Dat As Variant, C As Range, Txt As String, Col As Integer
  Dim L As Integer
  Dim objOL As Object, ObjMail As Object
  Dim oAttach As Object, ColAttach As Object
 
  Set objOL = CreateObject("Outlook.Application")
    Set ObjMail = objOL.CreateItem(0)...
Cliquez pour agrandir...
Trier par date Trier par votes
Oneida

Oneida

XLDnaute Impliqué
Bonjour,
Code trouve a la suite d'une recherche et adapte a votre morceau de code. Test: voir image

Une erreur sur .recipient dans votre code , mis en commentaire
VB: 
Sub test_image_corps_message()

    Dim objOL As Object, ObjMail As Object
    Dim oAttach As Object, ColAttach As Object
 
    Set objOL = CreateObject("Outlook.Application")
    Set ObjMail = objOL.CreateItem(0)
    Set ColAttach = ObjMail.attachments
    Set oAttach = ColAttach.Add("C:\Users\adv.\Downloads\logo.jpg") 'Changer le chemin et le nom de l'image
    '------------------------------
        Txt = " <p> Bonjour, <p> Suite à notre entretien téléphonique je vous confirme le rendez-vous pour le début de votre chantier le <p> <b>"
        Txt = Txt & Format(Dat, "dddd dd/mm/yyyy") & _
        " à partir de 7h30 </b> <p> A noter que nos poseurs sont habilités à réceptionner le chantier et à percevoir le solde restant dû, merci de " & _
        "prendre vos dispositions afin que cela soit respecté à la fin des travaux. "
    With ObjMail
        .to = Cells(8, 11)
        .CC = Cells(9, 11)
        .Subject = "Confirmation de rendez-vous"
        .htmlBody = "<BODY><IMG src=cid:logo.jpg<\BODY>" & Txt
        '.Recipients.Add Target.Offset(, -1)  ??????
        ObjMail.Save
        .display    'Send   Display permet d'afficher le message, Send l'envoie sans affichage
    End With
 
'    ActiveWorkbook.Close
 
    Set oAttach = Nothing
    Set ColAttach = Nothing
    Set ObjMail = Nothing
    Set objOL = Nothing
End Sub
 

Pièces jointes

  • Image_Corps_Message.JPG
    Image_Corps_Message.JPG
    103.1 KB · Affichages: 13
Vote positif 0 Vote négatif
D

Dju1

XLDnaute Occasionnel
Bonjour Oneida,
merci de ton aide, ça fonctionne plutôt bien. J'ai 2 adresses mail (l'une est l'en tete d'un tableau) qui se renseigne mais je vais chercher la cause.

J'ai oublié de préciser que j'aurais besoin de la signature également. Est-ce possible de l'ajouter à htmlbody ?
Merci d'avance
 
Vote positif 0 Vote négatif
D

Dju1

XLDnaute Occasionnel
J'ai trouvé la solution pour l'adresse mail, il s'agissait d'une adaptation à mon fichier.

Pour en finir avec cette vba il ne me reste qu'à insérer des espaces avant la date et insérer la signature... Si jamais l'un d'entre vous à la solution, je reste à l'écoute
 
Vote positif 0 Vote négatif
Oneida

Oneida

XLDnaute Impliqué
Bonjour,

un autre exemple. Pour les espaces, perso je les mets a la mano, ai pas trouve mieux sauf des variables definies avec un nombre espaces
VB: 
'http://www.rondebruin.nl/win/s1/outlook/signature.htm
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

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

    strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & "\Microsoft\Signatures\Mysig.htm"    'fichier signature a creeer

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next

    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        'or use
        .Display
        '.Send
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
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
 
Dernière édition:
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Bonjour Dju1, Oneida le forum,

Pour le problème d'espaces avant la date, tu peux :
  • Soit utiliser des espaces insécables avant la date (ajouter "&nbsp;" pour chaque espace) ;
  • Soit faire un décrochage sur la droite (ajouter "<dd>" avant la date et "</dd>" après.


Pour la signature, le code de rondebruin proposé par Oneida peut poser problème si la signature contient des images.
Si tel est le cas, tu trouveras une alternative ici.

A+
 
Vote positif 0 Vote négatif
D

Dju1

XLDnaute Occasionnel
Bonjour Romain,
merci pour le coup de main, ça fonctionne parfaitement pour le décrochage sur la droite, je vais avoir besoin d'ajouter d'autres espaces mais je devrais m'en sortir.
Ne me reste plus que la signature, mais là je t'avoue que ça devient complexe pour moi. Je mets le code si jamais quelqu'un peut prendre le temps de m'apporter un peu d'aide

Merci d'avance

VB: 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim Dat As Variant, C As Range, Txt As String, Col As Integer
  Dim L As Integer
  Dim objOL As Object, ObjMail As Object
  Dim oAttach As Object, ColAttach As Object
 
  Set objOL = CreateObject("Outlook.Application")
    Set ObjMail = objOL.CreateItem(0)
    Set ColAttach = ObjMail.attachments
    Set oAttach = ColAttach.Add("C:\Users\adv\Downloads\logo.jpg")
 
  If Sh.Name <> "LIEN WAZE" And Sh.Name <> "Config" Then
    Cancel = True
    If Target.Value = "*" Then
      If Target.Count > 1 Then Exit Sub
      If Target.Column <> 20 Or Target.Row < 9 Then Exit Sub
      Set olApp = CreateObject("Outlook.application")
      With Sh
        L = .[V:V].Find("*", , , , xlByRows, xlPrevious).Row + 1
        Col = Application.Match("PLANNING D'INTERVENTION", .[6:6], 0)
        For Each C In .Cells(9, Col).Resize(L, 5)
          If C = .Cells(Target.Row, 1) Then
            If .Cells(8, C.Column) < Dat Or Dat = "" Then
              Dat = .Cells(8, C.Column)
            End If
          End If
        Next C
      End With
      Txt = " <p> Bonjour, <p> Suite à notre entretien téléphonique je vous confirme le rendez-vous pour le début de votre chantier le <p> <b>"
      Txt = Txt & "<dd>" & Format(Dat, "dddd dd/mm/yyyy") & _
        " à partir de 7h30 </b> </dd> <p> A noter que nos poseurs sont habilités à réceptionner le chantier et à percevoir le solde restant dû, merci de " & _
        "prendre vos dispositions afin que cela soit respecté à la fin des travaux. "
      With ObjMail
        .Subject = "Confirmation de rendez-vous"
        .htmlBody = "<BODY><IMG src=cid:logo.jpg<\BODY>" & Txt
        .Recipients.Add Target.Offset(, -1)
        .display
        
      End With
      
    Set oAttach = Nothing
    Set ColAttach = Nothing
    Set ObjMail = Nothing
    Set objOL = Nothing
    End If
  End If
End Sub
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
bonjour à tous
juste en passant

la balise P est une balise paragraphe
si tu met <p> blablabla <p> blablabla tu met le outertext de la p(2) dans le innertext de p(1)
de ce fait les espaces et autre inconvenue sont pris comme du texte et le whitespace n'est plus pris en compte

a imbriquer des balises P vous risquez une interprétation différente selon l'application mail de votre client
VB: 
Sub test()
    dat = Date
    txt = " <p> Bonjour,</p>"
    txt = txt & "<p> Suite à notre entretien téléphonique je vous confirme le rendez-vous pour le début de votre chantier le <p>"
    txt = txt & "<p><dd><b>" & Format(dat, "dddd dd/mm/yyyy") & " à partir de 7h30 </b></dd></p> "
    txt = txt & "<p> A noter que nos poseurs sont habilités à réceptionner le chantier et à percevoir le solde restant dû, merci de " & _
          "prendre vos dispositions afin que cela soit respecté à la fin des travaux.</p> "


    'si vous avez encore internet explorer qui fonctionne
    'vous pouvez en avoir un apercu du résultat avec le code ci dessous
    With CreateObject("internetexplorer.application")
        .navigate "about:blank"
        .Visible = True
        Do While .readystate < 4: DoEvents: Loop
        .document.write txt
    End With
End Sub

VB: 
Sub test2()
    dat = Date
    txt = " <p> Bonjour,</p>"
    txt = txt & "<p> Suite à notre entretien téléphonique je vous confirme le rendez-vous pour le début de votre chantier le <p>"
    txt = txt & "<p><blockquote><b>" & Format(dat, "dddd dd/mm/yyyy") & " à partir de 7h30 </b></blockquote></p> "
    txt = txt & "<p> A noter que nos poseurs sont habilités à réceptionner le chantier et à percevoir le solde restant dû, merci de " & _
          "prendre vos dispositions afin que cela soit respecté à la fin des travaux.</p> "


    'si vous avez encore internet explorer qui fonctionne
    'vous pouvez en avoir un apercu du résultat avec le code ci dessous
    With CreateObject("internetexplorer.application")
        .navigate "about:blank"
        .Visible = True
        Do While .readystate < 4: DoEvents: Loop
        .document.write txt
    End With
End Sub
exemple 3
avec l'attribut text-indent à attribuer au P concerné
a noter que j'indente avec le mode length en pixels
cette dimension peut être modifiée à souhait
VB: 
Sub test3()
    dat = Date
    txt = " <p> Bonjour,</p>"
    txt = txt & "<p> Suite à notre entretien téléphonique je vous confirme le rendez-vous pour le début de votre chantier le <p>"
    txt = txt & "<p style="" Text-Indent:50px;""><b>" & Format(dat, "dddd dd/mm/yyyy") & " à partir de 7h30 </b></p> "
    txt = txt & "<p> A noter que nos poseurs sont habilités à réceptionner le chantier et à percevoir le solde restant dû, merci de " & _
          "prendre vos dispositions afin que cela soit respecté à la fin des travaux.</p> "


    'si vous avez encore internet explorer qui fonctionne
    'vous pouvez en avoir un appercu du résultat avec le code ci dessous
    With CreateObject("internetexplorer.application")
        .navigate "about:blank"
        .Visible = True
        Do While .readystate < 4: DoEvents: Loop
        .document.write txt
    End With
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Dju1 à dit:
Bonjour Romain,
merci pour le coup de main, ça fonctionne parfaitement pour le décrochage sur la droite, je vais avoir besoin d'ajouter d'autres espaces mais je devrais m'en sortir.
Ne me reste plus que la signature, mais là je t'avoue que ça devient complexe pour moi. Je mets le code si jamais quelqu'un peut prendre le temps de m'apporter un peu d'aide

Merci d'avance

VB: 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim Dat As Variant, C As Range, Txt As String, Col As Integer
  Dim L As Integer
  Dim objOL As Object, ObjMail As Object
  Dim oAttach As Object, ColAttach As Object
 
  Set objOL = CreateObject("Outlook.Application")
    Set ObjMail = objOL.CreateItem(0)
    Set ColAttach = ObjMail.attachments
    Set oAttach = ColAttach.Add("C:\Users\adv\Downloads\logo.jpg")
 
  If Sh.Name <> "LIEN WAZE" And Sh.Name <> "Config" Then
    Cancel = True
    If Target.Value = "*" Then
      If Target.Count > 1 Then Exit Sub
      If Target.Column <> 20 Or Target.Row < 9 Then Exit Sub
      Set olApp = CreateObject("Outlook.application")
      With Sh
        L = .[V:V].Find("*", , , , xlByRows, xlPrevious).Row + 1
        Col = Application.Match("PLANNING D'INTERVENTION", .[6:6], 0)
        For Each C In .Cells(9, Col).Resize(L, 5)
          If C = .Cells(Target.Row, 1) Then
            If .Cells(8, C.Column) < Dat Or Dat = "" Then
              Dat = .Cells(8, C.Column)
            End If
          End If
        Next C
      End With
      Txt = " <p> Bonjour, <p> Suite à notre entretien téléphonique je vous confirme le rendez-vous pour le début de votre chantier le <p> <b>"
      Txt = Txt & "<dd>" & Format(Dat, "dddd dd/mm/yyyy") & _
        " à partir de 7h30 </b> </dd> <p> A noter que nos poseurs sont habilités à réceptionner le chantier et à percevoir le solde restant dû, merci de " & _
        "prendre vos dispositions afin que cela soit respecté à la fin des travaux. "
      With ObjMail
        .Subject = "Confirmation de rendez-vous"
        .htmlBody = "<BODY><IMG src=cid:logo.jpg<\BODY>" & Txt
        .Recipients.Add Target.Offset(, -1)
        .display
       
      End With
     
    Set oAttach = Nothing
    Set ColAttach = Nothing
    Set ObjMail = Nothing
    Set objOL = Nothing
    End If
  End If
End Sub
Cliquez pour agrandir...
Re-bonjour,


Pour ce, il te faut ajouter cette fonction à ton projet VBA :
VB: 
Public Function UserSignatures() As Collection
Dim oFso As Object          'Scripting.FileSystemObject
Dim oCurFile As Object      'Scripting.File
Dim oRegExp As Object       'VBScript_RegExp_55.regExp
Dim oMatches As Object      'VBScript_RegExp_55.MatchCollection
Dim oMatch As Object        'VBScript_RegExp_55.Match
Dim pathSignatures As String
Dim relativePath As String
Dim absolutePath As String
Dim htmlSignature As String
 
    'initialisation
    Set UserSignatures = New Collection
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Set oRegExp = CreateObject("vbscript.regexp")
    With oRegExp
        .Pattern = "<[^>]+src=""([^"">]+)"""
        .MultiLine = True
        .Global = True
    End With
 
    'boucler sur tous les fichiers du dossier %APPDATA%\Roaming\Microsoft\Signatures
    pathSignatures = Environ("APPDATA") & "\Microsoft\Signatures"
    For Each oCurFile In oFso.GetFolder(pathSignatures).Files
        'si le fichier est un .htm (signature)
        If LCase(oCurFile.Name) Like "*.htm" Then
            'récupérer le contenu html
            htmlSignature = oFso.OpenTextFile(oCurFile.Path, 1).ReadAll
            'remplacer les path relatifs en path absolus
            Set oMatches = oRegExp.Execute(htmlSignature)
            For Each oMatch In oMatches
                relativePath = oMatch.SubMatches(0)
                absolutePath = oFso.BuildPath(pathSignatures, relativePath)
                If oFso.FileExists(absolutePath) Then
                    htmlSignature = Replace(htmlSignature, "src=""" & relativePath & """", "src=""" & absolutePath & """")
                End If
            Next oMatch
            'ajouter la signature à la collection
            UserSignatures.Add htmlSignature, oFso.GetBaseName(oCurFile.Name)
        End If
    Next oCurFile
 
    Set oFso = Nothing
    Set oCurFile = Nothing
    Set oRegExp = Nothing
    Set oMatches = Nothing
    Set oMatch = Nothing
End Function

Et modifier ton code ainsi :
VB: 
         .htmlBody = "<BODY><IMG src=cid:logo.jpg<\BODY>" & Txt & UserSignatures(1)

Ici, le 1 signifie "la première signature trouvée".
Si tu as plusieurs signatures, il te faudra peut-être adapter cet index.

A+
 
Vote positif 0 Vote négatif
Solution

Discussions similaires

Malynx
  • Question
XL 2016 VBA : Ajouter dans le ruban 1 onglet / import d'un fichier excel / reconstruction de la mise en page de l'import Excel
Réponses
1
Affichages
386
Gégé-45550
Gégé-45550
L
  • Résolu(e)
Microsoft 365 Macro mise en forme feuille excel
Réponses
2
Affichages
681
Laura01
L
L
  • Question
XL 2013 VBA - Dupliquer ligne et fusionner certaines colonnes
Réponses
2
Affichages
1 K
Leché
L
D
  • Question
Microsoft 365 Copier Coller simple et mise en page word
Réponses
0
Affichages
769
Dibou
D
S
  • Question
XL 2013 Faire mise en page de chiffres excel à word
Réponses
1
Affichages
695
Denis132
D
J
  • Question
Uploader un fichier .txt sur une page WEB via VBA
Réponses
1
Affichages
4 K
Staple1600
Staple1600
Rhiannon51
  • Question
Manipulation et mise en page données VBA
Réponses
2
Affichages
6 K
Rhiannon51
Rhiannon51
A
  • Question
Mise en page Word dans un mail Outlook
Réponses
7
Affichages
25 K
amayaa
A
M
  • Question
Mise en forme de tableau VBA
Réponses
0
Affichages
2 K
McKly91
M
K
  • Question
Mise en page par vba En-tête, pied de pages, marges, ligne des titres à imprimer
Réponses
4
Affichages
12 K
KIM
K

Membres actuellement en ligne

20 membres et 121 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 220
Messages
2 086 376
Membres
103 198
dernier inscrit
CACCIATORE