Question

使用Excel VBA，我想让一个小的数据透视表对Outlook用户可见。

我 NOT 想要粘贴到邮件正文中我想粘贴到 appointmentItem 这是我的代码，用于创建约会并将范围复制到剪贴板。如何将其粘贴到 Oapt.Body？ （没有Oapt.HTMLbody）

选项明确

method()

Answer 1

首先，请查看以下文章以开始使用Outlook对象：

有多种方法可以将图像插入Outlook中的邮件项目。其中之一是使用提供Paste / PasteSpecial方法的Word对象模型。

Inspector类的WordEditor属性返回表示邮件正文的Word Document类的实例。在Chapter 17: Working with Item Bodies中详细了解相关内容。

另一种方法是添加嵌入（隐藏）附件，然后在正文中添加对附加图像的引用（使用cid属性）。有关详细信息，请参阅How to add an embedded image to an HTML message in Outlook 2010。

最后另一种方法是将图像指定为Base64字符串。

Answer 2

简短：添加＆＃34; Oapt.Display＆＃34;在SENDKEYS Ctrl-V之前

长期解释：

提供的两个解决方案非常受欢迎。使用MSWord类的想法是＆＃34;正确＆＃34;一个，但对我来说太难了！使用SENDKEYS粘贴图像的想法要容易得多，但确实会出现时序问题。如果新的Outlook约会未成为当前关注的焦点＆＃39;窗口，然后图像粘贴在数据透视表的顶部。可怕。

添加＆＃34; Oapt.Display＆＃34;是我通过确保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

将数据透视表作为位图粘贴到Outlook预约的正文中

2 个答案: