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 = "[email protected]"
.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
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 = "[email protected]"
.From = "[email protected]"
.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