Как добавить код в мою 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 процедура откроет книгу, обновите ее, найдите путь для сохранения файла и, наконец, отправьте письмо.

По почте он отправит ссылку на книгу и не будет прикреплять книгу. Таким образом, вы можете сохранить книгу на любом общем диске.

Поместите этот код в разделе

Private Sub Workbook_Open() 
    RunMacro 
End Sub 

ThisWorkbook код Поместите этот код в любом модуле стандарта.

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