Hello hubTohub,
Here is the macro code so far. You will need to fill a few blanks fro the email and possibly you will need to change the name of the worksheets in the code. The sheet names I used are "Sheet1" and "Sheet2".
The macro does not do an automatic look up of the file yet. I want you to test the code written so far to be sure it works. I will then add in the code to automatically look up the Excel document.
You can copy this code to a Standard VBA module in your workbook's VBA project. You can then attach the macro to your Shape's click event. Test it out and let me know what formatting changes, etc. need to be made.
Sub EmailReportSums()
Dim DocPath As String
Dim Email As String
Dim Folder As String
Dim Link1 As String
Dim Message As String
Dim RngBeg As Range
Dim RngEnd As Range
Dim SendTo As String
Dim Subjec As String
Dim Sum1 As Double
Dim Sum2 As Double
Dim olApp As Object
Dim Wkb As Workbook
Dim Wks1 As Worksheet
Dim Wks2 As Worksheet
SendTo = "" ' Name of the person reveiving the email.
Email = "" ' email address of the person receiving the email.
Subject = "" ' Subject line for this email.
' User selects the file to open.
DocPath = Application.GetOpenFilename("Excel Workbooks (*.xls),*.xls, All Files (*.*),*.*")
' Check if Cancel button was clicked.
If DocPath = "False" Then Exit Sub
' Get the folder path where the Excel file is saved.
Folder = Left(DocPath, InStrRev(DocPath, "\"))
' Create the email hyperlink.
Link1 = "<a href=""" & "file:///" & Folder & """>" & Folder & "</a>"
' Open the Excel workbook.
Set Wkb = Workbooks.Open(Filename:=DocPath, ReadOnly:=True)
' Assign the worksheets to object variables.
Set Wks1 = Wkb.Worksheets("Sheet1")
Set Wks2 = Wkb.Worksheets("Sheet2")
' Get the sum of the range for "Sheet1".
Set RngBeg = Wks1.Range("B2:AW2")
Set RngEnd = Wks1.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
Sum1 = Application.Sum(Wks1.Range(RngBeg, RngEnd))
' Get the sum of the range for "Sheet2".
Set RngBeg = Wks2.Range("B2:AW2")
Set RngEnd = Wks2.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
Sum2 = Application.Sum(Wks1.Range(RngBeg, RngEnd))
' Build the HTML message for the email's body.
Message = "<p>Dear " & SendTo & "," & "<br><br>" _
& "Please find the total accepted for todays <b>XYZ: " & Sum1 & "</b><br>" _
& "And the total accepted for todays <b>ABC: " & Sum2 & "</b><br><br>" _
& "If you would like to modify the docs please follow: " & Link1 & "<br><br>" _
& "Kind regards, <br><br>" & "HubToHub</p>"
' Start Outlook.
Set olApp = CreateObject("Outlook.Application")
olApp.Session.GetDefaultfolder 4
' Send the email.
With olApp.CreateItem(0)
.To = Email
.Subject = Subject
.BodyHTML = Message
.Send
End With
End Sub
Reply With Quote
Drive (my tool sheet is also saved on the shared (F
