Вставьте сводную таблицу как растровое изображение в тело Outlook Outlook

Question

Используя Excel VBA, я хотел бы сделать небольшую сводную таблицу видимой для пользователей Outlook.

Я не хочу вставлять в тело сообщения
Я действительно хочу вставить в назначение. Вот мой код, который создает назначение и копирует диапазон в буфер обмена. Как мне вставить его в Oapt.Body? (Oapt.HTMLbody нет)

Вариант Явный

Public Sub DailySummary()
     Dim errorMsg As String
'library references are set, this is early binding technique:
    Dim Oapp As Outlook.Application
    Dim Onsp As Namespace
    Dim OcaF As Outlook.Folder
    Dim Oapt As AppointmentItem

    Sheets("DailySummary").Select

    errorMsg = "Get/CreateObject(""Outlook.Application"") - Failed"
    On Error Resume Next
     Set Oapp = GetObject("Outlook.Application")            'assume Outlook is running
    If Error <> 0 Then                                      'if Outlook NOT running
         Set Oapp = CreateObject("Outlook.Application")     'get Outlook running
    End If
    On Error GoTo err

    errorMsg = "oApp.GetNamespace(""MAPI"") - Failed"
     Set Onsp = Oapp.GetNamespace("MAPI")

    On Error GoTo 0
    errorMsg = "Oapp.CreateItem(olAppointmentItem) - Failed"
     Set Oapt = Oapp.CreateItem(olAppointmentItem)

    errorMsg = "Set Up AppointmentItem - Failed"
    With Oapt
        .Subject = "SPC Daily Summary"
        .Start = Range("B6").Value + 0.3333333 '8am on the date in B6 in the PT.
        .Duration = 60
        .AllDayEvent = False
        .Importance = olImportanceNormal
        .Location = "St Paul's Centre"
        .Body = "Team SPC Daily Duties"
        .ReminderSet = True
        .ReminderMinutesBeforeStart = "60"
        .ReminderPlaySound = True
        .ReminderSoundFile = "C:\Windows\Media\Ding.wav"
        .Attachments.Add Range("Downloads") & "\" & "TestAttachment.pdf", olByValue, 0
    ActiveSheet.PivotTables(1).TableRange1.CopyPicture xlScreen, xlBitmap
        .Body = RangetoHTML(Worksheets("DailySummary").Range("B5:K20"))

'--------------------------------------------------------------------------
' here's where I am STUCK!
' how do I paste into the body of the "olAppointmentItem" ?
'--------------------------------------------------------------------------

        errorMsg = "cannot Save appointment"
        '.Display
        .Save
    End With

    MsgBox "Appointment Created:" & vbCr & vbCr & _
            "App: " & Oapp & ", Namespace: " & Onsp & vbCr & _
            "Apointment: " & Oapt.Subject & vbCr & _
            "                       " & Oapt.Start, _
            vbOK, "SPC Bookings"
'Happy Ending
    GoTo exitsub
'Unhappy ending
Err:
    MsgBox err.Number & " " & errorMsg, vbCritical, "SPC Bookings"
Exitsub:
    Set Oapp = Nothing
    Set Onsp = Nothing
    Set Oapt = Nothing
End Sub`

Answer 1

Прежде всего, взгляните на следующие статьи, чтобы начать работу с объектами Outlook:

• Как автоматизировать Outlook из другой программы
• Начало работы с VBA в Outlook 2010

Есть несколько способов вставить изображение в почтовый элемент в Outlook. Одним из них является использование объектной модели Word, которая предоставляет методы Paste/ PasteSpecial.

Свойство WordEditor класса Inspector возвращает экземпляр класса Word Document, который представляет тело сообщения. Подробнее об этом читайте в главе 17: Работа с телами предметов.

Другой способ - добавить вложенное (скрытое) вложение, а затем добавить ссылку на прикрепленное изображение в теле (используя атрибут cid). См. Как добавить встроенное изображение в сообщение HTML в Outlook 2010 для получения дополнительной информации.

И, наконец, еще один способ - указать изображение в виде строки Base64.

Answer 2

КРАТКИЕ СВЕДЕНИЯ: добавленоOapt.Display"перед отправкой клавиш Ctrl-V

ДОЛГОЕ ОБЪЯСНЕНИЕ:

Два предложенных решения были высоко оценены. Идея использования класса MSWord является "правильной", но слишком сложной для меня! Идея использования SENDKEYS для вставки изображения НАМНОГО проще, но она действительно ошибается с проблемами синхронизации. Если новая встреча Outlook не становится текущим окном "в фокусе", изображение вставляется поверх сводной таблицы. Какой ужас.

Добавление "Oapt.Display"Я пытаюсь улучшить ситуацию, убедившись, что приложение Outlook - это" окно в фокусе "до того, как произойдет вставка. Я пытаюсь дождаться подходящего момента.

Это не самый элегантный метод, но сейчас он работает... большую часть времени!

Option Explicit
Public Sub DailySummary()

    Dim errorMsg As String

    'set library references, this is early binding technique:
    Dim sBod As String
    Dim oApp As Outlook.Application
    Dim oNsp As Namespace
    Dim oFol As Outlook.Folder
    Dim oAps As Object                  'I believe this is a collection of appointments
    Dim oApt As AppointmentItem

    Sheets("DailySummary").Select

    errorMsg = "Get/CreateObject(""Outlook.Application"") - Failed"
    On Error Resume Next
     Set oApp = GetObject("Outlook.Application")            'assume Outlook is running
    If Error <> 0 Then                                      'if Outlook NOT running
         Set oApp = CreateObject("Outlook.Application")     'get Outlook running
    End If
    On Error GoTo err

    errorMsg = "oApp.GetNamespace(""MAPI"") - Failed"
    Set oNsp = oApp.GetNamespace("MAPI")

    errorMsg = "oNsp.GetDefaultFolder(olFolderCalendar) - Failed"
    Set oFol = oNsp.GetDefaultFolder(olFolderCalendar)
    'MsgBox "There are: " & oFol.Items.Count & " calendar items"


    sBod = vbCr & "Created: " & Format(Now, "dddd dd mmmm yyyy")
    Dim mRes As VbMsgBoxResult
    Dim oObject As Object
    Dim i As Integer
    i = 0
    For Each oObject In oFol.Items
        If oObject.Class = olAppointment Then
            Set oApt = oObject
            If (InStr(oApt.Subject, "SPC Daily Summary") > 0 And Int(oApt.Start) = Int(Range("$B$6").Value)) Then
              mRes = vbYes
'             mRes = MsgBox("Appointment found:-" & vbCrLf & vbCrLf _
                   & Space(4) & "Date/time: " & Format(oApt.Start, "dd/mm/yyyy hh:nn") _
                   & " (" & oApt.Duration & "mins)" & Space(10) & vbCrLf _
                   & Space(4) & "Subject: " & oApt.Subject & Space(10) & vbCrLf _
                   & Space(4) & "Location: " & oApt.Location & Space(10) & vbCrLf & vbCrLf _
                   & "Delete this appointment?", vbYesNo + vbQuestion + vbDefaultButton2, "Delete Appointment?")
              If mRes = vbYes Then
                oApt.Delete
                sBod = vbCr & "Updated: " & Format(Now, "dddd dd mmmm yyyy")
                i = i + 1
              End If
            Else
              'MsgBox "NOT DELETING: " & oApt.Start & " " & Int(Range("$B$6").Value)
            End If
        End If
    Next oObject

    On Error GoTo 0
    errorMsg = "Oapp.CreateItem(olAppointmentItem) - Failed"
     Set oApt = oApp.CreateItem(olAppointmentItem)

    errorMsg = "Set Up AppointmentItem - Failed"
    With oApt
        .Subject = "SPC Daily Summary for " & Format(Range("$B$6").Value, "dddd dd mmmm yyyy")
        .Start = Range("B6").Value + 0.3333333  ' 8am on the date in B6 in the PT.
        .Duration = 60
        .AllDayEvent = False
        .Importance = olImportanceNormal
        .Location = "St Paul's Centre"
        .Body = sBod & vbCr
        .ReminderSet = True
        .ReminderMinutesBeforeStart = "60"
        .ReminderPlaySound = True
        .ReminderSoundFile = "C:\Windows\Media\Ding.wav"

        errorMsg = "cannot Save appointment"
        ActiveSheet.PivotTables(1).TableRange1.CopyPicture xlScreen, xlBitmap

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' WARNING - THIS ONLY WORKS IF OUTLOOK POPS UP AT THE RIGHT TIME!
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        oApt.Display
        DoEvents
        .Display    'to reduce risk, let's wait three seconds after we display the Outlok Appointment!
        DoEvents
        SendKeys "^v"
        DoEvents
        waitasec
        .Save
        .Close (olSave)

    End With

    MsgBox "There are: " & oFol.Items.Count & " calendar items." & vbCr & "We deleted: " & i & " calendar items" & vbCr & "We created: 1"

'    MsgBox "Appointment Created:" & vbCr & vbCr & _
            "App: " & Oapp & ", Namespace: " & Onsp & vbCr & _
            "Apointment: " & Oapt.Subject & vbCr & _
            "                       " & Oapt.Start, _
            vbOK, "SPC Bookings"
'Happy Ending
    GoTo exitsub
'Unhappy ending
err:
    MsgBox err.Number & " " & errorMsg, vbCritical, "SPC Bookings"
exitsub:
    Set oAps = Nothing
    Set oApp = Nothing
    Set oNsp = Nothing
    Set oFol = Nothing
    Set oApt = Nothing
    Set oObject = Nothing
End Sub