Makro in Excel macht Screenshot und schickt es als Mail, Bilder aber nicht erkannt

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von Baem.

    Makro in Excel macht Screenshot und schickt es als Mail, Bilder aber nicht erkannt

    Hallo zusammen,

    ich habe folgendes Problem..

    Ich habe ein Makro, welches mir einen Screenshot von einem bestimmten Bereich macht, anschließen eine neue Mail erstellt und diesen einfügt.

    Mein Problem dabei ist, dass in dem Screenshot auch 2 Bilder drinnen sein sollten und diese nicht angezeigt werden können. Habt ihr hier eine Idee? :-/

    Visual Basic-Quellcode

    1. Sub Versand()
    3. 'Versand Makro
    4. 'Dimensionen
    5. Dim oOutlookApp As Object, oOutlookMessage As Object
    6. Dim oFSObj As Object, oFSTextStream As Object
    7. Dim rngeSend As Range, strHTMLBody As String, strTempFilePath As String
    8. Dim ColIndex, RowIndex, Var1, Var2 As Integer
    9. Dim DatumSheet
    11. Sheets("Protokoll").Select
    12. 'Zählt wie viele Zellen kopiert werden sollen
    13. On Error Resume Next
    15. Range("B1:J41").Select
    16. Set rngeSend = Selection
    18. If rngeSend Is Nothing Then Exit Sub 'User pressed Cancel
    19. On Error GoTo 0
    21. 'Pfad für temporäre Datei
    22. Set oFSObj = CreateObject("Scripting.FilesystemObject")
    23. strTempFilePath = oFSObj.GetSpecialFolder(2)
    24. strTempFilePath = strTempFilePath & "\XLRange.htm"
    26. 'Hier wird die HTML-Datei erstellt
    27. ActiveWorkbook.PublishObjects.Add(4, strTempFilePath, _
    28. rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
    30. 'Outlook session öffnen
    31. Set oOutlookApp = CreateObject("Outlook.Application")
    33. 'Neue email
    34. Set oOutlookMessage = oOutlookApp.CreateItem(0)
    36. For i = 1 To 1 'Für einen Serienbrief muss hier der zweite um die jeweilige Briefanzahl erhöht werden.
    37. 'oOutlookMessage.To = Range("Formeln!A1").Value
    38. oOutlookMessage.To = "EMPFÄNGER DER MAIL"
    40. 'oOutlookMessage.Subject = Range("Formeln!A2").Value & " " & Mid(Time, 1, 2) & ":00 Uhr am " & Date
    41. oOutlookMessage.Subject = "Protokoll vom " & Range("H8")
    43. 'Die HTML-Datei wird geöffnet mit FilesystemObject
    44. Set oFSTextStream = oFSObj.OpenTextFile(strTempFilePath, 1)
    46. 'HTMLBody
    47. strHTMLBody = oFSTextStream.ReadAll
    49. oOutlookMessage.Htmlbody = strHTMLBody
    50. oOutlookMessage.Display
    51. 'oOutlookMessage.send
    52. Cells(1, 1).Select
    53. Next i
    55. ActiveWorkbook.Save
    57. End Sub


    Danke im Voraus und LG
    Benny

    Hallo Benny

    Das liegt daran das die Pfade zu den Bilder in der HTML relativ und nicht absolute hinterlegt sind.
    Siehe hier -> Excel VBA - convert range with pictures and buttons to HTML

    Ich habe dir das einmal in dein Code integriert.
    Gruss HenryV
    Spoiler anzeigen

    Visual Basic-Quellcode

    1. Sub Versand()
    3. 'Versand Makro
    4. 'Dimensionen
    5. Dim oOutlookApp As Object, oOutlookMessage As Object
    6. Dim oFSObj As Object, oFSTextStream As Object
    7. Dim rngeSend As Range, strHTMLBody As String, strTempFilePath As String, strTempFileFullPath As String
    8. Dim ColIndex, RowIndex, Var1, Var2, i As Integer
    9. Dim DatumSheet
    11. Sheets("Protokoll").Select
    12. 'Zählt wie viele Zellen kopiert werden sollen
    13. On Error Resume Next
    15. Set rngeSend = Range("B1:J41")
    17. If rngeSend Is Nothing Then Exit Sub 'User pressed Cancel
    18. On Error GoTo 0
    20. 'Pfad für temporäre Datei
    21. Set oFSObj = CreateObject("Scripting.FilesystemObject")
    22. strTempFilePath = oFSObj.GetSpecialFolder(2) & "\"
    23. strTempFileFullPath = strTempFilePath & "XLRange.htm"
    25. 'Hier wird die HTML-Datei erstellt
    26. Dim imgPrefix As String: imgPrefix = "Myimg"
    27. ActiveWorkbook.PublishObjects.Add(4, strTempFileFullPath, rngeSend.Parent.Name, rngeSend.Address, 0, imgPrefix, "").Publish True
    29. 'Outlook session öffnen
    30. Set oOutlookApp = CreateObject("Outlook.Application")
    32. 'Neue email
    33. Set oOutlookMessage = oOutlookApp.CreateItem(0)
    35. For i = 1 To 1 'Für einen Serienbrief muss hier der zweite um die jeweilige Briefanzahl erhöht werden.
    36. 'oOutlookMessage.To = Range("Formeln!A1").Value
    37. oOutlookMessage.To = "EMPFÄNGER DER MAIL"
    39. 'oOutlookMessage.Subject = Range("Formeln!A2").Value & " " & Mid(Time, 1, 2) & ":00 Uhr am " & Date
    40. oOutlookMessage.Subject = "Protokoll vom " & Range("H8")
    42. 'Die HTML-Datei wird geöffnet mit FilesystemObject
    43. Set oFSTextStream = oFSObj.OpenTextFile(strTempFileFullPath, 1)
    45. 'HTMLBody
    46. strHTMLBody = oFSTextStream.ReadAll
    48. Dim j As Integer
    49. Dim strData() As String
    50. strData() = Split(strHTMLBody, vbCrLf)
    52. '~~> Loop through the file
    53. For j = LBound(strData) To UBound(strData)
    54. '~~> Here we will first get the image names
    55. If InStr(1, strData(j), "Myimg_", vbTextCompare) And InStr(1, strData(j), ".png", vbTextCompare) Then
    56. '~~> Insert actual path to the images
    57. Debug.Print strData(j)
    58. strData(j) = Replace(strData(j), "XLRange-Dateien/", strTempFilePath & "XLRange-Dateien/")
    59. Debug.Print strData(j)
    60. End If
    61. Next j
    62. '~~> Rejoin to get the new html string
    63. strHTMLBody = Join(strData, vbCrLf)
    65. oOutlookMessage.HTMLBody = strHTMLBody
    66. oOutlookMessage.Display
    67. 'oOutlookMessage.send
    68. Cells(1, 1).Select
    69. Next i
    71. ActiveWorkbook.Save
    73. End Sub

Facebook
Telefonspende