我正在努力做到以下幾點。下面的代碼一切正常，但被復制和粘貼的范圍位于電子郵件正文的上方，而我需要它在下方。任何建議表示贊賞。
Sub Email()
Dim OutApp As Outlook.Application
Dim OutMeet AS Outlook.Appointment
Dim x as Integer
Set OutApp = Outlook.Application
Set OutMeet = OutApp.CreateItem(olAppointmentItem)
Const wdPASTERTF as Long = 1
RowCount = Range("").Value
With OutMeet
For x = 1 To Range("")
If Cells (x, 1) = "Yes" Then
.Recipients.Add Celss (x,2)
Else
End If
Next x
With OutMeet
.Body = "Hi"
Range(Cells(3,12), Cells(RowCount 2, 24)).Select
Selection.Copy
.Display
.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With
End With
End Sub
uj5u.com熱心網友回復：
如果我在正文之后添加范圍和專案，我會將新專案附加到舊專案上，這樣我就可以控制順序，HTMLBody而不僅僅是使用Body：
.HTMLBody = _
"<HTML><body>All;<br><br>" & _
"Text " & singleCellValue & ".<br><br></body></HTML>"
.HTMLBody = .HTMLBody & CopyRangeToHTML(rangeOfCells)
一些注意事項：
- 取自某個范圍的單個值可以包含在文本中的任何位置，例如，
singleCellValue - 雙 HTML 中斷被加倍為 1）讓你到下一行，和 2）添加另一行......我不傾向于有間距縮進，所以如果你這樣做，請記住這一點
- a 的使用
rangeOfCells是通過一個函式執行的，該函式對舊的 Rob de Bruin 函式稍作修改，以允許復制條件格式：
Private Function CopyRangeToHTML(ByVal n As Range)
Dim fso As Object, ts As Object, temp As String
Dim wbs As Workbook: Set wbs = n.Worksheet.Parent
temp = Environ$("temp") & "/" & Format(Now, "yyyyMMddHHmmss") & ".htm"
With wbs.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=temp, Sheet:=n.Worksheet.Name, Source:=n.Address, HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(temp).OpenAsTextStream(1, -2)
CopyRangeToHTML = ts.ReadAll
ts.Close
Kill temp
Set ts = Nothing
Set fso = Nothing
Set wbs = Nothing
End Function
uj5u.com熱心網友回復：
通過設定您的范圍和收件人來修改CreateAppointment程式。閱讀評論以獲得更好的理解。您的范圍將被復制到帶有RangetoHTML的 htm 臨時檔案。
為了創建 HTML 格式的約會，會在后臺以這種格式創建臨時電子郵件，然后將其內容復制到約會中。
Public Sub CreateAppointment()
Dim olApp As Object ' Outlook application
Dim olApt As Object ' Outlook Appointment Item
Dim olMail As Object ' Outloot Mail Item
Dim greetings As String
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
Set olApt = olApp.CreateItem(olAppointmentItem)
' Define your range HERE
Dim rangeOfCells As Range: Set rangeOfCells = ActiveSheet.ListObjects(1).Range
' Greetings
greetings = "Hi," & vbCrLf
With olApt
.Display
.Start = Date & " 09:10"
.Duration = 90
.Subject = "Report XXX"
.Location = "Office - XX"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Put the HTML into the mail item, then copy and paste to appt
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
olMail.BodyFormat = olFormatHTML
' Copy rante to mail body
olMail.HTMLBody = greetings & RangetoHTML(rangeOfCells)
' Copy from mail
olMail.GetInspector().WordEditor.Range.FormattedText.Copy
' Paste mail in Appointment
olApt.GetInspector().WordEditor.Range.FormattedText.Paste
' Close mail without saving
olMail.Close False
' Uncomment line bellow to save appointment
'.Save
End With
Set olMail = Nothing
Set olApt = Nothing
Set olApp = Nothing
End Sub
Function RangetoHTML(Rng As Range)
' Ron de Bruin: https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
fileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/329798.html
下一篇：將作業簿中的整列粘貼到本地列