我如何添加代码到我的Mail_Workbook vba每天打开，刷新，发送，然后关闭

Question

我需要添加vba来打开此工作簿，自动刷新数据，发送，然后关闭。

这是我的代码，它自己工作得很好，但我需要每天自动执行。

Sub Mail_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "[e-mail]"
.CC = ""
.BCC = ""
.Subject = "***TEST*** " & Subj
.Body = Subj
.Attachments.Add ActiveWorkbook.FullName
.Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%S"
End With
Set OutMail = Nothing
End Sub

Answer 1

您可以尝试如下操作。在工作簿打开时，它调用过程RunMacro。

RunMacro过程从范围中读取值，并设置MIS程序必须被调用。

MIS程序将打开工作簿，刷新它，获得保存文件的路径，最后发送邮件。

在邮件中，它将发送工作簿的链接，而不会附加工作簿。因此，您可以将工作簿保存在任何共享驱动器上。

将此代码放在ThisWorkbook代码段

 Private Sub Workbook_Open()
    RunMacro
End Sub

将此代码放到任意标准模块中。

Sub RunMacro()

    Dim a As String, b As String, c As String, d As String, e As String
    a = Format(Range("A3"), "hh:mm:ss")
    b = Format(Range("A4"), "hh:mm:ss")
    c = Format(Range("A5"), "hh:mm:ss")
    d = Format(Range("A6"), "hh:mm:ss")
    e = Format(Range("A7"), "hh:mm:ss")

    Application.OnTime TimeValue(a), "MIS"
    Application.OnTime TimeValue(b), "MIS"
    Application.OnTime TimeValue(c), "MIS"
    Application.OnTime TimeValue(d), "MIS"
    Application.OnTime TimeValue(e), "MIS"
End Sub
Sub MIS()
'open the workbook
    Dim wkb As Workbook
    Dim Path As String, strFile As String, strFilePath As String
    strFile = "file1.xlsx"
    Path = ThisWorkbook.Path & "" & strFile
    If IsWorkBookOpen(Path) Then
        Set wkb = Workbooks(strFile)
    Else
        Set wkb = Workbooks.Open(Path)
    End If
    'Refresh the data
    wkb.RefreshAll
    'get new filePath
    strFilePath = getFileLink
    wkb.SaveAs Filename:=strFilePath 
    wkb.Close
    'send mail
    SendMail strFilePath

End Sub
Function IsWorkBookOpen(FileName As String)
'Check if workbooks is open
'IsOpen Return true
    Dim ff As Long, ErrNo As Long
    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0
    Select Case ErrNo
    Case 0: IsWorkBookOpen = False
    Case 70: IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function
Sub SendMail(myDest As String)
'procedure to send mail
'you need to configure the server & port
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "test-svr-002"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
    End With
    With iMsg
        Set .Configuration = iConf
        .To = "[e-mail]"
        .From = "[e-mail]"
        .Subject = "MIS Reports" & " " & Date & " " & Time
        .TextBody = "Link to Mis Report :" & vbNewLine & "<" & myDest & ">"
        .Send
    End With
    Set iMsg = Nothing
    Set iConf = Nothing
End Sub
Function getFileLink() As String
    Dim fso As Object, MyFolder As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    MyFolder = ThisWorkbook.Path & "Reports"

    If fso.FolderExists(MyFolder) = False Then
        fso.CreateFolder (MyFolder)
    End If
    MyFolder = MyFolder & "" & Format(Now(), "MMM_YYYY")
    If fso.FolderExists(MyFolder) = False Then
        fso.CreateFolder (MyFolder)
    End If
    getFileLink = MyFolder & "MIS " & Format(Now(), "DD-MM-YY hh.mm.ss") & ".xls"
    Set fso = Nothing
End Function