将枢轴 table 作为位图粘贴到 Outlook 约会正文中
Paste pivot table as bitmap into Body of Outlook Appointment
使用 Excel VBA，我想让 Outlook 用户可以看到一个小枢轴 table。
我不想粘贴到邮件正文中
我确实想粘贴到 appointmentItem
这是我创建 Appointment 并将 Range 复制到剪贴板的代码。
怎么粘贴到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`
首先，请查看以下文章以开始使用 Outlook 对象：
有几种方法可以将图像插入 Outlook 中的邮件项目。其中之一是使用提供 Paste/PasteSpecial 方法的 Word 对象模型。
检查器 class 的 WordEditor 属性 returns 表示邮件正文的 Word 文档 class 的实例。在 Chapter 17: Working with Item Bodies 中阅读更多相关信息。
另一种方法是添加嵌入（隐藏）附件，然后在正文中添加对附件图像的引用（使用 cid 属性）。有关详细信息，请参阅 How to add an embedded image to an HTML message in Outlook 2010。
最后还有一种方法是将图像指定为 Base64 字符串。
SHORT: 在 SENDKEYS Ctrl-V
之前添加了“Oapt.Display”
详细说明：
非常感谢提供的两个解决方案。使用 MSWord class 的想法是 "Correct" 一个，但对我来说太难了！使用 SENDKEYS 粘贴图像的想法更容易实现，但确实会在时间问题上出错。如果新的 Outlook 约会没有成为当前的 'in focus' window，则图像会粘贴到 Pivot Table 的顶部。太可怕了。
添加“Oapt.Display”是我尝试通过确保 Outlook 应用程序在粘贴之前是 "Window in Focus" 来改进内容。我正在努力等待合适的时机。
这不是最优雅的方法，但它现在有效，..大多数时候！
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").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").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").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
使用 Excel VBA，我想让 Outlook 用户可以看到一个小枢轴 table。
我不想粘贴到邮件正文中
我确实想粘贴到 appointmentItem
这是我创建 Appointment 并将 Range 复制到剪贴板的代码。
怎么粘贴到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`
首先，请查看以下文章以开始使用 Outlook 对象：
有几种方法可以将图像插入 Outlook 中的邮件项目。其中之一是使用提供 Paste/PasteSpecial 方法的 Word 对象模型。
检查器 class 的 WordEditor 属性 returns 表示邮件正文的 Word 文档 class 的实例。在 Chapter 17: Working with Item Bodies 中阅读更多相关信息。
另一种方法是添加嵌入（隐藏）附件，然后在正文中添加对附件图像的引用（使用 cid 属性）。有关详细信息，请参阅 How to add an embedded image to an HTML message in Outlook 2010。
最后还有一种方法是将图像指定为 Base64 字符串。
SHORT: 在 SENDKEYS Ctrl-V
之前添加了“Oapt.Display”
详细说明：
非常感谢提供的两个解决方案。使用 MSWord class 的想法是 "Correct" 一个，但对我来说太难了！使用 SENDKEYS 粘贴图像的想法更容易实现，但确实会在时间问题上出错。如果新的 Outlook 约会没有成为当前的 'in focus' window，则图像会粘贴到 Pivot Table 的顶部。太可怕了。
添加“Oapt.Display”是我尝试通过确保 Outlook 应用程序在粘贴之前是 "Window in Focus" 来改进内容。我正在努力等待合适的时机。
这不是最优雅的方法，但它现在有效，..大多数时候！
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").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").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").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