工作簿会自动向收件人发送邮件,但也会向不公开的电子邮件发送电子邮件

时间:2016-05-20 15:50:25

标签: excel vba excel-vba email

此代码正常工作,并将整个工作簿发送到我的电子邮件收件人列表,但我发现它还发送电子邮件到随机内部电子邮件地址,列表中没有列表或代码。有人知道它可能会这样做吗?

Sub Send_Reports()

    Dim wb1 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim X As Integer
    Dim Analyst_Count As Integer
    Dim Analyst_Email As String

    Analyst_Count = ActiveWorkbook.Worksheets("Dashboard").Range("C27", Worksheets("Dashboard").Range("C27").End(xlDown)).Rows.Count

    For X = 1 To Analyst_Count

        With Worksheets("Dashboard")
            Analyst_Email = Range("C27").Offset(X - 1, 0)
            Application.StatusBar = "    Emailing:   " & Analyst_Email
        End With

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        Set wb1 = ActiveWorkbook

        TempFilePath = Environ$("temp") & "\"
        TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
        FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

        wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next
        With OutMail
            .To = (Analyst_Email)
            .CC = ""
            .BCC = ""
            .Subject = "New Open Req Report"
            .Body = "Here is the Open Req Report broken down by function."
            .Attachments.Add TempFilePath & TempFileName & FileExtStr

            .Send
        End With
        On Error GoTo 0

        Kill TempFilePath & TempFileName & FileExtStr

        Set OutMail = Nothing
        Set OutApp = Nothing

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With

    Next X
    Application.StatusBar = False
End Sub

0 个答案:

没有答案