Microsoft 365 creation mail av capture ecran plage définie

looky62 · 16 Mars 2023

hELLO la communauté,

je souhaite automatiser un mail afin d'envoyer un rapport en fin de semaine, le minutage fonctionne, ce qui bloque pr moi c la capture d'ecran en fait je souhaiterai joindre ds le corps de mon mail une capture de 2 feuilles de calculs composé de graphiques et de données qui sont comprises entre A1 et R35 , j ai tenté plusieurs codes mais en vain si vous avez ds vos bibliothéques ce genre d'automatisation

ma dernieres tentatives en vain *

Sub EnvoyerEmailAvecPlage()

Dim monMail As Object
Dim strAdresse As String
Dim strObjet As String
Dim strMsg As String
Dim rngPlage As Range

'Définir la plage à capturer sous forme d'image
Set rngPlage = ThisWorkbook.Sheets("TCD").Range("A1:R35")

'Définir l'adresse du destinataire
strAdresse = "exemple@adresse.com"

'Définir l'objet de l'e-mail
strObjet = "Objet de l'e-mail"

'Définir le message de l'e-mail avec l'image capturée
strMsg = "Bonjour, Voici la plage de cellules que vous avez demandée : <img src='data:image/png;base64," & ImageToBase64(rngPlage) & "'> Bien cordialement."

'Créer l'e-mail
Set monMail = CreateObject("Outlook.Application").CreateItem(0)

'Définir les propriétés de l'e-mail
With monMail
.To = strAdresse
.Subject = strObjet
.HTMLBody = strMsg
.Display
End With
'Créer un graphique à partir de la plage spécifiée
Set imgChart = rng.Parent.Shapes.AddChart2(201, xlColumnClustered).Chart
With imgChart
.SetSourceData rng
.ChartArea.Format.Fill.Visible = msoFalse
.ChartArea.Format.Line.Visible = msoFalse
End With

End Sub

Function ImageToBase64(rng As Range) As String
Dim cht As Chart
Dim imgStream As ADODB.Stream

'Créer un graphique à partir de la plage spécifiée
Set cht = rng.Parent.Shapes.AddChart2(201, xlColumnClustered).Chart
With cht
.SetSourceData rng
.ChartArea.Format.Fill.Visible = msoFalse
.ChartArea.Format.Line.Visible = msoFalse
End With

'Enregistrer le graphique sous forme d'image dans un flux ADODB
Set imgStream = New ADODB.Stream
With imgStream
.Type = adTypeBinary
.Open
cht.Export "C:\Temp\chart.png", "PNG"
.LoadFromFile "C:\Temp\chart.png"
End With

'Convertir l'image en chaîne Base64
ImageToBase64 = Replace(imgStream.ReadText(adReadAll), vbCrLf, "")

'Nettoyer les objets créés
cht.Parent.Delete
imgStream.Close
Kill "C:\Temp\chart.png"
End Function

************************************

ça plante Dim imgStream As ADODB.Stream, a mon avis ADOB n'est pas défini ds les extensions de mon ETS sous Excel y a t il une autre parade

kiki29 · 16 Mars 2023

Salut, à fouiller : Mail from Excel with Outlook (Windows)

Oneida · 18 Mars 2023

Bonjour,
essayez ceci pour definir imgStream

VB:

Sub test()
    Dim imgStream As Object

    Set imgStream = CreateObject("ADODB.Stream")
End Sub

patricktoulon · 18 Mars 2023

bonjour
pour info le base 64 n'est pas valide dans outlook et ce n'est pas le seul client mail a ne plus l'accepter

outlook a son propre pseudo code base 64 qui diffère un peu du code original
et quand on met une image dans outlook il le converti automatiquement dans son pseudo code base 64

attache l'image en pièce jointe
et dans le src tu met "cid:nomimage.jpg"

d'ailleurs depuis windows 64 l'object stream rencontres des problèmes d'octets manquant en effet en buffer il est devenu limité ce qui fait que l'image est soit tronquée soit une fractale soit un beau carré blanc
il est fort possible aussi que le stream casse le BOM

Bref conclusion: l'object stream tu oublie

d'ailleurs je crois reconnaitre une partie de mes vieux codes de conversion meme le nom de la fonction n'a pas changé
pour info ces codes là je ne les utilise plus depuis presque 4 ans

attach les tes images et tu sera moins ennuyée

patricktoulon · 18 Mars 2023

j'oubliais il y a le fait aussi que le jpg sauvé avec un chart n'est pas vraiment ni un jpg ni un gif mono frame ni un bitmap c'est tres proche du jpg c'est vrai
ce qui fait qu'en terme binaire( en lecture) l’entête de fichier image(le BOM) n'est pas 255 ,274,255 comme un jpg
il est fort possible que le stream en perd le nord
bref trouvant que ça devenait un peu too much a corriger, j'ai abandonné le base 64 dans outlook
c’était déjà le cas a vec 2007

sans parler des versions outlook apres 2007 qui ont pris un grand tournant en terme d'accès par code vb
les versions actuelles d'outlook en mode html5 n’acceptent pas le style css sur une image on passe par des objects shapes(similaires au shapes de excel)
si tu cherche bien je montre comment on code ça dans les ressources
sinon juste la balise "IMG" sans style avec le src vers le fichier ATTACHE!!!!
microsoft a beaucoup travaillé sur l'autre mode qui consiste a travailler avec le document.inspector et les range comme dans word quasiment

voilà tu sais quasiment tout

fanch55 · 18 Mars 2023

Bonjour,
Si j'ai bien compris votre besoin, testez le code ci-dessous

VB:

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

Sub Exemple()
Dim Signature As String
    Signature = "Moi Gmail"  ' 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 = "exemple@adresse.com"
            .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 la plage de cellules que vous avez demandée :" & _
                            "<br><br>"
                Wedi.Content.InsertParagraphAfter
                Sheets("Feuil1").[B3:I32].CopyPicture
                Wedi.Paragraphs(2).Range.Paste
                  
                ' paragraphes 3 et 4
                .htmlbody = .htmlbody & _
                            "et la deuxième plage de cellules :" & _
                            "<br><br>"
                Wedi.Content.InsertParagraphAfter
                Sheets("Feuil2").ListObjects("Tableau1").Range.CopyPicture
                Wedi.Paragraphs(4).Range.Paste
                
                .htmlbody = .htmlbody & _
                            "Cordialement," & _
                            Signature
            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"

    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

looky62 · 21 Mars 2023

fanch55 à dit:

Bonjour,
Si j'ai bien compris votre besoin, testez le code ci-dessous

VB:

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

Sub Exemple()
Dim Signature As String
    Signature = "Moi Gmail"  ' 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 = "exemple@adresse.com"
            .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 la plage de cellules que vous avez demandée :" & _
                            "<br><br>"
                Wedi.Content.InsertParagraphAfter
                Sheets("Feuil1").[B3:I32].CopyPicture
                Wedi.Paragraphs(2).Range.Paste
                 
                ' paragraphes 3 et 4
                .htmlbody = .htmlbody & _
                            "et la deuxième plage de cellules :" & _
                            "<br><br>"
                Wedi.Content.InsertParagraphAfter
                Sheets("Feuil2").ListObjects("Tableau1").Range.CopyPicture
                Wedi.Paragraphs(4).Range.Paste
               
                .htmlbody = .htmlbody & _
                            "Cordialement," & _
                            Signature
            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"

    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

Un grand merci nickel c'est ce que je cherchais

Effectuez une recherche sur Excel Downloads...

Microsoft 365 creation mail av capture ecran plage définie

looky62

XLDnaute Occasionnel

looky62

kiki29

XLDnaute Barbatruc

Oneida

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

Pièces jointes

looky62

XLDnaute Occasionnel

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums