I have a button and macro currently set up that allows a sheet to save to a folder and close that sheet. Is there a way I can add to the macro so it will email out a message from Outlook saying something along the lines of "machine checklist submitted" to Test123#outlook.com for example. Below is the code i already have that works a treat.
Sub Saveworkbook()
Application.DisplayAlerts = False
Dim Sheet1 As Worksheet
Dim dName$, vName$, sName$
dName = Range("B8")
vName = ActiveWorkbook.FullName
sName = ActiveWorkbook.ActiveSheet.Name
For Each Sheet1 In ActiveWorkbook.Sheets
If Not Sheet1.Name = sName Then
Sheet1.Delete
End If
Next Sheet1
ActiveWorkbook.SaveAs "\\filestore\IT$\Forms and Templates\Completed Checklists\" & dName & "_" & Environ("username") & "_" & Format(Now, "ddmmyy")
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Thanks in advance
Sam
Add below to your code
dim olApp as object, olMail as object
set olApp = createobject("outlook.application")
set olMail = olApp.createitem(0)
With olMail
.To = "Test123#outlook.com"
.Cc = ""
.Bcc = ""
.Subject = "machine checklist submitted"
.body = "machine checklist submitted"
.Send
End With
set olApp = nothing
set olMail = nothing
Related
I am taking a worksheet from a master workbook and creating a separate workbook for each one
These workbooks are then saved into a folder and then each workbook is added to an e-mail.
Each workbook is creating 2 e-mails but I can't see why from the code?
Sub MoveandSaveWorkBooks()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wK As Worksheet
For Each wK In ThisWorkbook.Worksheets
If wK.name = "Master Data" Then
ElseIf wK.name = "Button" Then
Else
wK.Copy
Selection.RowHeight = 84.75
Cells.EntireColumn.AutoFit
ActiveWorkbook.Password = UserInput
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & wK.name & ".xlsx"
Dim OlApp As Object
Dim NewMail As Object
Set OlApp = CreateObject("Outlook.Application")
Set NewMail = OlApp.CreateItem(0)
On Error Resume Next
With NewMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = ""
.Attachments.Add ActiveWorkbook.FullName
.display
End With
On Error GoTo 0
Set NewMail = Nothing
Set OlApp = Nothing
ActiveWorkbook.Close True
End If
Next wK
Application.DisplayAlerts = True
Application.ScreenUpdating = True
I have a simple code to open Microsoft Outlook and send an email with an attachment. I would like to send the email securely. Meaning, I would like to know if there is any code that would be tantamount to pressing the "Send Securely" button in outlook. Here is my code so far.....
Sub EmailInvoice()
Dim OutlookApp As Object, OutlookMessage As Object
Dim FileName As String, EmailAddress As String
EmailAddress = Range("ProviderEmail").Value
FileName = "C:\Users\rblahblahblah.txt"
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if
Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp =
CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
Exit Sub
End If
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
With OutlookMessage
.To = EmailAddress
.CC = ""
.BCC = ""
.Subject = "Invoice for Upload - " & Month
.Body = "Please upload the attached file to the Vendor Portal."
.Attachments.Add FileName
.Display
.Send
End With
End Sub
The code below will send it with a sensitivity enumeration but not securely (Certified Mail). I also add my signature (Default) to the email.
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2013
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim SigString As String
Dim Signature As String
For Each cell In ThisWorkbook.Sheets("Email List").Range("B1:B100")
If cell.Value Like "?*#?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.to = strto
.CC = ""
.BCC = ""
.Subject = ("*Confidential*: Policyholder Name Here - Policy # Here - Premium Bill")
.HTMLBody = "Attached is the most recent premium bill in Excel." & "<br><br>" & Signature
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Importance = 2 '(0=Low, 1=Normal, 2=High)
.Sensitivity = 3 '(0=Normal, 1=Personal, 2=Private, 3=Confidential)
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
I have got a workbook with 4 sheets:
1st - recipients email data such as TO, CC, Subject, from 2nd to 4th
the sheets which I need to send as an attachment to the recipients.
I made up the following script. But I faced 2 issues as a VBA beginner:
The 'loop' proposes for sending the 1st empty row from the 1st sheet
as well (I would like to stop with the last email details);
The 'ActiveWorkbook' sends all sheets (I would like to skip the 1st
one where the recipients & the VBA script are located);
I appreciate every advice/remark because I have been studying VBA for 3 months.
Thank you in advance!
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
End Sub
Have a look at this. This takes a copy of your workbook and saves it to the users "temp" location. It then does the modifications that you want to the copy of the workbook before attaching that.
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
Dim wb As Workbook, nwb As Workbook
Application.ScreenUpdating = False
Set wb = ThisWorkbook
wb.SaveCopyAs (Environ("temp") & "\temp_" & wb.Name)
Set nwb = Workbooks.Open(Environ("temp") & "\temp_" & wb.Name)
With nwb
Application.DisplayAlerts = False
' Delete relevant sheet
.Sheets(1).Delete
Application.DisplayAlerts = True
.Save
End With
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add nwb.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
nwb.Close
Application.ScreenUpdating = True
End Sub
Save a copy of your workbook
Open it
Remove the sheet from the copy
Save
Send this edited workbook
I'm using the basic VBA code to send an email with a copy of my spreadsheet on a daily basis. The email subject is always the same.
I want these emails to appear in Outlook as the same conversation, so that they are nested/threaded when using Conversation view. However, these emails always come up as a new conversation.
How can I set a property in the OutMail variable below similar to .subject etc to create my own ConversationID / ConversationIndex that is always identical so that emails appear nested?
VBA code:
Dim Source As Range 'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:AQ45").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = "C:\temp\"
TempFileName = "MyReport " & Format(Now, "yyyy-mm-dd hh-mm-ss")
FileExtStr = ".xlsx": FileFormatNum = 51
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
End With
With Dest
With OutMail
.to = "xyz#zyx.com"
.CC = ""
.BCC = ""
.Subject = "Subject Report 1"
.HTMLBody = RangetoHTML(Range("A1:AQ45"))
.Attachments.Add Dest.FullName
.Send
End With
End With
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
With Dest
On Error GoTo 0
.Close savechanges:=False
End With
This is the Outlook code that you can port over to Excel, using the method I suggest in the comments above.
Sub test()
Dim m As MailItem
Dim newMail As MailItem
Dim NS As NameSpace
Dim convo As Conversation
Dim cItem
Dim entry As String 'known conversationID property
Set NS = Application.GetNamespace("MAPI")
'Use the EntryID of a known item
'## MODIFY THIS BASED ON YOUR ENTRYID PROPERTY!! ##
entry = "0000000019EF3F5F49714748915AA379833C20460700D6CCDE850A3B9D41A5B930CCE1E12030000337DBD42F00003C7DFC9FAAF8254DACC71DEEEC1DF0A30003ADA9AF2D0000"
'Get a handle on this item:
Set m = NS.GetItemFromID(entry)
'Get a handle on the existing conversation
Set convo = m.GetConversation
'Get a handle on the conversation's root item:
Set cItem = convo.GetRootItems(1)
'Create your new email as a reply thereto:
Set newMail = cItem.Reply
'Modify the new mail item as needed:
With newMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Subject Report 1"
.HTMLBody = RangeToHTML(Range("A1:AQ45"))
.Attachments.Add Dest.FullName
.Display
'.Send
End With
End Sub
I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?
Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?
Code:
Sub SplitFile()
Dim rTemp As Range
Dim regions() As String
Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
Set wb = Workbooks.Add
ThisWorkbook.Sheets("DVal").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
With ThisWorkbook.Sheets("Combined")
.AutoFilterMode = False
' .AutoFilter
.Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
Application.DisplayAlerts = False
.Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
Application.DisplayAlerts = True
For c = 1 To 68
wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
With wb
.Sheets("Sheet1").Activate
.SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
.Close True
End With
Set wb = Nothing
Next N
End Sub
I am assuming you want to do it programmaticaly using VB, you can do something like
Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage()
msg.From = "noone#nobody.com"
msg.To = "someone#somewhere.com"
msg.Subject = "Email with Attachment Demo"
msg.Body = "This is the main body of the email"
Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls")
msg.Attachments.Add(attch)
SmtpMail.Send(msg)
If you're having trouble with the above, my mail macro is different; this is used with excel 2007:
Sub Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
"This is a test!" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.to = "anyone#anywhere.com"
.cc = ""
.BCC = ""
.Subject = "This is only a test"
.Body = strbody
'You can add an attachment like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Jon
I am assuming the following.
1) Regions are in Col AH
2) Contacts are in Col AI
3) UniqueItems() in your code removes duplicates?
Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.
NOTE: I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.
Option Explicit
Sub SplitFile()
'~~> Excel variables
Dim wb As Workbook, wbtemp As Workbook
Dim rTemp As Range, rng As Range
Dim regions() As String, FileExt As String, flName As String
Dim N As Long, FileFrmt As Long
'~~> OutLook Variables
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strTo As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'~~> Just Regions
Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
'~~> Regions and Email address. We wil require this later
'~~> Tofind email addresses
Set rng = wb.Sheets("Combined").Range("AH2:AI1455")
regions = UniqueItems(rTemp, False)
'~~> Create an instance of outlook
Set OutApp = CreateObject("Outlook.Application")
For N = 1 To UBound(regions)
Set wb1 = Workbooks.Add
wb.Sheets("DVal").Copy after:=wb1.Sheets(1)
With wb.Sheets("Combined")
.AutoFilterMode = False
With .Range("A1:BP1455")
.AutoFilter Field:=34, Criteria1:=regions(N)
'~~> I think you want to copy the filtered data???
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
wb1.Sheets("Sheet1").Range("A1")
For c = 1 To 68
wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
wb.Columns(c).ColumnWidth
Next c
End With
End With
'~~> Set the relevant Fileformat for Save As
' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
FileFrmt = 52
Select Case FileFrmt
Case 50: FileExt = ".xlsb"
Case 51: FileExt = ".xlsx"
Case 52: FileExt = ".xlsm"
Case 56: FileExt = ".xls"
End Select
'~~> Contruct the file name.
flName = "H:\" & regions(N) & " 14-12-11" & FileExt
'~~> Do the save as
wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
wb1.Close SaveChanges:=False
'~~> Find the email address
strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)
'~~> Create new email item
Set OutMail = OutApp.CreateItem(0)
'~~> Create the body of the email here. Change as applicable
strbody = "Dear Mr xyz..."
With OutMail
.To = strTo
.Subject = regions(N) & " 14-12-11" '<~~ Change subject here
.Body = strbody
.Attachments.Add flName
'~~> Uncomment the below if you just want to display the email
'~~> and comment .Send
'.Display
.Send
End With
Next N
LetContinue:
Application.ScreenUpdating = True
'~~> CleanUp
On Error Resume Next
Set wb = Nothing
Set wb1 = Nothing
Set OutMail = Nothing
OutApp.Quit
Set OutApp = Nothing
On Error GoTo 0
Whoa:
MsgBox Err.Description
Resume LetContinue
End Sub