代码错误-VBA MAcro发送邮件

时间：2019-07-16 12:16:56

标签： excel vba

我正在尝试根据他们的帐户向不同的项目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

现在仅生成空邮件

1 个答案:

答案 0 :(得分：0)

Sub 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

'如果rng无效，则 'MsgBox“所选内容不在范围内或工作表受保护”＆vbNewLine＆“请更正，然后重试。”，vbOKOnly 退出子 '如果结束

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） 由Ron de Bruin更改2006年10月28日 在Office 2000-2016中工作     暗淡作为对象     暗淡为对象     昏暗的TempFile作为字符串     将TempWB作为工作簿调暗

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

结束功能

函数LastRow（以工作表形式显示）     关于错误继续     LastRow = sh.Cells.Find（What：=“ *”，_                             之后：= sh.Range（“ A1”），_                             查找：= xlPart，_                             LookIn：= xlValues，_                             SearchOrder：= xlByRows，_                             SearchDirection：= xl上一个_                             MatchCase：= False）。行     出错时转到0 结束功能

相关问题
最新问题