电子邮件正文中间的范围 [英] Range in Middle of the email body
本文介绍了电子邮件正文中间的范围的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我正在编写一个可以在电子邮件正文中间获取范围/选择的代码。以下代码对我来说有点不错，它没有捕获电子邮件正文中间的所需范围。这将节省我的手动工作时间。
I am working on a Code which can get the range/selection in the middle of the email body. The below code works a bit fine for me it does not captures the desired range in the middle of the email body. This will save my time to work manually.
Sub Selection_email()
Dim bStarted As Boolean
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olMailItm As Object: Set olMailItm = olApp.CreateItem(0)
Dim rngTo As Range
Dim rngSubject As Range
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With Active Sheet
Set rngTo = .Rng("E3")
Last = ActiveSheet.Cells(2, 4).Value
End With
With oItem
.SentOnBehalfOfName = ""
.To = rngTo.Value
.Cc = ""
.Subject = "" & Last & ""
.body = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
**HERE I NEED THE CODE TO PASTE THE RANGE FROM THE EXCEL FILE IT SHOULD BE FROM "A1:D6"**
"Thank you for your cooperation."
.Display.
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub
推荐答案
Option Explicit
Sub Selection_email()
Dim bStarted As Boolean
Dim olApp As Object
Dim oItem As Outlook.MailItem
Dim olMailItm As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim Last As Variant
Dim htmlString As String
Dim beginBody, endBody As String
Dim oOutlookApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With ActiveSheet
Set rngTo = .Range("E3")
Last = ActiveSheet.Cells(2, 4).Value
End With
'create the HTML table first --
' this builds a string with proper HTML header info
htmlString = RangetoHTML(ActiveSheet.Range("A1:D6"))
'now add the email greeting to the body information
beginBody = Left(htmlString, InStr(1, htmlString, "<body>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "<body>", vbTextCompare) + 5)
htmlString = beginBody & _
"Hello,<br><br>Welcome to My World<br><br>" & _
endBody
'now find the end of the table and add the signoff message
beginBody = Left(htmlString, InStr(1, htmlString, "</div>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "</div>", vbTextCompare) + 5)
htmlString = beginBody & _
"<br><br>Thank you for your cooperation." & _
endBody
With oItem
.SentOnBehalfOfName = ""
.To = rngTo.Value
.CC = ""
.Subject = "" & Last & ""
.HTMLBody = htmlString
.Display
End With
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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"
'Copy the range and create a new workbook to past the data in
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
'Publish the sheet to a htm file
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
'Read all data from the htm file into RangetoHTML
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=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
这篇关于电子邮件正文中间的范围的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
