這會給你創建收件人列表你。
EmailTo = getRecipients（1）
EmailCC = getRecipients（2）
Function getRecipients(vColumn As Variant) As String
Dim rListColumn As Range
Dim c As Range
Dim s As String
With Worksheets("Email Recipient List")
Set rListColumn = .Range(.Cells(2, vColumn), .Cells(Rows.Count, vColumn).End(xlUp))
For Each c In rListColumn
s = s & c.Text & ";"
Next
getRecipients = Left(s, Len(s) - 1)
End With
End Function
我沒看到，你會得到一個變量沒有定義的錯誤。如果getRecipients在一個私人模塊中，你會得到一個子或函數未定義的錯誤。
我重構我們的代碼。請在代碼模塊中自行運行ComposeEmail。
Option Explicit
Public Sub ComposeEmail()
ToggleEvents False
Dim EmailTo As String, CC As String, BCC As String, Subject As String, HTMLBody As String, ShowEmail As Boolean
Dim rng As Range
ToggleEvents False
Set rng = Sheets("Email Form").Range("A1:AB119")
EmailTo = getRecipients(1)
CC = getRecipients(2)
'BCC = getRecipients(2)
Subject = Range("H6").Value & " - " & "SAC" & Range("G12").Value & " - " & Range("G14").Value & " - " & Range("H8").Value
HTMLBody = RangetoHTML2(rng)
ShowEmail = True
SendMail EmailTo, CC, BCC, Subject, HTMLBody, ShowEmail
' ThisWorkbook.Close True 'This Line save and Closes the workbook
ToggleEvents True
End Sub
Function getRecipients(vColumn As Variant) As String
Dim rListColumn As Range
Dim c As Range
Dim s As String
With Worksheets("Email Recipient List")
Set rListColumn = .Range(.Cells(2, vColumn), .Cells(Rows.Count, vColumn).End(xlUp))
For Each c In rListColumn
s = s & c.Text & ";"
Next
getRecipients = Left(s, Len(s) - 1)
End With
End Function
Public Sub SendMail(EmailTo As String, CC As String, BCC As String, Subject As String, HTMLBody As String, ShowEmail As Boolean)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = EmailTo
.CC = CC
.BCC = BCC
.Subject = Subject
.HTMLBody = HTMLBody
If ShowEmail Then
.Display
Else
.Send
End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
EmailCouldNotBeCreated:
MsgBox "Email could not be created", vbCritical, "Error in Sub SendMail"
End Sub
Sub ToggleEvents(bEnableEvents As Boolean)
With Application
.EnableEvents = bEnableEvents
.ScreenUpdating = bEnableEvents
End With
End Sub
' https://msdn.microsoft.com/en-us/library/ff519602%28v=office.11%29.aspx?f=255&MSPPError=-2147217396
Function RangetoHTML2(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
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 workbook to receive the data.
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 an .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 the RangetoHTML subroutine.
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.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
謝謝你的快速反應。我將函數添加到模塊中，並將子項中的To和CC替換爲EmailTo和EmailCC，但我無法使其工作。我收到錯誤「變量未定義」。我試圖通過Dim EmailTo將其定義爲字符串（等），但沒有奏效。我有點困惑如何做到這一點。請指教。乾杯 – TheShyButterfly