如何將代碼添加到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 = "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

您可以嘗試以下類似方法。 在工作簿上打開它會調用過程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 = "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