XL 2016 Envoi mail Outlook plage de cellule (qui ne se déforme pas)

[fredl]

Bonjour à tous,
Je reviens vers vous suite à recherche infructueuse dans le forum.
je souhaite envoyer un Email via outlook dont le corps de message serait la plage A1:E47 du fichier joint qui contient une photo et un dessin.
L'utilisation de "ActiveSheet.MailEnvelope" de la plage en question déforme legèrement le contenu à reception du mail...

Connaitriez un autre moyen de faire cela afin de conserver la presentation de l'original?
(générer par ex une copie d'ecran de la plage- type photo- puis ajout dans le corps du message outlook ? )

Merci d'avance pour votre aide.

Frédéric

/////////////////////ActiveSheet.MailEnvelope///////////////////////////////
Range("A1:E14").Select
' Affiche le message dans le classeur
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Item.To = "xx@cea.fr"
.Item.CC = ""
.Item.Subject = "DUPONT"
.Item.Display
End With
//////////////////////////////////////////////////////

////////////////creation et affichage d'un mail outlook//////////////////////////////////
On Error Resume Next
Set myOlApp = GetObject(, "Outlook.Application")
If myOlApp Is Nothing Then 'si outlook es fermé,ouvrir outlook
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
myFolder.Display
End If
'supprimer les messages d'alerte
Application.DisplayAlerts = False

'Déclaration des objets de la messagerie
Set myOlApp = CreateObject("Outlook.Application")
Set Mail = myOlApp.CreateItem(olMailItem)
'On prépare l'envoi de Mai
With Mail
.SentOnBehalfOfName = SentOnName
'Mettre ici le ou les destinataires
.To = "XX@cea.fr
'.CC = "f"
'.cci = ""
.Subject = "NouvelArrivant"
.Body ="Arrivée de Mr DUPONT" ' ajouter ici à la place la plage de cellule
.Display

End With
Set Mail = Nothing
/////////////////////////////////////////////////////////////////////////////////////////////

 

[kiki29]

Salut, voir sur le site de Ron de Bruin : Mail from Excel with Outlook (Windows)

 

[fanch55]

Salut,
Code exemple fonctionnel à adapter par la suite à votre contexte :

Dim MailItem    As Object
Dim Outlook     As Object
Dim Wins        As Object

Sub Exemple()
    On Error Resume Next
    Ow = Outlook.ActiveWindow.WindowState ' Test si Outlook est ouvert
    If Err Then
        Err.Clear
        Set Outlook = CreateObject("Outlook.Application")
            Set MailItem = Outlook.CreateItem(olMailItem)
                MailItem.Display
            Set Wins = MailItem.GetInspector.wordeditor
    End If
    If Err = 0 Then
       [A1:E14].CopyPicture
        Wins.Paragraphs(1).Range.Paste
        MailItem.Display
    Else
        MsgBox "Erreur " & Err.Number & " - " & Err.Description & vbLf & _
            "Recommencez ...", vbCritical + vbOKOnly
    End If
End Sub

 

[fredl]

Bonjour fanch55 et kiki29,

merci pour vos retours.
j'ai sauté sur la proposition de fanch55 qui est au top!
yoyoyo... trop biennnnnnnnnnn!

Vraiment merci pour votre aide!
kiki29, je vais garder sous le coude les infos du site de Ron de Bruin qui me serviront vraisemblablement plus tard.

A bientôt!

 

[xsara63]

Bonjour

La macro fonctionne partiellement, je suis bloqué a la ligne 99, et pas plus
Avez vous une solution pour des plages de cellules suppérieur à 100 lignes ?
Y-a-il une option a modifier dans EXCEL ?

Merci de votre retour

 

[fanch55]

Bonsoir,
Je ne comprend pas votre problème , pourriez-vous le développer ?
Quelle est votre plage de cellule ?

 

[xsara63]

Bonsoir,
Je ne comprend pas votre problème , pourriez-vous le développer ?
Quelle est votre plage de cellule ?

ma plage de cellules A1: G112

Cependant quand je fais le mail, j'ai bien toutes les colonnes, mais il me manque les lignes de 105 a 112

Alors que j'ai bien dans la macro
Sub MAIL()
Dim Signature As String
Signature = "Signature1" ' Nom d'une signature établie dans Outlook

On Error Resume Next
Ow = Outlook.ActiveWindow.WindowState ' Test si session Outlook ouverte
If Err Then
Err.Clear
Set Outlook = CreateObject("Outlook.Application")
Set MailItem = Outlook.CreateItem(olMailItem)
End If
If Err = 0 Then
On Error GoTo 0
With MailItem
.Display
.To = "mon adresse mail@exemple.com"
.Subject = "P1"
'.Subject = "Objet de l'e-mail"

If Signature = "" Then
Signature = .HTMLBody ' Signature par défaut si paramètré dans outlook
Else
Signature = GetSig(Signature) ' Récupération de la signature si elle existe
End If

Set Wedi = MailItem.GetInspector.WordEditor
' paragraphes 1 et 2
.HTMLBody = "Bonjour,<br><br>" & _
"Voici les données pour le mois" & _
"<br><br>"
Wedi.Content.InsertParagraphAfter
Sheets("Préparation Mail").[A1:G113].CopyPicture
Wedi.Paragraphs(2).Range.Paste

Set Wedi = Nothing

' .display
End With
Set Outlook = Nothing
Else
MsgBox "Erreur " & Err.Number & " - " & Err.Description & vbLf & _
"Recommencez ...", vbCritical + vbOKOnly
End If
End Sub

Comme si la macro prenait que les 105 premiers lignes ou été limité en taille en hauteur pour l'image

Merci de votre aide

 

[fanch55]

Dans le classeur joint , votre macro donne un résultat normal :

Peut-être me manque-t-il une particularité ...
Si vous pouviez joindre un exemplaire anonymisé de votre classeur.

 

[xsara63]

Bonjour

je vous joint l'onglet, je sais pas si il y a la macro

 

[fanch55]

Ci-dessous ce que donne la macro avec le classeur fourni :

Apparemment, pas de problème ...

 

[xsara63]

Pour moi seul la macro PDF fonctionne
Si je ne passe pas par la macro et que je fais un copier coller tout simple
et que j’insère l’image dans un message Outlook, j’ai le même problème

 

[fanch55]

Pouvez-vous fournir un classeur avec la macro qui vous pose problème ?
Je ne connais pas la macro Pdf ...

 

[xsara63]

Pouvez-vous fournir un classeur avec la macro qui vous pose problème ?
Je ne connais pas la macro Pdf ...

Je précise que mes données s’arrête à la ligne 112
Je ne comprend pas pourquoi la copie d'image s’arrête à la ligne 105 (limite d'excel pour faire une image ?)
je pense avoir trouvé, EXCEL ne sait pas géré plus de 105 ligne en format Image pouvez vous me confirmer ?. Car quand sur 1 des tableaux je filtre en enlevant les 0, voici cela donne

Et j'ai bien toute mes lignes et pour infos voici les macros
la commande COPYPICTURE qui je pense doit être limitéà confirmer

Dim MailItem As Object
Dim Outlook As Object
Dim Wedi As Object

Sub MAIL()
Dim Signature As String
Signature = "Signature1" ' Nom d'une signature établie dans Outlook

On Error Resume Next
Ow = Outlook.ActiveWindow.WindowState ' Test si session Outlook ouverte
If Err Then
Err.Clear
Set Outlook = CreateObject("Outlook.Application")
Set MailItem = Outlook.CreateItem(olMailItem)
End If
If Err = 0 Then
On Error GoTo 0
With MailItem
.Display
.To = "XXXXXX@AAA.fr"
.Subject = "P1"
'.Subject = "Objet de l'e-mail"

If Signature = "" Then
Signature = .HTMLBody ' Signature par défaut si paramètré dans outlook
Else
Signature = GetSig(Signature) ' Récupération de la signature si elle existe
End If

Set Wedi = MailItem.GetInspector.WordEditor
' paragraphes 1 et 2
.HTMLBody = "Bonjour,<br><br>" & _
"Voici les données pour le mois" & _
"<br><br>"
Wedi.Content.InsertParagraphAfter
Sheets("Préparation Mail").[A1:G113].CopyPicture
Wedi.Paragraphs(2).Range.Paste

Set Wedi = Nothing

' .display
End With
Set Outlook = Nothing
Else
MsgBox "Erreur " & Err.Number & " - " & Err.Description & vbLf & _
"Recommencez ...", vbCritical + vbOKOnly
End If
End Sub
Function GetSig(ByVal Signature As String) As String
Dim Fso As Object
Dim Txs As Object
Dim File As String
Set Fso = CreateObject("Scripting.FileSystemObject")
' File = Environ("appdata") & "\Microsoft\Signatures\" & Signature & ".htm"
File = "C:\Utilisateurs\XXXXXX\AppData\Roaming\Microsoft\Signatures\" & Signature1 & ".htm"
Select Case True
Case Signature = "":
Case Not Fso.FileExists(File):
Case Else
Set Txs = Fso.GetFile(File).OpenAsTextStream(1, -2)
GetSig = Txs.readall
Txs.Close
Set Txs = Nothing
End Select
Set Fso = Nothing
End Function

 

[fanch55]

Bon, vous avez peut-être un problème de mémoire de stockage.
Moi, j'ai 32 go,la procédure marche correctement, à ceci près que l'image devient un peu trop comprimée .

Essayez la méthode de Ron de Brouin :

Option Explicit
Dim MailItem As Object
Dim Outlook As Object

Sub MAIL()
Dim Signature As String, L As Variant, Ow
    Signature = "Signature1" ' Nom d'une signature établie dans Outlook
    L = InputBox("Nombre de lignes à insérer", , 115)
    
    On Error Resume Next
    Ow = Outlook.ActiveWindow.WindowState ' Test si session Outlook ouverte
    If Err Then
        Err.Clear
        Set Outlook = CreateObject("Outlook.Application")
        Set MailItem = Outlook.CreateItem(0)
    End If
    If Err = 0 Then
        On Error GoTo 0
        With MailItem
            .display
            .To = "XXXXXX@AAA.fr"
            .Subject = "P1"     ' Objet de l'e-mail
            If Signature = "" Then
                Signature = .HTMLBody ' Signature par défaut si paramètré dans outlook
            Else
               Signature = GetSig(Signature) ' Récupération de la signature si elle existe
            End If
            .HTMLBody = "Bonjour,<br><br>" & _
            "Voici les données pour le mois<br><br>" & _
            RangetoHTML(Sheets("Préparation Mail").[A1:G1].Resize(L)) & _
            "<br><br>" & _
            Signature

        ' .display
        End With
        Set Outlook = Nothing
    Else
        MsgBox "Erreur " & Err.Number & " - " & Err.Description & vbLf & _
        "Recommencez ...", vbCritical + vbOKOnly
    End If
End Sub
Function GetSig(ByVal Signature As String) As String
Dim Fso As Object
Dim Txs As Object
Dim File As String
    Set Fso = CreateObject("Scripting.FileSystemObject")
         File = Environ("appdata") & "\Microsoft\Signatures\" & Signature & ".htm"
        'File = "C:\Utilisateurs\XXXXXX\AppData\Roaming\Microsoft\Signatures\" & Signature1 & ".htm"
        Select Case True
            Case Signature = "":
            Case Not Fso.FileExists(File):
            Case Else
                Set Txs = Fso.GetFile(File).OpenAsTextStream(1, -2)
                GetSig = Txs.readall
                Txs.Close
                Set Txs = Nothing
        End Select
    Set Fso = Nothing
End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim Fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
'        On Error Resume Next
'        .DrawingObjects.Visible = True
'        .DrawingObjects.Delete
'        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set Fso = Nothing
    Set TempWB = Nothing
End Function