问题描述
我要根据Excel工作表中的选择发送模板电子邮件。
我想从工作表的下拉菜单中选择哪个电子邮件模板和主题行。如果为空，我想跳过。
带有下拉选项的范围。
Dim cellrange As Range,cell As Range
Set cellrange = Range("H3:H500")
我经常使用PowerShell和其他脚本语言。我的VBA曝光量有限。
我为不同的电子邮件模板和主题行创建了变量。我还找到了将发送电子邮件的代码。那部分看起来还可以。
我收到一封电子邮件，而不是根据工作表中的选择遍历多封电子邮件。
我将电子邮件模板和主题行设置在另一个工作表中的某个范围内，并为它们创建了变量。
Set delivery = Sheets("EmailTemplates").Range("A5:A40")
Set address = Sheets("EmailTemplates").Range("A50:A90")
Set deliverysub = Sheets("EmailTemplates").Range("B2")
Set addresssub = Sheets("EmailTemplates").Range("B50")
我还将为会议模板和主题行创建此内容。我一直在尝试使其首先与这两个一起使用，并获得各种各样的结果。
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim delivery As Range
Dim shipping As Range
Dim meeting As Range
Dim address As Range
Dim deliverysub As Range
Dim shippingsub As Range
Dim meetingsub As Range
Dim addresssub As Range
Dim template As Range
Set delivery = Sheets("EmailTemplates").Range("A5:A40")
Set address = Sheets("EmailTemplates").Range("A50:A90")
Set deliverysub = Sheets("EmailTemplates").Range("B2")
Set addresssub = Sheets("EmailTemplates").Range("B50")
Set rng = nothing
On Error Resume Next
Dim cellrange As Range,cell As Range
Set cellrange = Range("H3:H500")
For Each cell In cellrange
If cell.Value = "" Then
Next cell
ElseIf cell.Value = "Delivery" Then
Set rng = delivery
Set SubjectLine = deliverysub
ElseIf cell.Value = "Shipping" Then
Set rng = address
Set SubjectLine = addresssub
ElseIf cell.Value = "Meeting" Then
Set rng = meeting
Set SubjectLine = meetingsub
End If
Next cell
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = SubjectLine
.HTMLBody = RangetoHTML(rng)
.SEND 'or use .display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = nothing
Set OutApp = nothing
End Sub
Function RangetoHTML(rng As Range)
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
.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 rng = nothing
Set ts = nothing
Set fso = nothing
Set TempWB = nothing
End Function
End Sub
解决方法
更像这样：
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet,wsTemplates As Worksheet
Dim cell As Range,subj As String
Set ws = ActiveSheet
Set wsTemplates = ThisWorkbook.Worksheets("EmailTemplates")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In ws.Range("H3:H500").Cells
'What type of template are we using?
Select Case cell.Value
Case "Delivery"
Set rng = wsTemplates.Range("A5:A40")
subj = wsTemplates.Range("B2")
Case "Shipping"
Set rng = wsTemplates.Range("A50:A90")
subj = wsTemplates.Range("B50")
Case "Meeting"
'etc etc
Case Else
Set rng = Nothing 'not sending anything
End Select
If Not rng Is Nothing Then 'sending?
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = subj
.HTMLBody = RangetoHTML(rng)
.SEND 'or use .Display
End With
End If
Next cell
End Sub