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
Related
I am using below code to send multiple emails through outlook, this code is working fine when I use Excel 2007 and Outlook 2007 however when I tried to run same code in Excel 2013 and Outlook 2013 it is throwing an error "Runtime Error 424: Object not Defined" in the below code:
Set Doc = olMail.GetInspector.WordEditor
Can somebody please check below coding and let me know what do I need to change if I want to use same macro in 2013 version?
Sub Msmail()
Dim otlApp As Object
Dim olMail As Object
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set mainWB = ActiveWorkbook
Worksheets("Mail").Select
ActiveSheet.Calculate
Total_Site = Range("Total_Site")
For Site_Count = 1 To Total_Site
Application.StatusBar = False
ActiveSheet.Calculate
Range("Site_Count") = Site_Count
ActiveSheet.Calculate
If Range("Send_Email") = "Y" Then
Set mainWB = ActiveWorkbook
Set olMail = otlApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor '<~ ERROR 424 HERE
SendID = mainWB.Sheets("Mail").Range("To_List").Value
CCID = mainWB.Sheets("Mail").Range("Cc_List").Value
Subject = mainWB.Sheets("Mail").Range("Subject_Line").Value
Body = mainWB.Sheets("Summary").Range("Mail_Body").Value
AttachFile = mainWB.Sheets("Mail").Range("StrPath").Value
StrPath = ActiveSheet.Range("StrPath").Value
With olMail
.To = SendID
If CCID <> 0 Then
.CC = CCID
End If
.Subject = Subject
mainWB.Sheets("Summary").Range("Mail_Body").Copy
Set WrdRng = Doc.Range
.Display
WrdRng.Paste
'StrPath = Range("StrPath").Value
StrFile = Range("StrFile").Value & "*.*"
StrFile = Range("StrFile").Value
.Attachments.Add StrPath & "\" & StrFile
.Send
End With
End If
Next Site_Count
End Sub
OK - so there appear to be quite a lot of issues with the current code; you have duplication of code and non-dimensioned variables. I have tried to condense the code down, added direct references and this will hopefully make it more readable and (should maybe) work, but it's untested... I don't have the ranges set out in relevant sheets and no data to test it
Sub msMail()
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olMail As Object
Dim Total_Site As Range, Doc As Variant, WrdRng As Range
Dim StrPath As String, StrFile As String, Site_Count As Long
Dim wbMain As Workbook: Set wbMain = ThisWorkbook
Dim wsMail As Worksheet: Set wsMail = wbMain.Worksheets("Mail")
Dim wsSumm As Worksheet: Set wsSumm = wbMain.Worksheets("Summary")
With wsMail
.Calculate ' Not sure why this is included...
Set Total_Site = Range("Total_Site")
For Site_Count = 1 To Total_Site.Count
''Application.StatusBar = False
Range("Site_Count") = Site_Count
If Range("Send_Email") = "Y" Then
Set olMail = olApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor
If Not Doc Is Nothing Then
With olMail
.To = wsMail.Range("To_List")
.CC = IIf(wsMail.Range("Cc_List") <> 0, wsMail.Range("Cc_List"), "")
.Subject = wsMail.Range("Subject_Line")
wsSumm.Range("Mail_Body").Copy
Set WrdRng = Doc.Range
.Display
WrdRng.Paste
StrPath = wsMail.Range("StrPath")
StrFile = wsMail.Range("StrFile")
.Attachments.Add StrPath & "\" & StrFile
' .Send
End With
End If
End If
Next Site_Count
End With
End Sub
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
Is there any way I can attach as well as send a worksheet as an email body.
The below VBA code sends the worksheet as an attachment.
How can I send a worksheet in the body of email?
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim wbTemp As Workbook
Dim strFilename As String
Dim Sendrng As Range
ThisWorkbook.Worksheets("Test Worksheet").Copy
Set wbTemp = ActiveWorkbook
wbTemp.SaveAs ThisWorkbook.Path & "/" & "TestWb", XlFileFormat.xlOpenXMLWorkbook
strFilename = wbTemp.FullName
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "test#testdomain.com"
.CC = ""
.BCC = ""
.Subject = "Test Email"
.Body = ""
.Attachments.Add strFilename
.display
End With
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
wbTemp.Close
Kill strFilename
End Sub
Private Sub CommandButton1_Click()
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sendrng = Worksheets("Sheet1").Range("A1:g15")
Set AWorksheet = ActiveSheet
With Sendrng
.Parent.Select
Set rng = ActiveCell
.Select
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = "recipient"
.CC = ""
.BCC = ""
.Subject = "My subject"
.Send
End With
End With
rng.Select
End With
AWorksheet.Select
Sheet1.Activate
Range("c2:c3").ClearContents
Range("e2:e3").ClearContents
Range("c5") = ""
Range("B8:b10").ClearContents
Range("c8:c10").ClearContents
Range("d8:d10").ClearContents
Range("e8:e10").ClearContents
Range("f8:f10").ClearContents
Range("g8:g10").ClearContents
Range("b13") = ""
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
End Sub
you should add your code that also copies it to this. Forgive all the crap you dont need here, I just copy and pasted one I have been using
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