Excel VBA - Send Email via CDO.message - cannot add attachment - excel

I am following this tutorial to send emails via Gmail SMTP which is working well, but fails when it comes to adding an attachment.
http://www.learnexcelmacro.com/wp/2011/12/how-to-send-an-email-using-excel-macro-from-gmail-or-yahoo/
I am trying to send a copy of the active workbook which is saved into the users TEMP Appdata folder. I traced the temp file, checked for the files existence which is alright and should not be a problem, however, excel doesnt seem to attach it. I can however attach a file if I hardcode it (eg. "C:\temp\file.xls"), but not when the file path is given via variables.
Can anyone point me in the right direction please? I am out of ideas...
EDIT:
just to clarify, I tried several syntax's such as defining the path in the Gmail_Attachment variable or adding the TempFilePath & TempFileName & FileExtStr variables. None of them work, only if I literally code it as .addattachment "C:/path/file.xls" does it attach.
Sub Mail_Gmail()
'Working in 2000-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb, Destwb As Workbook
Dim TempFilePath, TempFileName As String
Dim SendTo, SendCC, Holidex, Property, QCI_Mgr, Position As Range
Dim Gmail_ID, Gmail_PWD, Gmail_SMTP, Gmail_attachment As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Set SendTo = ActiveWorkbook.Sheets("Settings").Range("B20")
Set SendCC = ActiveWorkbook.Sheets("Settings").Range("B21")
Set Holidex = ActiveWorkbook.Sheets("Settings").Range("B5")
Set Property = ActiveWorkbook.Sheets("Settings").Range("B4")
Set QCI_Mgr = ActiveWorkbook.Sheets("Settings").Range("B14")
Set Position = ActiveWorkbook.Sheets("Settings").Range("B15")
Gmail_SMTP = "smtp.gmail.com"
Gmail_ID = "user#gmail.com"
Gmail_PWD = "password"
'Copy the sheet to a new workbook
ActiveSheet.Copy Before:=Sheets(1)
With ActiveSheet
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
'.ShowAllData ' disable autofilters
.Cells.Copy
.Cells.PasteSpecial xlValues
End With
Application.CutCopyMode = False
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
'FileExtStr = ".pdf": FileFormatNum = 17
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in the worksheet to values if you want
'With Destwb.Sheets(1).Range("A1:I50")
' .Select
' .Copy
' .PasteSpecial xlPasteValues
'End With
'Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")
Set NewMail = CreateObject("CDO.Message")
' Define Gmail configuration
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True ' Enalbe SSL
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 ' SMTP Authentication ON
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Gmail_SMTP ' SMTP Server address
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 ' SMTP port
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' SMTP encryption
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Gmail_ID ' Gmail ID
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Gmail_PWD ' Gmail PWD
NewMail.Configuration.Fields.Update ' Update all settings
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
.Close savechanges:=False
On Error Resume Next
Gmail_attachment = TempFilePath & TempFileName & FileExtStr
'Set All Email Properties
With NewMail
.From = Gmail_ID
.To = SendTo
.CC = SendCC
.BCC = ""
.Subject = Holidex & " System Login - " & ThisWorkbook.Name & " - " & Format(Now, "dd-mm-yyyy")
.textbody = "The following client has just logged in to this system:" & vbNewLine _
& "Date: " & Format(Now, "dd-mm-yyyy hh:ss") & vbNewLine _
& "System: F&B Feedback Card Summary" & vbNewLine _
& "Filename: " & ThisWorkbook.FullName
'.HTMLBody = "Write your complete HTML Page"
' For multiple Attachment you can add below lines as many times
.AddAttachment Gmail_attachment
End With
NewMail.Send ' or use .display
'MsgBox Gmail_attachment, vbOKOnly, "String"
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
' Delete the duplicated worksheet and turn off prompts
Application.DisplayAlerts = False
With ActiveWorkbook
.ActiveSheet.Select
.ActiveSheet.Delete
.Sheets("Summary").Select
End With
Application.DisplayAlerts = True
' Clean up
Set NewMail = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The problem is here in this section where one adds the .attachment "C:\file.xls" variable
'Set All Email Properties
With NewMail
.From = Gmail_ID
.To = SendTo
.CC = SendCC
.BCC = ""
.Subject = Holidex & " System Login - " & ThisWorkbook.Name & " - " & Format(Now, "dd-mm-yyyy")
.textbody = "The following client has just logged in to this system:" & vbNewLine _
& "Date: " & Format(Now, "dd-mm-yyyy hh:ss") & vbNewLine _
& "System: F&B Feedback Card Summary" & vbNewLine _
& "Filename: " & ThisWorkbook.FullName
'.HTMLBody = "Write your complete HTML Page"
' For multiple Attachment you can add below lines as many times
.AddAttachment Gmail_attachment
End With

The script does not support attaching open workbooks, hence I had to place .Close savechanges:=False right after the save dialog which solved the issue. Original post has been edited.

Related

Compiling condition across multiple worksheets to output 1 "solution". Also call out which worksheets(s) fit the condition

I am new to vba and struggling with trying to accomplish having a single overall email send out if any worksheet column L/M have a value below 1 and want it to call out which sheet (or sheets) had the value <1 in the email body or subject line. I have spent countless hours searching the web, but nothing so far has really worked for me. The MsgBox function is working fine, just having issues with compiling the results to 1 email naming which worksheet had the <1 value and 1 "solution" for the whole workbook, instead of having an email sent for every single worksheet that the conditions fit. Thank you in advance.
Option Explicit
Sub Main()
Dim sh As Worksheet, i As Long
For Each sh In ActiveWorkbook.Worksheets
With WorksheetFunction
If .CountIf(sh.Range("L3:L26"), "<1") > 0 Then
Call SendReminderMail1
Else
MsgBox "Rotations NOT needed for """ & sh.Name & """."
End If
If .CountIf(sh.Range("M3:M20"), "<1") > 0 Then
Call SendReminderMail2
Else
MsgBox "Functions are NOT needed for """ & sh.Name & """."
End If
End With
Next
End Sub
Sub SendReminderMail1()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sh As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "test#test.com"
.CC = ""
.BCC = ""
.Subject = "Rotations are due for """ & sh.Name & """."
.Body = "Hi there bud, ya need to take a good ole look at this here document. You've been slackin', let's fix that."
.Attachments.Add wb2.FullName
.Display 'or use .Display
End With
On Error GoTo 0
wb2.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your Automated Email for Rotations was successfully ran at " & TimeValue(Now), vbInformation
End Sub
Sub SendReminderMail2()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sh As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "test#test.com"
.CC = ""
.BCC = ""
.Subject = "Functions are due for """ & sh.Name & """."""
.Body = "Hi there bud, ya need to take a good ole look at this here document."
.Attachments.Add wb2.FullName
.Display 'or use .Display
End With
On Error GoTo 0
wb2.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your Automated Email for Functions was successfully ran at " & TimeValue(Now), vbInformation
End Sub
Try something like this:
Sub Main()
Dim sh As Worksheet, i As Long, shtsRotations As String
Dim shtsFunctions As String, shtsOK As String
For Each sh In ActiveWorkbook.Worksheets
If Application.CountIf(sh.Range("L3:L26"), "<1") > 0 Then
shtsRotations = shtsRotations & vbLf & sh.Name
Else
shtsOK = shtsOK & vbLf & sh.Name & " (Rotations)"
End If
If Application.CountIf(sh.Range("M3:M20"), "<1") > 0 Then
shtsFunctions = shtsFunctions & vbLf & sh.Name
Else
shtsOK = shtsOK & vbLf & sh.Name & " (Functions)"
End If
Next sh
If Len(shtsRotations) > 0 Then
SendReminderMail "test#test.com", "Rotations are due for worksheet(s).", _
"Hi there bud, ya need to take a good ole look at this here document." & _
"Check sheets: " & shtsRotations & vbLf & _
"You've been slackin', let's fix that."
End If
If Len(shtsFunctions) > 0 Then
SendReminderMail "test#test.com", "Functions are due for worksheet(s).", _
"Hi there bud, ya need to take a good ole look at this here document." & _
"Check sheets: " & shtsFunctions & vbLf & _
"You've been slackin', let's fix that."
End If
If Len(shtsOK) > 0 Then
MsgBox "These sheets are OK: " & vbLf & shtsOK, vbInformation
End If
End Sub
Sub SendReminderMail(sTo As String, sSubject As String, sBody As String)
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sh As Worksheet
Dim TempFilePath As String, TempFileName As String
Dim FileExtStr As String, OutApp As Object, OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "test#test.com"
.CC = ""
.BCC = ""
.Subject = sSubject
.Body = sBody
.Attachments.Add wb2.FullName
.Display
End With
On Error GoTo 0
wb2.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your Automated Email was successfully ran at " & TimeValue(Now), vbInformation
End Sub
You can reduce your code size by creating a single sub to send a mail, and passing in the variable parts.

Save a file without overwriting an existing file

I need to rewrite this macro so it won't overwrite the file. I tried various solutions, but I can't get them to work.
Here is the macro I have written so far:
Sub email_workbook()
Dim wb1 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = Range("H22") & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "person1#PLACE.COM"
.CC = "MPERSON#PLACE.COM" & " " & "LPERSON#PLACE.COM"
.BCC = ""
.Subject = "SUBJECT" & Range("H22")
.Body = "Please review ETC.ETC."
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display
End With
On Error GoTo 0
Dim myFile As String
myFile = ActiveWorkbook.Name
Application.DisplayAlerts = False ' Disregard overwriting message.
ActiveWorkbook.SaveAs Filename:="U:\Public\WAKKA\WAKKAWAKKA - To Review"
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Call SaveFileExcel
End Sub
Sub SaveFileExcel()
Dim path As String
Dim filename1 As String
path = "U:\Public\WAKKA - WAKKAWAKKA"
filename1 = Range("W1").Text
Application.DisplayAlerts = True
'If Dir("f:ull\path\with\filename.xls") <> "" Then
' Kill "f:ull\path\with\filename.xls"
'End If ActiveWorkbook.SaveAs
Filename:=path & filename1 & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
End Sub
The format with which the file name is created is important for downstream usage, so a timestamp (with actual time) isn't an option.
How can I add a "-2" or "-3", etc. to the end of the file name?
You need to decide what the new name would be if the file already exists... adding a timestamp to the filename usually helps for keeping it unique.
Just reusing your code:
Sub SaveFileExcel()
Dim path As String
Dim filename1 As String
path = "U:\Public\WAKKA - WAKKAWAKKA"
filename1 = Range("W1").Text
Application.DisplayAlerts = True
If Not Dir(path & filename1 & ".xlsm") <> "" Then
filename1 = filename1 & "file_already_exists_with_same_name"
End If
ActiveWorkbook.SaveAs Filename:=path & filename1 & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
End Sub

Excel Send Emails Based on Worksheet Names

I made a macro that splits a main worksheet into different tabs and renames the tabs. I want to email the tabs to different people, by matching the tab name to a list containing email addresses.
What I have right now is this:
Sub Split_To_Workbook_and_Email_with_Body()
'Working in 2013/2016
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
Dim myOutlook As Object
Dim myMailItem As Object
Dim mySubject As String
Dim myto As String
Dim myPath As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Prompt for Email Subject
Set otlApp = CreateObject("Outlook.Application")
'mySubject = InputBox("Subject for Email")'this shows a dialog where you can enter the email subject (right now it is hard coded)
'myto = Application.VLOOKUP(SheetId, Sheet1!A3:B48, 2, FALSE)
'myto = Application.VLookup(SheetId, Sheet1!A3:B48, 2, range_lookup)
'Copy every sheet from the workbook with this macro
Set Sourcewb = ActiveWorkbook
'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = "Z:\user\report" & Sourcewb.Name & " " & DateString
MkDir FolderName
'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy
'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
End With
'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
'Save the new workbook, email it, and close it
Set otlNewMail = otlApp.CreateItem(olMailItem)
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
End With
myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
idkfile = "C:\Users\UniaHa\Desktop\Testing.txt"
With Destwb
.Close False
End With
With otlNewMail
'.Subject = mySubject
.to = test#test.ca
.Subject = "Diversion Report"
.Body = "Dear customer," & vbNewLine & vbNewLine & _
"This is your report please..... blah blah" & _
vbNewLine & vbNewLine & "Regards," & vbNewLine & vbNewLine & "Sender Name"
.Attachments.Add myPath
.Attachments.Add idkfile
.Display
End With
Set otlNewMail = Nothing
End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
For your vlookup, you can try something like:
On Error Resume Next
for each sht in activeworkbook.worksheets
err.clear
sEmailTo = Application.worksheetfunction.VLOOKUP(sh.name, Sheet1!A3:B48, 2, FALSE)
if err<>0 and semailto like "*#*" Then
'send your email
end if
next sht
On Error goto 0

Set Focus Back to Excel, Mac VBA 2016

I am currently using the following VBA code in Excel for MAC 2016:
Sub MailWorkSheet()
Dim SourceWb As Workbook, DestWb As Workbook, sh As Worksheet
Dim strbody As String, TempFileName As String
If Val(Application.Version) < 15 Then Exit Sub
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Check if the Script File is in the correct location
If CheckScript(ScriptFileName:="ExcelOutlook.scpt") = False Then
MsgBox "Sorry the ExcelOutlook.scpt file is not in the correct
location, " & _
"Email File Manually."
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set reference to the source workbook
Set SourceWb = ActiveWorkbook
'Create the body text in the strbody string
strbody = "<FONT size=""3"" face=""Calibri"">"
strbody = strbody & "Hello:" & "<br>" & "<br>" & _
"XXXXXXX." & "<br>" & _
" " & "<br>" & _
"XXXXXXX." & "<br>" & _
" " & "<br>" & _
"XXXXXXX!!"
strbody = strbody & "</FONT>"
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set DestWb = ActiveWorkbook
'Delete the button on the one sheet workbook
On Error Resume Next
DestWb.Sheets(1).DrawingObjects.Visible = True
DestWb.Sheets(1).DrawingObjects.Delete
On Error GoTo 0
'Enter the name of the file just created
TempFileName = "Long Lane Merit Sheet" & " " _
& Range("A2") & " " & Format(Now, "mmm-dd-yy")
'Call the MailWithMac function to save the new file and create the
mail
MailWithMac _
subject:="XXXXXXX", _
mailbody:=strbody, _
toaddress:=Range("A3"), _
ccaddress:="", _
bccaddress:="", _
displaymail:=True, _
accounttype:="", _
accountname:="", _
attachment:=TempFileName, _
FileFormat:=SourceWb.FileFormat
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Turn on Automatic Calculation
Application.Calculation = xlCalculationAutomatic
'Turn Alert Messages On
Application.DisplayAlerts = True
End Sub
It works great to email the current sheet through Outlook.
The problem I am having is that I want the focus to return to the Excel sheet. What is happening now is that the Outlook screen along with a new email pops up. After hitting send, the new email screen goes away, but the main Outlook window remains.
How do I set focus back to Excel?
I have found that the solution is to use Applescript to achieve the desired effect. Here is the whole script:
ption Explicit
Sub MailWorkSheet()
'Only working in Excel 2016 for the Mac with Outlook 2016
Dim SourceWb As Workbook, DestWb As Workbook, sh As Worksheet
Dim strbody As String, TempFileName As String
Dim RunMyScript As String
'Exit the sub if it is Mac Excel 2011 or lower
If Val(Application.Version) < 15 Then Exit Sub
'Turn off Automatic Calculation
Application.Calculation = xlCalculationManual
'Turn off Alerts
Application.DisplayAlerts = False
'Check if the Script File is in the correct location
If CheckScript(ScriptFileName:="ExcelOutlook.scpt") = False Then
MsgBox "Sorry the ExcelOutlook.scpt file is not in the correct location, " & _
"Email File Manually."
Exit Sub
End If
With Application
'.ScreenUpdating = False
.EnableEvents = False
End With
'Set reference to the source workbook
Set SourceWb = ActiveWorkbook
'Create the body text in the strbody string
strbody = "<FONT size=""3"" face=""Calibri"">"
strbody = strbody & "Hello:" & "<br>" & "<br>" & _
"XXXXXXX" & "<br>" & _
" " & "<br>" & _
"XXXXXXX" & "<br>" & _
" " & "<br>" & _
"XXXXXXX"
strbody = strbody & "</FONT>"
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set DestWb = ActiveWorkbook
'Delete the button on the one sheet workbook
On Error Resume Next
DestWb.Sheets(1).DrawingObjects.Visible = True
DestWb.Sheets(1).DrawingObjects.Delete
On Error GoTo 0
'Enter the name of the file just created
TempFileName = "XXXXXXX" & " " _
& Range("A2") & " " & Format(Now, "mmm-dd-yy")
'Call the MailWithMac function to save the new file and create the mail
MailWithMac _
subject:="XXXXXXX", _
mailbody:=strbody, _
toaddress:=Range("A3"), _
ccaddress:="", _
bccaddress:="", _
displaymail:=True, _
accounttype:="", _
accountname:="", _
attachment:=TempFileName, _
FileFormat:=SourceWb.FileFormat
With Application
'.ScreenUpdating = True
.EnableEvents = True
End With
'Minimize Outlook
RunMyScript = AppleScriptTask("ExcelOutlook.scpt", "Mini", _
"/Library/Application Scripts/com.microsoft.Excel/ExcelOutlook.scpt")
'Turn on Automatic Calculation
Application.Calculation = xlCalculationAutomatic
'Turn Alert Messages On
Application.DisplayAlerts = True
End Sub
Function MailWithMac(subject As String, mailbody As String, _
toaddress As String, ccaddress As String, _
bccaddress As String, displaymail As Boolean, _
accounttype As String, accountname As String, _
attachment As String, FileFormat As Long)
'Function to create a mail with the activesheet
Dim FileExtStr As String, FileFormatNum As Long
Dim TempFilePath As String, fileattachment As String
Dim ScriptStr As String, RunMyScript As String
Select Case FileFormat
Case 52: FileExtStr = ".xlsx": FileFormatNum = 52
Case 53:
If ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 53
Else
FileExtStr = ".xlsx": FileFormatNum = 52
End If
Case 57: FileExtStr = ".xls": FileFormatNum = 57
Case Else: FileExtStr = ".xlsb": FileFormatNum = 51
End Select
'Save the new temporary workbook and close it
TempFilePath = _
MacScript("return POSIX path of (path to home folder) as string")
With ActiveWorkbook
.SaveAs TempFilePath & attachment & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
'Build the AppleScriptTask parameter string
fileattachment = TempFilePath & attachment & FileExtStr
ScriptStr = subject & ";" & mailbody & ";" & toaddress & ";" & ccaddress & ";" & _
bccaddress & ";" & displaymail & ";" & accounttype & ";" & _
accountname & ";" & fileattachment
'Call the ExcelOutlook Script with the AppleScriptTask Function
RunMyScript = AppleScriptTask("ExcelOutlook.scpt", "CreateMailinOutlook", CStr(ScriptStr))
'Delete the file we just mailed
KillFile fileattachment
End Function
Function CheckScript(ScriptFileName As String) As Boolean
'Function to Check if the AppleScriptTask script file exists
Dim AppleScriptTaskFolder As String
Dim TestStr As String
AppleScriptTaskFolder = MacScript("return POSIX path of (path to desktop folder) as string")
AppleScriptTaskFolder = Replace(AppleScriptTaskFolder, "/Desktop", "") & _
"Library/Application Scripts/com.microsoft.Excel/"
On Error Resume Next
TestStr = Dir(AppleScriptTaskFolder & ScriptFileName, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
CheckScript = False
Else
CheckScript = True
End If
End Function
Function KillFile(Filestr As String)
'Function to Kill File
Dim ScriptToKillFile As String
Dim Fstr As String
'Delete files from a Mac using Applescript to avoid probelsm with long file names
If Val(Application.Version) < 15 Then
ScriptToKillFile = "tell applicatoin " & Chr(34) & _
"Finder" & Chr(34) & Chr(13)
ScriptToKillFile = ScriptToKillFile & _
"do shell script ""rm"" & quoted form of posix path of " & _
Chr(34) & Filestr & Chr(34) & Chr(13)
ScriptToKillFile = ScriptToKillFile & "end tell"
On Error Resume Next
MacScript (ScriptToKillFile)
On Error GoTo 0
Else
Fstr = MacScript("return POSIX path of (" & _
Chr(34) & Filestr & Chr(34) & ")")
On Error Resume Next
Kill Fstr
End If
End Function
Applescript:
on CreateMailInOutlook(paramString)
set {fieldValue1, fieldValue2, fieldValue3, fieldValue4, fieldValue5, fieldValue6, fieldValue7, fieldValue8, fieldValue9} to SplitString(paramString, ";")
tell application "Microsoft Outlook"
if fieldValue7 = "pop" then
set theAccount to the first pop account whose name is fieldValue8
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2, account:theAccount})
else if fieldValue7 = "imap" then
set theAccount to the first imap account whose name is fieldValue8
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2, account:theAccount})
else
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2})
end if
tell NewMail
repeat with toRecipient in my SplitString(fieldValue3, ",")
make new to recipient at end of to recipients with properties {email address:{address:contents of toRecipient}}
end repeat
repeat with toRecipient in my SplitString(fieldValue4, ",")
make new to recipient at end of cc recipients with properties {email address:{address:contents of toRecipient}}
end repeat
repeat with toRecipient in my SplitString(fieldValue5, ",")
make new to recipient at end of bcc recipients with properties {email address:{address:contents of toRecipient}}
end repeat
make new attachment with properties {file:POSIX file fieldValue9 as alias}
if fieldValue6 as boolean = true then
open NewMail
activate NewMail
else
send NewMail
end if
end tell
end tell
end CreateMailInOutlook
on SplitString(TheBigString, fieldSeparator)
tell AppleScript
set oldTID to text item delimiters
set text item delimiters to fieldSeparator
set theItems to text items of TheBigString
set text item delimiters to oldTID
end tell
return theItems
end SplitString
on Mini()
tell application "Microsoft Outlook"
tell (windows whose id is not (get id of front window) and visible is true)
set miniaturized to true
end tell
end tell
end Mini

Need to send attachment in XLSX format using CDO mail

Hi Iam using follwing code as a sample to send a mail with attachment via SMTP, but the attachment what it send is in XLSM format i need that to be in XLSX (non macro) format. Kindly help me to fo this.
Option Explicit
'This procedure will mail the whole workbook
'You can 't send a Workbook that is open with CDO.
'That's why it use SaveCopyAs to save it with another name and send that file.
Sub CDO_Mail_Workbook()
'Working in 2000-2007
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "This is a test"
.TextBody = "This is the body text"
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I think what you'll need to do, is have this code reside in an add-in. That way you aren't trying to send the existing file with code via email.
You are sending workbook which you are running code from so it must be .xlsm and so you send it.
You must either create a copy of your workbook without macros and then send this copy or move your macro to PERSONAL (assuming macro you posted is the only code contained in your workbook)

Resources