Question

我尝试将这些工作表自动发送到与其相应收件人的电子邮件中。基本上，编码将读取＆＃34;电子邮件＆＃34;包含所有电子邮件地址，cc和密件抄送的工作表。然后，代码将所需的工作表发送到＆＃34;电子邮件＆＃34;中所列的电子邮件。片。我现在唯一需要的就是让它自动化。但是，代码Application.OnTime不适用于整个编码。我不知道为什么。请帮助我们。

Sub ExportEmail()

    Dim objfile As FileSystemObject
    Dim xNewFolder
    Dim xDir As String, xMonth As String, xFile As String, xPath As String
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim NameX As Name, xStp As Long
    Dim xDate As Date, AWBookPath As String
    Dim currentWB As Workbook, newWB As Workbook
    Dim strEmailTo As String, strEmailCC As String, strEmailBCC As String, strDistroList As String

    AWBookPath = ActiveWorkbook.Path & "\"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = "Creating Email and Attachment for " & Format(Date, "dddd dd mmmm yyyy")

    Set currentWB = ActiveWorkbook

    xDate = Date

    '******************************Grabbing New WorkBook and Formatting*************

    Sheets(Array("Interval Data", "rawData")).Copy

    Set newWB = ActiveWorkbook

    Range("A1").Select
    Sheets("rawData").Visible = True
   ' Sheets("Cover").Select


    '******************************Creating Pathways*********************************

    xDir = AWBookPath
    xMonth = Format(xDate, "mm mmmm yy") & "\"

    xFile = "This is the automated report " & Format(xDate, "dd-mm-yyyy") & ".xlsx"

    xPath = xDir & xMonth & xFile

    '******************************Saving File in Pathway*********************************

    Set objfile = New FileSystemObject

    If objfile.FolderExists(xDir & xMonth) Then
        If objfile.FileExists(xPath) Then
            objfile.DeleteFile (xPath)
            newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False

            Application.ActiveWorkbook.Close
        Else
            newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
            Application.ActiveWorkbook.Close
        End If
    Else
        xNewFolder = xDir & xMonth
        MkDir xNewFolder
        newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
        Application.ActiveWorkbook.Close
    End If

    '******************************Preparing Distribution List *********************************

    currentWB.Activate
    Sheets("Email").Visible = True
    Sheets("Email").Select

    strEmailTo = ""
    strEmailCC = ""
    strEmailBCC = ""

    xStp = 1

    Do Until xStp = 4

        Cells(2, xStp).Select

        Do Until ActiveCell = ""

            strDistroList = ActiveCell.Value

            If xStp = 1 Then strEmailTo = strEmailTo & strDistroList & "; "
            If xStp = 2 Then strEmailCC = strEmailCC & strDistroList & "; "
            If xStp = 3 Then strEmailBCC = strEmailBCC & strDistroList & "; "

            ActiveCell.Offset(1, 0).Select

        Loop

        xStp = xStp + 1

    Loop

    Range("A1").Select

    '******************************Preparing Email*********************************


    Set olApp = New Outlook.Application
       Dim olNs As Outlook.Namespace
       Set olNs = olApp.GetNamespace("MAPI")
       olNs.Logon
    Set olMail = olApp.CreateItem(olMailItem)
    olMail.To = strEmailTo
    olMail.CC = strEmailCC
    olMail.BCC = strEmailBCC


        olMail.Subject = Mid(xFile, 1, Len(xFile) - 4)
        olMail.Body = vbCrLf & "Hello Everyone," _
                            & vbCrLf & vbCrLf & "Please find attached the " & Mid(xFile, 1, Len(xFile) - 4) & "." _
                            & vbCrLf & vbCrLf & "Regards," _
                            & vbCrLf & "--------"


    olMail.Attachments.Add xPath
    'olMail.Display

    olMail.Send

    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Answer 1

创建另一个Sub

在时间14:47执行此操作

Sub test()
    Application.OnTime TimeValue("14:47:00"), "ExportEmail"
End Sub

从现在开始运行这15分钟

Sub test()
    Application.OnTime Now + TimeValue("00:15:00"), "ExportEmail"
End Sub

Application.OnTime不起作用

1 个答案: