excel - 用于发送邮件的代码错误 -VBA MAcro
问题描述
我正在尝试根据他们的帐户向不同的项目 DM 发送邮件。在我的 excel 工作表数据中,第一列包含 Parent 和 Project 的详细信息。K 列包含 DM 的详细信息。如果有多个 DM。代码应在单个邮件中生成标记给每个 DM 的邮件。
我试过这段代码
Sub Button6_Click()
Dim My_Range As Range
Dim My_Range2 As Range
Dim rng As Range
Dim mailaddress As Range
Dim My_Range1 As Range
Dim FieldNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2, ws1 As Worksheet
Dim Lrow As Long
Dim Lrow1 As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
Dim OutApp As Object
Dim OutMail As Object
Dim body1 As String, body2 As String, mail_Message As String, mail_Subject As String, mail_from As String, mail_on_behfalfof As String
Dim last_row, last_row2 As Long
Dim last_col, last_col2 As Integer
Dim i As Integer
Set My_Range = Range("A1:Z" & LastRow(ActiveSheet))
My_Range.Parent.Select
Set My_Range2 = Range("B1:Z" & LastRow(ActiveSheet))
My_Range2.Parent.Select
Set ws1 = ActiveSheet
If ws1.FilterMode Then
ActiveSheet.ShowAllData
End If
last_row = LastRow(ActiveSheet)
mail_Message = "ACD."
mail_Message_end = "ABCD"
mail_Subject = "ABBD "
mail_from = "MNA"
mail_on_behalfof = "mnvjdf"
Set ws1 = ActiveSheet
last_col = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
FieldNum = 1
FieldNum1 = 2
My_Range.Parent.AutoFilterMode = False
My_Range2.Parent.AutoFilterMode = False
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
Set ws2 = Worksheets.Add
With ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), UNIQUE:=True
My_Range.Columns(FieldNum1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("B1"), UNIQUE:=True
On Error Resume Next
Lrow1 = ws2.Cells(Rows.Count, "B").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
Lrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
Lrow1 = .Cells(Rows.Count, "B").End(xlUp).Row
For Each cell1 In .Range("B2:B" & Lrow1)
My_Range.AutoFilter Field:=FieldNum1, Criteria1:="=" & _
Replace(Replace(Replace(cell1.Value, "~", "~~"), "*", "~*"), "?", "~?")
Set My_Range1 = ws1.Range(Cells(1, 1), Cells(last_row, last_col)).SpecialCells(xlCellTypeVisible)
If (ws1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1) Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim Ldate As Date
With OutMail
.SentOnBehalfOfName = mail_on_behfalfof
.To = UNIQUE(ActiveSheet.Range("K2:K3235"), 1000)
.CC = ""
.BCC = ""
.Subject = mail_Subject
.HTMLBody = body1 & RangetoHTML(My_Range1) & body2
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.Display
On Error Resume Next
End With
End If
My_Range.AutoFilter Field:=FieldNum1
Next cell1
My_Range.AutoFilter Field:=FieldNum
Next cell
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
'My_Range1.Parent.AutoFilterMode = False
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
My_Range.Parent.Select
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
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
.Cells(1).EntireRow.AutoFit
.Cells(1).EntireColumn.AutoFit
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
TempWB.Sheets(1).UsedRange.Columns.AutoFit
'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
Function UNIQUE(InputRange As Range, ItemNo As Long) As Variant
Dim cl As Range, cUnique As New Collection, cValue As Variant
Application.Volatile
On Error Resume Next
For Each cl In InputRange
If cl.Formula <> "" Then
cUnique.Add cl.Value, CStr(cl.Value)
End If
Next cl
If ItemNo = 0 Then
UNIQUE = cUnique.Count
Else
If ItemNo <= cUnique.Count Then
UNIQUE = cUnique(ItemNo)
End If
End If
On Error GoTo 0
End Function
现在只生成空邮件
解决方案
子 Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object 'Dim OutApp As Outlook.Application
Dim OutMail As Object 'Dim OutMail As Outlook.MailItem
Dim ws1 As Worksheet, ws2 As Worksheet
Dim body1 As String, body2 As String, mail_Message As String, mail_Subject As String, mail_from As String, mail_on_behfalfof As String
Dim last_row, last_row2 As Long
Dim last_col, last_col2 As Integer
Dim I As Integer, J As Integer
I = 1
J = 1
Set rng = Nothing
mail_Message = "UABCD"
mail_Message_end = "ABCD"
mail_Subject = "ABCD "
mail_from = ""
mail_on_behalfof = ""
Set ws1 = ThisWorkbook.Worksheets("Mail")
Set ws2 = ThisWorkbook.Worksheets("do")
Set My_Range = Range("A1:Z" & LastRow(ws1))
My_Range.Parent.Select
FieldNum = 1
FieldNum1 = 2
If ws1.FilterMode Then
ActiveSheet.ShowAllData
End If
last_row = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
last_row1 = ws2.Cells(ws1.Rows.Count, 1).End(xlUp).Row
last_row2 = ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row
last_col = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
last_col2 = ws2.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
My_Range.Columns(FieldNum1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("B1"), Unique:=True
结束于
ws1.Range(Cells(1, 1), Cells(last_row, last_col)).AutoFilter
For I = 1 To last_row1 - 1
body1 = "<P STYLE='font-family:Calibri (Body);font-size:14.5'>" & "Hi " & "," & "<br>" & "<br>" & mail_Message & "<br>" & "</p>"
body2 = "<P STYLE='font-family:Calibri (Body);font-size:14.5'>" & "<br>" & mail_Message_end & "<br>" & "Regards," & "<br>" & mail_from & "</p>"
ws1.AutoFilterMode = False
ws1.Range(Cells(1, 1), Cells(1, last_col)).AutoFilter Field:=1, Criteria1:=ws2.Range("A1").Offset(I, 0).Value
For J = 1 To last_row2 - 1
ws1.Range(Cells(1, 1), Cells(1, last_col)).AutoFilter Field:=2, Criteria1:=ws2.Range("B1").Offset(J, 0).Value
Set rng = ws1.Range(Cells(1, 1), Cells(last_row, last_col)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If (ws1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1) Then
' If rng Is Nothing Then ' MsgBox "选择不是范围或工作表受保护" & vbNewLine & "请更正并重试。", vbOKOnly ' Exit Sub ' End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Set OutMail = OutApp.CreateItem(olMailItem)
Dim Ldate As Date
On Error Resume Next
With OutMail
.SentOnBehalfOfName = mail_on_behfalfof
.To = ws1.Range("A1").Offset((ActiveCell.Row), (ActiveCell.Column) + 10).Value
.CC = ""
.BCC = ""
.Subject = mail_Subject
.HTMLBody = body1 & RangetoHTML(rng) & body2
.SendUsingAccount = OutApp.Session.Accounts.Item(2)
.Display 'use .Send or .Display for testing
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next J
Next I
结束子
函数 RangetoHTML(rng As Range) ' 由 Ron de Bruin 2006 年 10 月 28 日更改 ' 在 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
.Cells(1).EntireRow.AutoFit
.Cells(1).EntireColumn.AutoFit
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
TempWB.Sheets(1).UsedRange.Columns.AutoFit
'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
结束功能
Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlValues , _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function
推荐阅读
- flutter - 一旦点击触发,如何动态更改颤动网格卡中的图标
- php - 找不到驱动程序 laravel 命令
- python - Python boto3 库无法在 Amazon Linux 2 上运行
- html - 为什么我的 github pages 站点没有加载我的图像
- jmeter - Dynamic Refid is appended to the URL but i can't find refid in the response
- python - 字典不起作用,我也收到“KeyError:0”错误消息,我不知道这是什么意思:/(顺便说一下python)
- firebase - Pyrebase 认证不返回成功案例
- jmeter - jmeter,如何一次性设置“思考时间”?
- assembly - 在x86中将两个数字相乘(通过重复加法)
- python - 使用 pandas 读取 excel 文件并将其打印以将其插入到 Rest-API 的 http GET 语句中