I have a workbook that I am trying to email with macros. This way the recipient will also be able to use the macros that are included with the workbook. This will make office life easier for my company. I have tried setting the saved file name to .xlsm, but that causes an error.
This is my code (which is adapted from sources online)
Sub MailGo()
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to
'a temporary file
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = "Text.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\Users\Public\Documents" & FileName
'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = "wesley.x.sherow#us.tel.com"
.Cc = ""
.Bcc = ""
.Subject = "LotInput"
.Body = "LotInput"
.Attachments.Add WB.FullName
.Display
.send
End With
'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
you need to also include this argument in your .SaveAs line.
FileFormat:=xlOpenXMLWorkbookMacroEnabled
Related
I've written a macro/piece of code in excel vba to send the current worksheet to a specific email in .txt format but when I receive the email there are several unneeded commas listed in the file I'm just trying to possibly find a piece of code that will remove these extra commas when the file is sent over in the email. I currently have another macro created which opens and reads the file and removes the unwanted commas but i am having to save the email attachment first whereas I'd like to just receive the clean .txt file directly to my email.
The current .txt file I am receiving looks like;
S99,2602,7/12/2017,
10405,PUSH NUT PLAIN 1/4,2.000,EACH
WVC424,CORD 2.2MM E/S CHESTNUT,3.800,MTR
,,,
whereas I need it to look like;
S99,2602,7/12/2017
10405,PUSH NUT PLAIN 1/4,2.000,EACH
WVC424,CORD 2.2MM E/S CHESTNUT,3.800,MTR
For It to be read into our system.
Sub EmailAsCSV()
'
' EmailAsCSV Macro
'
Dim csvFiles(1 To 3) As String, i As Integer
Dim wsName As Variant
Dim OutApp As Object, OutMail As Object
i = 0
For Each wsName In Array("Sheet1") 'sheet names to be emailed - CHANGE THE SHEET NAMES
i = i + 1
csvFiles(i) = ThisWorkbook.Path & "\" & wsName & ".txt"
ThisWorkbook.Worksheets(wsName).Copy
ActiveWorkbook.SaveAs csvFiles(i), FileFormat:=xlCSV
ActiveWorkbook.Close False
Next
'Email the .csv files
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ThisWorkbook.Worksheets("Sheet2").Range("E1").Value 'cell containing email address - CHANGE THE SHEET NAME AND CELL
.CC = ""
.BCC = ""
.Subject = "Order"
.Body = "This email contains 1 file attachment with an order."
.Attachments.Add csvFiles(1)
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
'Delete the .csv files
Kill csvFiles(1)
'
End Sub
Sub test()
Dim fn As String, txt As String
fn = Application.GetOpenFilename("TextFiles,*.txt")
If fn = "" Then Exit Sub
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
.Pattern = ",+$"
Open Replace(fn, ".txt", "_Clean.txt") For Output As #1
Print #1, .Replace(txt, "")
Close #1
End With
End Sub
The code I have currently got is listed above.
Try saving it in text format instead?
FileFormat:=xlText
You can copy just the used range (not tested):
ThisWorkbook.Worksheets(wsName).UsedRange.CurrentRegion.Copy
With Workbooks.Add
.Sheets(1).Paste
.SaveAs csvFiles(i), FileFormat:=xlCSV
.Close False
End With
or paste the values without formatting (also not tested):
ThisWorkbook.Worksheets(wsName).UsedRange.Copy
With Workbooks.Add
ActiveCell.PasteSpecial xlPasteValues
.SaveAs csvFiles(i), FileFormat:=xlCSV
.Close False
End With
I have an Excel workbook, with several worksheets in it. Each worksheet is a document I would like to email separately.
I have the workbook on a Windows XP SP3 machine running Office 2007. The VBA code works perfectly, and I can email each individual worksheet.
I need to run this on a Windows 7 or Windows 10 PC, again with Office 2007. This is where I get the error:
Sub EmailWithOutlook()
Dim oApp As Object
Dim oMail As Object
Dim WB As Workbook
Dim FileName As String
Dim wSht As Worksheet
Dim shtName As String
Application.ScreenUpdating = False
' Make a copy of the active worksheet
' and save it to a temporary file
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = WB.Worksheets(1).Name
On Error Resume Next
Kill "C:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\" & FileName
'Create and show the Outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
'Uncomment the line below to hard code a recipient
'.To = "testuser#test.com"
'Uncomment the line below to hard code a subject
'.Subject = "Subject Line"
'Uncomment the lines below to hard code a body
'.body = "Dear John" & vbCrLf & vbCrLf & _
'"Here is the file you asked for"
.Attachments.Add WB.FullName
.Display
End With
'Delete the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restore screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
The routine stops on the line containing the following:
WB.SaveAs FileName:="C:\" & FileName
What am I missing?
Windows users by default do not have permission to write at C:\ root directory.
Solutions:
Use a sub directory where the user has permission to write
Change user permission to gain write access at C:\ (not recommended)
My codes run fine until I get to closing the workbook. Here's my code:
.....
With olMail
.Subject = "Hi " & ActiveWorkbook.Name
.Body = strSubject
.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
.display
End With
Set olApp = Nothing
Set olNameSpace = Nothing
Set olMail = Nothing
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWorkbook.Saved = True
DoEvents
ActiveWorkbook.Close <<<<===== I see the BLANK EXCEL WINDOW HERE!
Application.EnableEvents = True
Exit Sub
I'm not sure if this is a bug with excel 2016 or not but this is the whole window of excel, it is missing the ribbon:
It's because you close the workbook and not the application.
Use Application.Quit
I have created a VBA module that :
searches for a specific email in outlook
grabs the excel file attachment from the email it finds
formats the excel file attachment (adds colors and grid to make it look more presentable)
saves the formatted excel file to my desktop
sends email(s) to our client with the formatted excel file as an attachment (and pastes the excel file into the body of the email)
** I use multiple arrays to send to individual clients
My code works pretty well and has worked without issues many times. However, every now and again it will have a '1004 run time error' pop up randomly while processing. When I debug, it takes me to 'ActiveWorkbook.Save'. Usually if I run it again it works just fine, but I need it to be more user friendly for others to use. Code is as follows.
Public f As Integer 'format integer
Sub Clients()
'Array([file destination to be saved], [subject of file being searched in outlook], [file name given when saved], [emails the report is going to])
f = 0
email_1 = Array("C:\User\Desktop\", "FL Test Results", "FL_Reports", "client1#email.com")
Call Reports(email_1)
f = 1
email_2 = Array("C:\User\Desktop\", "CA Test Results", "CA_Reports", "client2#email.com")
Call Reports(email_2)
f = 2
email_3 = Array("C:\User\Desktop\", "NY Test Results", "NY_Reports", "client3#email.com")
Call Reports(email_3)
email_4 = Array("C:\User\Desktop\", "TX Test Results", "TX_Reports", "client4#email.com")
Call Reports(email_4)
End Sub
Function Reports(a As Variant)
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim olFldr As MAPIFolder
Dim olItms As Items
Dim olMi As MailItem
Dim olEmail As Outlook.MailItem
Dim olAtt As Attachment
Dim subj As String
Dim saveAs As String
Dim emails As String
Dim FilePath As String
FilePath = a(0)
subj = a(1)
saveAs = a(2)
emails = a(3)
Set olApp = GetObject(, "Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set olEmail = olApp.CreateItem(olMailItem)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set olMi = olItms.Find("[Subject] = " & Chr(34) & subj & Chr(34))
If Not (olMi Is Nothing) Then
For Each olAtt In olMi.Attachments
olAtt.SaveAsFile FilePath & saveAs & ".xls"
Workbooks.Open (FilePath & saveAs & ".xls")
Call format.Run 'Seperate file that formats the raw excel sheet to look more pretty
If f = 0 Then
Call format.DeleteOldClasses 'different ways clients want there excel file info sorted
ElseIf f = 1 Then
Call format.sortByDate
Else
End If
ActiveWorkbook.Save '#######This is where the error pops up
Set rng = Worksheets(saveAs).UsedRange
Next olAtt
End If
On Error Resume Next
With OutMail
.Attachments.Add FilePath & saveAs & ".xls"
.To = emails
.CC = ""
.BCC = ""
.subject = subj
.HTMLBody = RangetoHTML(rng)
.send
End With
On Error GoTo 0
ActiveWorkbook.Close
Kill (FilePath & saveAs & ".xls")
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set olAtt = Nothing
Set olMi = Nothing
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Thank you for your time and help.
So I found a solution that works for me but maybe not others with the same issue. I Set my workbooks as #findwidow and #R3uk suggested. I simply put "On Error Resume Next" and save an extra copy in a new place that I pull the attachment from to place in the email.
On Error Resume Next
wB.Save
wB.SaveCopyAs ("C:\Users\Ken\Desktop\" & saveAs & ".xls")
Set rng = Worksheets(saveAs).UsedRange
Next olAtt
End If
It wont save the formatted excel file at times during the error, however this rarely happens now and it is only for our own documentation. It now continues through the cycle of client arrays with ease (and actually seems faster). Thank you for the help.
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