Excel发送电子邮件 [英] Excel to send emails
本文介绍了Excel发送电子邮件的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我有一个Excel，可以发送电子邮件，其中包含工作表列表的列(酒店)中所有具有相同名称的行.
Hi I have an excel that sends an email with all rows with the same name in column (hotel) from sheet list.
我希望用户可以在工作表:菜单中选择发送哪些列以及如何排序数据.用户还可以在表格和电子邮件主题之前和之后的正文中定义文本.
I wanted the user to have the possibility to choose which columns are sent and how the data is ordered, in sheet: menu. Also the user can define a text in the body before and after the table and the subject of the email.
宏运行良好，但现在我想在电子邮件中使用"Operador"列，并且发送的电子邮件发送得不好，Operador的值不正确，日期采用另一种格式:
The macro was working well but now I want to use column "Operador" in the email and the email sent isnt sending well, Operador doesnt have right value and dates are in another format:
excel文件在这里: https://www.dropbox.com/s/d5b2wc3w5db2m01/Email％20das％20reservas.xlsm?dl = 1
The excel file is here: https://www.dropbox.com/s/d5b2wc3w5db2m01/Email%20das%20reservas.xlsm?dl=1
VBA在这里:
Sub btnSendMails()
Dim objOutlook As Outlook.Application
Dim strTo As String
Dim strCc As String
Dim strSubject As String
Dim strBody As String
Dim shtMain As Worksheet
Dim shtMails As Worksheet
Dim shtMenu As Worksheet
Dim shtTmp As Worksheet
Dim iLastRow As Long
Dim iLastColumn As Integer
Dim sHotelName As String
Dim iCl As Integer
Dim myArr() As String
Dim iColumn As Integer
Dim iRow As Long
Dim rng As Range
Dim iHotel As Integer
Set shtMain = Sheets("list")
Set shtMails = Sheets("hotels")
Set shtMenu = Sheets("menu")
Set shtTmp = Sheets("tmp")
Set objOutlook = CreateObject("Outlook.Application")
Dim iPos As Integer
iLastRow = shtMain.Cells(shtMain.Rows.Count, "B").End(xlUp).Row
iLastColumn = shtMenu.Cells(3, shtMenu.Columns.Count).End(xlToLeft).Column
ilastrowmail = shtMails.Cells(shtMails.Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
shtMain.Range("A1:AO" & iLastRow).Sort key1:=shtMain.Range("B1:N" & iLastRow), _
order1:=xlAscending, Header:=xlYes
ReDim Preserve myArr(5)
j = 0
shtTmp.Cells.ClearContents
For iCl = 2 To 41
If shtMain.Cells(1, iCl) = "Hotel" Then
iHotel = iCl
Exit For
End If
Next iCl
For i = 3 To iLastColumn
myArr(j) = UCase(shtMenu.Cells(3, i))
j = j + 1
ReDim Preserve myArr(j)
Next i
For i = 0 To UBound(myArr)
shtTmp.Cells(1, i + 1) = myArr(i)
Next i
For i = 2 To iLastRow
If InStr(shtMain.Cells(i, iHotel), "(") = 0 Then
iPos = 50
Else
iPos = InStr(shtMain.Cells(i, iHotel), "(")
End If
sHotelName = Left(shtMain.Cells(i, iHotel), iPos - 2)
iRow = 2
For j = i To iLastRow
iColumn = 1
For iCl = 1 To 41
If IsInArray(UCase(shtMain.Cells(1, iCl)), myArr) Then
shtTmp.Cells(1, iColumn) = shtMain.Cells(1, iCl)
shtTmp.Cells(iRow, iColumn) = shtMain.Cells(j, iCl)
If shtTmp.Cells(1, iColumn) = "Obs" Then shtTmp.Cells(iRow, iColumn) = shtTmp.Cells(iRow, iColumn) & vbNewLine
iColumn = iColumn + 1
End If
Next iCl
shtTmp.Cells(iRow, 1) = sHotelName
On Error GoTo Resume1
If Left(shtMain.Cells(j + 1, iHotel), iPos - 2) = sHotelName Then
iRow = iRow + 1
Else
Resume1:
For r = 2 To ilastrowmail
If UCase(sHotelName) = UCase(shtMails.Cells(r, 3)) Then
strTo = shtMails.Cells(r, 4)
Exit For
End If
Next r
If strTo = "" Then
MsgBox "Email not found for " & sHotelName & vbNewLine & "Macro will resume."
Else
Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr)))
strSubject = shtMenu.Cells(13, 3)
strBody = shtMenu.Cells(7, 3) & "<br>" & RangetoHTML(rng) & "<br>" & shtMenu.Cells(10, 3)
Call createMail(objOutlook, strTo, strSubject, strBody)
End If
strTo = ""
shtTmp.Cells.ClearContents
For r = 0 To UBound(myArr)
shtTmp.Cells(1, r + 1) = myArr(r)
Next r
i = j
Exit For
End If
Next j
Next i
shtTmp.Select
If shtMenu.Cells(15, 6) <> "x" Then
Exit Sub
End If
Set shtTmp = Sheets("tmpCar")
Dim iRentacar As Integer
Set shtMails = Sheets("rentacar")
iLastRow = shtMain.Cells(shtMain.Rows.Count, "B").End(xlUp).Row
iLastColumn = shtMenu.Cells(17, shtMenu.Columns.Count).End(xlToLeft).Column
ilastrowmail = shtMails.Cells(shtMails.Rows.Count, "B").End(xlUp).Row
shtMain.Range("A1:AO" & iLastRow).Sort key1:=shtMain.Range("B1:N" & iLastRow), _
order1:=xlAscending, Header:=xlYes
Erase myArr
ReDim myArr(1)
j = 0
shtTmp.Cells.ClearContents
For i = 3 To iLastColumn
myArr(j) = UCase(shtMenu.Cells(17, i))
Debug.Print myArr(j)
j = j + 1
ReDim Preserve myArr(j)
Next i
For i = 0 To UBound(myArr)
shtTmp.Cells(1, i + 1) = myArr(i)
Next i
For iCl = 2 To 41
If shtMain.Cells(1, iCl) = "Rent a car" Then
iRentacar = iCl
Exit For
End If
Next iCl
For i = 2 To iLastRow
If shtMain.Cells(i, iRentacar) <> "" And shtMain.Cells(i, iRentacar) <> 0 Then
If InStr(shtMain.Cells(j + 1, iHotel), "(") = 0 Then
iPos = 50
Else
iPos = InStr(shtMain.Cells(i, iHotel), "(")
End If
sHotelName = Left(shtMain.Cells(i, iHotel), iPos - 2)
iRow = 2
For j = i To iLastRow
iColumn = 1
For iCl = 1 To 41
If IsInArray(UCase(shtMain.Cells(1, iCl)), myArr) Then
shtTmp.Cells(1, iColumn) = shtMain.Cells(1, iCl)
shtTmp.Cells(iRow, iColumn) = shtMain.Cells(j, iCl)
If shtTmp.Cells(1, iColumn) = "Obs" Then shtTmp.Cells(iRow, iColumn) = shtTmp.Cells(iRow, iColumn) & vbNewLine
iColumn = iColumn + 1
End If
Next iCl
shtTmp.Cells(iRow, 1) = sHotelName
On Error GoTo Resume2
If Left(shtMain.Cells(j + 1, iHotel), iPos - 2) = sHotelName Then
iRow = iRow + 1
Else
Resume2:
For r = 2 To ilastrowmail
If shtMain.Cells(i, iRentacar + 1) = shtMails.Cells(r, 2) Then
strTo = shtMails.Cells(r, 3)
Exit For
End If
Next r
If strTo = "" Then
MsgBox "Rent a Car service not found for " & sHotelName & vbNewLine & "Macro will resume."
Else
Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr)))
strSubject = shtMenu.Cells(27, 3)
strBody = shtMenu.Cells(21, 3) & "<br>" & RangetoHTML(rng) & "<br>" & shtMenu.Cells(24, 3)
Call createMail(objOutlook, strTo, strSubject, strBody)
End If
strTo = ""
shtTmp.Cells.ClearContents
For r = 0 To UBound(myArr)
shtTmp.Cells(1, r + 1) = myArr(r)
Next r
i = j
Exit For
End If
Next j
End If
Next i
shtTmp.Select
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = False
For i = 0 To UBound(arr)
If stringToBeFound = arr(i) Then
IsInArray = True
Exit Function
End If
Next i
End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
Sub createMail(objOutlook As Outlook.Application, strTo As String, strSubject As String, strBody As String)
Dim objMail As Outlook.MailItem
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = strTo
.Subject = strSubject
.HTMLBody = Replace(strBody, "0in", "1in")
.Save
' If you want to send:
'.Send
End With
Set objMail = Nothing
Application.ScreenUpdating = False
End Sub
我试图检测酒店栏的位置，因此与我添加变量iHotel并将其用于多个迭代之前的代码相比.
What I tried was to detect the position of hotel column, so compared to code I had before I added a variable iHotel and used it in the several iteractions..
先谢谢您！
注意:此外，我们还有2列:租车和服务(在数据列表中)，如果它在该单元格(租车)中有值，我们想要一个规则，即该行可以被发送到酒店，并根据另一个单元格(服务)中的值向另一封电子邮件发送另一封电子邮件.我们提供服务列表以及相应的电子邮件和租车电子邮件"列.
NOTE:Also we have 2 columns: rent-a-car and service, (in the data list table) if it has a value in that cell (rent-a-car) we want a rule that, that rows could be sent to the hotel and send a different email to another email based on a value in another cell (service). We have the list of services and respective email and columns for rent-a-car email.
推荐答案
如果我正确理解，则只需将您的代码替换为以下内容，即可显示您期望的日期:
If I understood correctly then simply replace your code with the following and it should show the dates as you expect:
Sub btnSendMails()
Dim strTo As String, strCc As String, strSubject As String, strBody As String, sHotelName As String, myArr() As String, DateValue As String, DateValue2 As String, DateValue3 As String
Dim iLastRow As Long, iLastColumn As Long, iColumn As Long, iRow As Long, iCl As Long, iHotel As Long, iPos As Long, i As Long
Dim rng As Range
Dim shtMain As Worksheet: Set shtMain = Sheets("list")
Dim shtMails As Worksheet: Set shtMails = Sheets("hotels")
Dim shtMenu As Worksheet: Set shtMenu = Sheets("menu")
Dim shtTmp As Worksheet: Set shtTmp = Sheets("tmp")
Dim objOutlook As Outlook.Application
Set objOutlook = CreateObject("Outlook.Application")
iLastRow = shtMain.Cells(shtMain.Rows.Count, "B").End(xlUp).Row
iLastColumn = shtMenu.Cells(3, shtMenu.Columns.Count).End(xlToLeft).Column
ilastrowmail = shtMails.Cells(shtMails.Rows.Count, "B").End(xlUp).Row
For i = 2 To iLastRow
DateValue = shtMain.Cells(i, 3)
shtMain.Cells(i, 3).NumberFormat = "@"
shtMain.Cells(i, 3).Value = DateValue
DateValue2 = shtMain.Cells(i, 9)
shtMain.Cells(i, 9).NumberFormat = "@"
shtMain.Cells(i, 9).Value = DateValue2
DateValue3 = shtMain.Cells(i, 23)
shtMain.Cells(i, 23).NumberFormat = "@"
shtMain.Cells(i, 23).Value = DateValue3
Next i
Application.ScreenUpdating = False
shtMain.Range("A1:AO" & iLastRow).Sort key1:=shtMain.Range("B1:N" & iLastRow), order1:=xlAscending, Header:=xlYes
ReDim Preserve myArr(5)
j = 0
shtTmp.Cells.ClearContents
For iCl = 2 To 41
If shtMain.Cells(1, iCl) = "Hotel" Then
iHotel = iCl
Exit For
End If
Next iCl
For i = 3 To iLastColumn
myArr(j) = UCase(shtMenu.Cells(3, i))
j = j + 1
ReDim Preserve myArr(j)
Next i
For i = 0 To UBound(myArr)
shtTmp.Cells(1, i + 1) = myArr(i)
Next i
For i = 2 To iLastRow
If InStr(shtMain.Cells(i, iHotel), "(") = 0 Then
iPos = 50
Else
iPos = InStr(shtMain.Cells(i, iHotel), "(")
End If
sHotelName = Left(shtMain.Cells(i, iHotel), iPos - 2)
iRow = 2
For j = i To iLastRow
iColumn = 1
For iCl = 1 To 41
If IsInArray(UCase(shtMain.Cells(1, iCl)), myArr) Then
shtTmp.Cells(1, iColumn) = shtMain.Cells(1, iCl)
shtTmp.Cells(iRow, iColumn) = shtMain.Cells(j, iCl)
If shtTmp.Cells(1, iColumn) = "Obs" Then shtTmp.Cells(iRow, iColumn) = shtTmp.Cells(iRow, iColumn) & vbNewLine
iColumn = iColumn + 1
End If
Next iCl
On Error GoTo Resume1
If Left(shtMain.Cells(j + 1, iHotel), iPos - 2) = sHotelName Then
iRow = iRow + 1
Else
Resume1:
For r = 2 To ilastrowmail
If UCase(sHotelName) = UCase(shtMails.Cells(r, 3)) Then
strTo = shtMails.Cells(r, 4)
Exit For
End If
Next r
If strTo = "" Then
MsgBox "Email not found for " & sHotelName & vbNewLine & "Macro will resume."
Else
Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr)))
strSubject = shtMenu.Cells(13, 3)
strBody = shtMenu.Cells(7, 3) & "<br>" & RangetoHTML(rng) & "<br>" & shtMenu.Cells(10, 3)
Call createMail(objOutlook, strTo, strSubject, strBody)
End If
strTo = ""
shtTmp.Cells.ClearContents
For r = 0 To UBound(myArr)
shtTmp.Cells(1, r + 1) = myArr(r)
Next r
i = j
Exit For
End If
Next j
Next i
If shtMenu.Cells(15, 6) <> "x" Then
Exit Sub
End If
Set shtTmp = Sheets("tmpCar")
Dim iRentacar As Long
Set shtMails = Sheets("rentacar")
iLastRow = shtMain.Cells(shtMain.Rows.Count, "B").End(xlUp).Row
iLastColumn = shtMenu.Cells(17, shtMenu.Columns.Count).End(xlToLeft).Column
ilastrowmail = shtMails.Cells(shtMails.Rows.Count, "B").End(xlUp).Row
shtMain.Range("A1:AO" & iLastRow).Sort key1:=shtMain.Range("B1:N" & iLastRow), _
order1:=xlAscending, Header:=xlYes
Erase myArr
ReDim myArr(1)
j = 0
shtTmp.Cells.ClearContents
For i = 3 To iLastColumn
myArr(j) = UCase(shtMenu.Cells(17, i))
Debug.Print myArr(j)
j = j + 1
ReDim Preserve myArr(j)
Next i
For i = 0 To UBound(myArr)
shtTmp.Cells(1, i + 1) = myArr(i)
Next i
For iCl = 2 To 41
If shtMain.Cells(1, iCl) = "Rent a car" Then
iRentacar = iCl
Exit For
End If
Next iCl
For i = 2 To iLastRow
If shtMain.Cells(i, iRentacar) <> "" And shtMain.Cells(i, iRentacar) <> 0 Then
If InStr(shtMain.Cells(j + 1, iHotel), "(") = 0 Then
iPos = 50
Else
iPos = InStr(shtMain.Cells(i, iHotel), "(")
End If
sHotelName = Left(shtMain.Cells(i, iHotel), iPos - 2)
iRow = 2
For j = i To iLastRow
iColumn = 1
For iCl = 1 To 41
If IsInArray(UCase(shtMain.Cells(1, iCl)), myArr) Then
shtTmp.Cells(1, iColumn) = shtMain.Cells(1, iCl)
shtTmp.Cells(iRow, iColumn) = shtMain.Cells(j, iCl)
If shtTmp.Cells(1, iColumn) = "Obs" Then shtTmp.Cells(iRow, iColumn) = shtTmp.Cells(iRow, iColumn) & vbNewLine
iColumn = iColumn + 1
End If
Next iCl
shtTmp.Cells(iRow, 1) = sHotelName
On Error GoTo Resume2
If Left(shtMain.Cells(j + 1, iHotel), iPos - 2) = sHotelName Then
iRow = iRow + 1
Else
Resume2:
For r = 2 To ilastrowmail
If shtMain.Cells(i, iRentacar + 1) = shtMails.Cells(r, 2) Then
strTo = shtMails.Cells(r, 3)
Exit For
End If
Next r
If strTo = "" Then
MsgBox "Rent a Car service not found for " & sHotelName & vbNewLine & "Macro will resume."
Else
Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr)))
strSubject = shtMenu.Cells(27, 3)
strBody = shtMenu.Cells(21, 3) & "<br>" & RangetoHTML(rng) & "<br>" & shtMenu.Cells(24, 3)
Call createMail(objOutlook, strTo, strSubject, strBody)
End If
strTo = ""
shtTmp.Cells.ClearContents
For r = 0 To UBound(myArr)
shtTmp.Cells(1, r + 1) = myArr(r)
Next r
i = j
Exit For
End If
Next j
End If
Next i
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = False
For i = 0 To UBound(arr)
If stringToBeFound = arr(i) Then
IsInArray = True
Exit Function
End If
Next i
End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
Sub createMail(objOutlook As Outlook.Application, strTo As String, strSubject As String, strBody As String)
Dim objMail As Outlook.MailItem
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = strTo
.Subject = strSubject
.HTMLBody = Replace(strBody, "0in", "1in")
.Save
' If you want to send:
'.Send
End With
Set objMail = Nothing
Application.ScreenUpdating = False
End Sub
我只是添加了一个循环，以将日期格式设置为字符串，以便将日期附加到电子邮件中时，格式正确.我添加的代码是:
I've simply added a loop to format your dates as strings, so that when you attach them to the email the come in the right format. The code I added is:
For i = 2 To iLastRow
DateValue = shtMain.Cells(i, 3)
shtMain.Cells(i, 3).NumberFormat = "@"
shtMain.Cells(i, 3).Value = DateValue
DateValue2 = shtMain.Cells(i, 9)
shtMain.Cells(i, 9).NumberFormat = "@"
shtMain.Cells(i, 9).Value = DateValue2
DateValue3 = shtMain.Cells(i, 23)
shtMain.Cells(i, 23).NumberFormat = "@"
shtMain.Cells(i, 23).Value = DateValue3
Next i
要解决操作员问题，只需删除以下代码行即可:
Also to fix the Operator issue, you simply had to remove the following line of code:
shtTmp.Cells(iRow, 1) = sHotelName
这篇关于Excel发送电子邮件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
