Персональный макрос не работает: выбор диапазона и вставка в текст электронной почты Outlook

Question

Собирая воедино этот код, я смог правильно его настроить. Думая, что я закончил, я отправил его кому-то, кто пытался добавить его в качестве личного макроса, и тогда мы поняли, что это не сработало. Чтобы проверить, я добавил его в качестве личного макроса на своем компьютере, и он все еще не работал.

Я слепо пробовал несколько добавлений кода, таких как ChartObject.Activate после ThisWorkbook.Activate, но безуспешно.

Sub RangeToEmailBody()

        Dim TempFilePath As String
        Dim xOutApp As Object
        Dim xOutMail As Object
        Dim xHTMLBody As String
        Dim xRg As Range
        On Error Resume Next
        Set xRg = Application.InputBox(prompt:="Please select the data range:", Type:=8)
        If xRg Is Nothing Then Exit Sub
        With Application
            .Calculation = xlManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        Set xOutApp = CreateObject("outlook.application")
        Set xOutMail = xOutApp.CreateItem(olMailItem)

        Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
        TempFilePath = Environ$("temp") & "\"
        xHTMLBody = "<span LANG=EN>" _
                & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
                & "<img src='cid:DashboardFile.jpg'>"
        With xOutMail
            .Subject = ""
            .HTMLBody = xHTMLBody
          .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
            .To = " "
            .Cc = " "
            .Display
        End With
End Sub

Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)

    Dim xRgPic As Range
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete

Set xRgPic = Nothing
End Sub

Я ожидаю, что выбранный диапазон будет отображаться в теле письма, но в качестве личного макроса внутри "картинки" нет содержимого.

Answer 1

Это предположение о проблеме. Если вы добавляете это в личный макрос, ThisWorkbook относится к личной книге. Я предполагаю, что ваш исходный диапазон находится в другой книге целиком.

Для упрощения я бы сделал что-то вроде этого, используя временную новую рабочую книгу:

Sub createJpg(rng As Range, nameFile As String)

    Dim tempChartObj As ChartObject
    Dim tempWb As Workbook

    Set tempWb = Workbooks.Add
    Set tempChartObj = tempWb.Sheets(1).ChartObjects.Add(rng.Left, rng.Top, rng.Width, rng.Height)

    rng.CopyPicture
    With tempChartObj
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With

    tempWb.Close SaveChanges:=False

End Sub

Затем назовите это так (заметьте, что Call не нужно):

createJpg xRg, "DashboardFile"