Paste pivot table as bitmap into Body of Outlook Appointment

Question

Using Excel VBA, I'd like to make a small pivot table visible to Outlook users.

I do NOT want to paste into a message body
I DO want to paste into an appointmentItem Here is my code that creates the Appointment and copies Range to clipboard. How do I paste it into Oapt.Body? (there is no Oapt.HTMLbody)

Option Explicit

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`

`I've been writing Excel VBA for years, but never used Outlook at all.` Well, [THIS](http://www.rondebruin.nl/win/s1/outlook/bmail2.htm) will get you started... Try it out and if you are stuck then post the code that you tried with the error messages if any and then we will take it from there — Siddharth Rout, Jun 16 '15 at 20:23
Respectful thanks, and my apology for being unclear. I hope my edited question shows I have everything in place except for a single line of code that must paste a bitmap image from the clipboard into the body of an Appointment Item (NOT into an email body - that is already well-documented) — Steve E Weeks, Jun 17 '15 at 09:37
posted an answer. You may have to refresh the page to see it :) — Siddharth Rout, Jun 17 '15 at 11:37

score 0 · Accepted Answer · edited May 23 '17 at 11:58

0

First of all, take a look at the following articles to get started with Outlook objects:

There are several ways to insert an image to the mail item in Outlook. One of them is to use the Word object model which provides the Paste/PasteSpecial methods.

The WordEditor property of the Inspector class returns an instance of the Word Document class which represents the message body. Read more about that in the Chapter 17: Working with Item Bodies.

The other way is to add an embedded (hidden) attachment and then add a reference to the attached image in the body (using the cid attribute). See How to add an embedded image to an HTML message in Outlook 2010 for more information.

And finally yet another way is to specify the image as a Base64 string.

edited May 23 '17 at 11:58

Community

1
1

answered Jun 16 '15 at 20:41

Eugene Astafiev

47,483
3
24
45

Respectful thanks to @EugeneAstafiev, and my apology for being unclear. I hope my edited question shows I have everything in place except for a single line of code that must paste a bitmap image from the clipboard into the body of an Appointment Item (NOT into an email body - that is already well-documented) – Steve E Weeks Jun 17 '15 at 09:39
I also realise that your answer is good!!
It worked for @AndresFelipeMartinez [in THIS article](http://stackoverflow.com/questions/29809721/paste-formatted-excel-range-into-outlook-task?rq=1) – Steve E Weeks Jun 17 '15 at 09:44
As you say, MSDN may have the answer [here](https://msdn.microsoft.com/en-us/library/dd492012(v=office.12).aspx#Outlook2007ProgrammingCh17_AddingTextToAnItem) in section 17.5.4 of "Working with Item Bodies" but I am still concerned this applies to an email body, not an appointment body? – Steve E Weeks Jun 17 '15 at 10:27
wow - Outlook **crashed** when I pasted a picture into an appointment instead of an email message. ` Set objInsp = Oapt.GetInspector Set objDoc = objInsp.WordEditor Set objSel = objDoc.Windows(1).Selection objSel.InlineShapes.AddPicture strfile, False, True` – Steve E Weeks Jun 17 '15 at 10:40
Was the inspector window opened? Anyway, appointment items are based on the RTFBody property. It looks like you need to use the rtf markup for adding images. See [Programatically adding Images to RTF Document](http://stackoverflow.com/questions/1490734/programatically-adding-images-to-rtf-document) for more information. – Eugene Astafiev Jun 17 '15 at 11:04
Thank you. I just found `RTFbody` in the Object Browser,.. will follow your lead. **Much Appreciated.** – Steve E Weeks Jun 17 '15 at 11:33

Steve E Weeks · Answer 2 · 2015-06-27T05:43:18.260

SHORT: added "Oapt.Display" before SENDKEYS Ctrl-V

LONG EXPLANATION:

The two solutions offered were much appreciated. The idea of using the MSWord class is the "Correct" one, but too difficult for me! The idea of using SENDKEYS to paste the image is MUCH easier to do, but indeed does go wrong with timing issues. If the new Outlook appointment does not become the current 'in focus' window, then the image gets pasted over the top of the Pivot Table. Horrible.

Adding "Oapt.Display" is my attempt to improve things by ensuring the Outlook App is the "Window in Focus" before the paste takes place. I'm trying to wait for the right moment.

It's not the most elegant method, but it now works, ..most of the time!

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

Paste pivot table as bitmap into Body of Outlook Appointment

2 Answers2