如何将代码添加到Mail_Workbook vba中以每天打开，刷新，发送然后关闭？

Question

I need to add vba to open this workbook, refresh the data, automatically, send, then close.

Here is my code which works fine on it's own but I need to automate this daily.

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 = "me.meeee@company.com"
.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

You may try something like below. On workbook open it calls a procedure RunMacro .

The RunMacro procedure reads the values from the ranges and sets the time when the MIS procedure has to be called.

MIS procedure will open the workbook, Refresh it , get a path to save the file and finally send the mail.

In the mail it will send the link for the workbook and wont attach the workbook. So you can save the workbook on any shared drive.

Put this code on ThisWorkbook code section

 Private Sub Workbook_Open()
    RunMacro
End Sub

Put this code in any Standard Module.

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 = "test@gmail.com"
        .From = "test@gmail.com"
        .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