Open message file
Sub OpenMsgFile()
Dim olApp As Object
Dim olMsg As Object
'Create Outlook Application object
Set olApp = CreateObject("Outlook.Application")
'Open .msg file
Set olMsg = olApp.CreateItemFromTemplate("C:\Users\username\Downloads\test.msg")
'Display the message
olMsg.Display
'Clean up
Set olMsg = Nothing
Set olApp = Nothing
End Sub
Save Email Attachments
Sub SaveEmailAttachments()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Dim olAttachment As Outlook.Attachment
Dim savePath As String
Dim fileName As String
Dim i As Long
' Set folder path where you want to save attachments
savePath = "C:\Users\username\Downloads\test\"
' Ensure path ends with backslash
If Right(savePath, 1) <> "\" Then savePath = savePath & "\"
'Create Outlook objects
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
' Select folder (e.g., Inbox)
Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
'Loop through each mail item in the folder
For Each olItem In olFolder.Items
'Check if it's a mail item
If TypeName(olItem) = "MailItem" Then
'Check if it has attachments
If olItem.Attachments.Count > 0 Then
For i = 1 To olItem.Attachments.Count
Set olAttachment = olItem.Attachments(i)
fileName = olAttachment.fileName
' Save attachment
olAttachment.SaveAsFile savePath & fileName
Next i
End If
End If
Next olItem
MsgBox "Attachments saved to: " & savePath, vbInformation
End Sub
Send Mail Notification
Sub SendMailNotification()
' ********* Send Mail Notification based on recepient in list in scheduling sheet ************
Dim oMSOutlook As Object
Dim oEmail As Object
Dim sName As String
sName = "Summary" 'change sheet name here
ReporterName = Environ$("UserName")
If ReporterName = "" Then
ReporterName = Mid(WorksheetFunction.Substitute((Environ$("UserProfile")), "\", "_", 2), WorksheetFunction.Find("_", WorksheetFunction.Substitute((Environ$("UserProfile")), "\", "_", 2)) + 1, 8)
End If
SignatureReporterName = "XYZ" 'Application.UserName
DestinationDriveFolderLink = Sheets(sName).Range("F32").Value
UserComments = "<a href=""" & Sheets(sName).Range("F40").Value & """>Final Report</a>"
FAQ = "<b>Note:</b> Please feel free to share your feedback or report issues by replying to this email. For common issues, refer to the " & "<a href=""" & Sheets(sName).Range("F48").Value & """>FAQ</a>."
FirstLine = "Dear All," 'Sheets(sName).Range("F72").Value
SecondLine = "The Final Report is now updated with " & "<b>Day +3</b>" & " financials. " & "<b>All tabs in the report are updated</b>" & ". Please use the link below to view the dashboard."
If Left(DestinationDriveFolderLink, 2) = "\\" Then
If Sheets(sName).Range("F44") = "" Then
DestinationDriveFolderLink = Sheets(sName).Range("F32").Value & "\" & ActiveWorkbook.Name
Else
DestinationDriveFolderLink = Sheets(sName).Range("F32").Value & "\" & Sheets(sName).Range("F44") & Right(ActiveWorkbook.Name, 5)
End If
ElseIf Left(DestinationDriveFolderLink, 4) = "http" Then
DestinationDriveFolderLink = WorksheetFunction.Substitute(DestinationDriveFolderLink, "\", "/")
Else
If Sheets(sName).Range("F44") = "" Then
DestinationDriveFolderLink = Sheets(sName).Range("F32").Value & "\" & ActiveWorkbook.Name
Else
DestinationDriveFolderLink = Sheets(sName).Range("F32").Value & "\" & Sheets(sName).Range("F44") & Right(ActiveWorkbook.Name, 5)
End If
End If
Link1 = "<A HREF=""" & DestinationDriveFolderLink & """>" & DestinationDriveFolderLink & "</A>"
If Sheets(sName).Range("F36").Value = "" Then
ToSenderName = ReporterName
Else
ToSenderName = Sheets(sName).Range("F36").Value '& ";" & ReporterName
End If
Set oMSOutlook = CreateObject("Outlook.Application")
Set oEmail = oMSOutlook.CreateItem(olMailItem)
sSubject = "Final Report" 'WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "")
MsgBody = "<font size=""2"" face=""Arial"" color=""Black"">" & _
FirstLine & "<br>" & "<br>" & _
SecondLine & "<br>" & "<br>" & _
UserComments & "<br>" & "<br>" & "<br>" & _
FAQ & "<br>" & "<br>" & _
"Best Regards," & "<br>" & _
SignatureReporterName
On Error GoTo DefaultMail:
With oEmail
.SentOnBehalfOfName = "Final.Report@gmail.com"
.To = "" 'ToSenderName
.CC = "" 'Sheet1.Range("I37")
.BCC = ToSenderName
.Subject = "" & sSubject
.HTMLBody = MsgBody
'.Send
.display
End With
DefaultMail:
If Err.Number <> 0 Then
MsgBody2 = "<font size=""2"" face=""Arial"" color=""Black"">" & _
"Message: Report generated successfully and saved in below path: " & "<br>" & "<br>" & _
"Path: " & Link1 & "<br>" & "<br>" & _
"Error: Mail Notification is not received to Recipients, as Mail-ID/username are not correct OR blank OR not seperated by Semicolon" & "<br>" & "<br>" & _
"Best Regards," & "<br>" & _
SignatureReporterName
With oEmail
.To = ReporterName
.Subject = "" & sSubject
.HTMLBody = MsgBody2
.Send
End With
Else
Flag = False
End If
Set oMSOutlook = Nothing
Set oEmail = Nothing
End Sub
Send an Email from Excel/Word/PowerPoint
Must add a reference: Microsoft Outlook Object Library
Sub SendEmail()
Dim OutApp As Object, Mail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Mail = OutApp.CreateItem(0)
With Mail
.To = "someone@example.com"
.Subject = "Hello from VBA"
.Body = "Automated message sent at " & Now
.Send
End With
End Sub