Private Declare PtrSafe Function GetUserNameEx Lib "secur32.
dll" Alias
"GetUserNameExA" (ByVal NameFormat As Long, ByVal lpNameBuffer As String, ByRef
nSize As Long) As Long
Sub SendAuditUpdateEmail()
' Variable declarations
Dim shapeIndex As Integer
Dim shapeCount As Integer
Dim imagePath As String
Dim base64Image As String
Dim emailRecipient As String
Dim userEmail As String
Dim ccEmails As String
Dim currentWorkbook As Workbook
Dim outlookApp As Object
Dim outlookMail As Object
Dim currentDate As String
Dim shape As shape
Dim originalWidth As Double
Dim originalHeight As Double
Dim resizeRatio As Double
Dim newWidth As Double
Dim newHeight As Double
Set currentWorkbook = ThisWorkbook
' Prepare recipient and cc list by extracting values from the "Update"
worksheet
emailRecipient = currentWorkbook.Worksheets("Update").Cells(3, 2).Value
userEmail = GetUserEmail() ' Get the current user's email address
emailRecipient = RemoveUserEmail(emailRecipient, userEmail) ' Remove the
current user's email from the recipient list if it exists
ccEmails = currentWorkbook.Worksheets("Update").Cells(3, 4).Value ' Get CC
list from the "Update" worksheet
' Clean up the "Temp" worksheet by deleting any existing shapes
currentWorkbook.Worksheets("Temp").Visible = xlSheetVisible
shapeCount = currentWorkbook.Worksheets("Temp").Shapes.Count
For shapeIndex = 1 To shapeCount
currentWorkbook.Worksheets("Temp").Shapes.Item(1).Delete
Next shapeIndex
' Copy the required range from the "Summary" worksheet as an image
currentWorkbook.Worksheets("Summary").Activate
shapeIndex = WorksheetFunction.Max(Columns(2)) ' Find the maximum row number
in column 2 (B)
Call Range(Cells(2, 2), Cells(4 + shapeIndex, 18)).CopyPicture ' Copy the
desired range as a picture
Application.Wait Now + TimeValue("00:00:01") ' 1 second delay to allow the
paste operation
' Paste the image into the "Temp" worksheet and convert it into a chart for
exporting
currentWorkbook.Worksheets("Temp").Activate
ActiveSheet.Paste
Cells(1, 1).Select
' Resize the image based on a ratio
resizeRatio = 0.7 ' Define the resize ratio (e.g., 0.5 for 50% of the original
size)
' Resize each shape (image) while maintaining aspect ratio
For Each shape In ActiveSheet.Shapes
shape.Select
originalWidth = shape.Width
originalHeight = shape.Height
' Calculate the new width and height based on the resize ratio
newWidth = originalWidth * resizeRatio
newHeight = originalHeight * resizeRatio
' Resize the shape (image)
shape.LockAspectRatio = msoTrue ' Maintain the aspect ratio
shape.Width = newWidth ' Resize width based on ratio
shape.Height = newHeight ' Resize height based on ratio
Application.Selection.CopyPicture
Set ChartObject = currentWorkbook.Worksheets("Temp").ChartObjects.Add(0, 0,
shape.Width, shape.Height)
Set ChartArea = ChartObject.Chart
ChartObject.Activate
With ChartArea
.ChartArea.Select
.Paste
imagePath = Environ("USERPROFILE") & "\Downloads\Audit_Update_" &
Format(Now, "yyyymmdd_hhnnss") & ".jpg" ' Save the image to the Downloads folder
with a unique name
.Export imagePath ' Export the chart as an image file
End With
Next shape
' Clean up any remaining shapes in the "Temp" worksheet
shapeCount = currentWorkbook.Worksheets("Temp").Shapes.Count
For shapeIndex = 1 To shapeCount
currentWorkbook.Worksheets("Temp").Shapes.Item(1).Delete
Next shapeIndex
' Hide the "Temp" worksheet again and activate the "Update" worksheet
currentWorkbook.Worksheets("Temp").Visible = xlSheetHidden
currentWorkbook.Worksheets("Update").Activate
' Convert the saved image to Base64 encoding to embed in the email
base64Image = ConvertImageToBase64(imagePath)
' Initialize Outlook and create the email
On Error Resume Next
Set outlookApp = GetObject(, "Outlook.Application") ' Try to hook onto an
existing Outlook session
If outlookApp Is Nothing Then
Set outlookApp = CreateObject("Outlook.Application") ' If Outlook isn't
running, create a new instance
End If
On Error GoTo 0
If outlookApp Is Nothing Then
MsgBox "Outlook is not available. Email cannot be sent.", vbExclamation
Exit Sub
End If
' Create the email item in Outlook
Set outlookMail = outlookApp.CreateItem(0)
currentDate = Format(Date, "dd mmm yyyy") ' Format the current date for the
email subject
' Set the email's content, including the embedded Base64 image
With outlookMail
.To = emailRecipient ' Set the recipient
.CC = ccEmails ' Set the CC recipients
.BCC = "" ' Set the BCC (empty in this case)
.Subject = "Audits and Visits Update as of " & currentDate ' Set the
subject with the current date
.HTMLBody = "<p>Dear Team,</p>" & _
"<p>We would like to update the site audits and visits as of "
& currentDate & ".</p>" & _
"<p>Any additional audits or visits, please let us know to
include in the list and identify support needed.</p>" & _
"<img src=""data:image/jpeg;base64," & base64Image & """><br>"
& _
"<p>Best regards,</p>" & GetFullDisplayName() & ",</p>" ' Add
sender's full display name
.Recipients.ResolveAll ' Resolve recipient addresses
.Display ' Display the email (use .Send to send directly)
End With
' Clean up Outlook objects
Set outlookMail = Nothing
Set outlookApp = Nothing
End Sub
' Convert the image file to Base64 encoding to embed it in the email
Function ConvertImageToBase64(imagePath As String) As String
Dim stream As Object
Dim imageBytes() As Byte
Dim base64String As String
' Create an ADODB stream to read the image file
Set stream = CreateObject("ADODB.Stream")
stream.Type = 1 ' Binary
stream.Open
stream.LoadFromFile imagePath
' Read the image data as binary
imageBytes = stream.Read
stream.Close
' Convert the binary data to Base64
Set stream = Nothing
Dim xmlDoc As Object
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
Dim base64Node As Object
Set base64Node = xmlDoc.createElement("b64")
base64Node.DataType = "bin.base64"
base64Node.nodeTypedValue = imageBytes
base64String = base64Node.Text
base64String = Replace(base64String, vbCrLf, "") ' Remove newline characters
from the Base64 string
ConvertImageToBase64 = base64String ' Return the Base64 string
' Clean up the XML object
Set xmlDoc = Nothing
End Function
' Retrieve the full display name of the current user
Function GetFullDisplayName() As String
Const NameDisplay As Long = 3
Dim displayName As String
Dim bufferSize As Long
' Set buffer size for the name retrieval
bufferSize = 255
displayName = String(bufferSize, vbNullChar)
' Call API to get the full display name of the current user
If GetUserNameEx(NameDisplay, displayName, bufferSize) Then
GetFullDisplayName = Left(displayName, InStr(displayName, vbNullChar) - 1)
' Return the display name
End If
End Function
' Retrieve the email address of the current Outlook user
Function GetUserEmail() As String
Dim outlookApp As Object
Dim outlookNamespace As Object
Dim account As Object
Dim userEmail As String
On Error Resume Next
Set outlookApp = GetObject(, "Outlook.Application") ' Try to hook onto an
existing Outlook session
If outlookApp Is Nothing Then
Set outlookApp = CreateObject("Outlook.Application") ' If Outlook isn't
running, create a new instance
End If
On Error GoTo 0
If outlookApp Is Nothing Then
GetUserEmail = "" ' Return an empty string if Outlook isn't available
Exit Function
End If
' Get the user's email address from the first Outlook account
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
For Each account In outlookNamespace.Session.Accounts
If account.SmtpAddress <> "" Then
userEmail = account.SmtpAddress ' Assign the email address
Exit For
End If
Next account
GetUserEmail = userEmail ' Return the email address
' Clean up
Set outlookNamespace = Nothing
Set outlookApp = Nothing
End Function
' Remove the current user's email from a list of email addresses
Function RemoveUserEmail(emailList As String, userEmail As String) As String
Dim emailArray() As String
Dim cleanedList As String
Dim email As Variant
' Split the email list into an array
emailArray = Split(emailList, ";")
' Loop through each email and remove the current user's email
For Each email In emailArray
If LCase(Trim(email)) <> LCase(Trim(userEmail)) Then
If cleanedList = "" Then
cleanedList = Trim(email)
Else
cleanedList = cleanedList & ";" & Trim(email) ' Append the valid
email to the list
End If
End If
Next email
' Return the cleaned list
RemoveUserEmail = cleanedList
End Function