VBA code How to change from xlsx to xlsm

edouard

New Member
Joined
Feb 18, 2016
Messages
1
Hi everybody,

I found an awesome code on chandoor.org. Nevertheless I have an issue on the below in RED / as I would like to change from xlsx to xlsm !

Could you please Help Me ?

THANKS A LOT :D

Option Explicit


Sub ExportEmail()


Dim objfile As FileSystemObject
Dim xNewFolder
Dim xDir As String, xMonth As String, xFile As String, xPath As String
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim NameX As Name, xStp As Long
Dim xDate As Date, AWBookPath As String
Dim currentWB As Workbook, newWB As Workbook
Dim strEmailTo As String, strEmailCC As String, strEmailBCC As String, strDistroList As String

AWBookPath = ActiveWorkbook.Path & "\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "Creating Email and Attachment for " & Format(Date, "dddd dd mmmm yyyy")

Set currentWB = ActiveWorkbook

xDate = Date

'******************************Grabbing New WorkBook and Formatting*************

Sheets(Array("FORM", "Email", "Currency & Lists")).Copy

Set newWB = ActiveWorkbook

Range("A1").Select
Sheets("Email").Visible = False
Sheets("FORM").Select


'******************************Creating Pathways*********************************

xDir = AWBookPath
xMonth = Format(xDate, "mm mmmm yy") & "\"

xFile = "Customer Service Dashboard Report " & Format(xDate, "dd-mm-yyyy") & ".xlsx"

xPath = xDir & xMonth & xFile

'******************************Saving File in Pathway*********************************

Set objfile = New FileSystemObject

If objfile.FolderExists(xDir & xMonth) Then
If objfile.FileExists(xPath) Then
objfile.DeleteFile (xPath)
newWB.SaveAs Filename:=xPath, FileFormat:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False

Application.ActiveWorkbook.Close
Else
newWB.SaveAs Filename:=xPath, FileFormat:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
End If
Else
xNewFolder = xDir & xMonth
MkDir xNewFolder
newWB.SaveAs Filename:=xPath, FileFormat:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
End If

'******************************Preparing Distribution List *********************************


currentWB.Activate
Sheets("Email").Visible = True
Sheets("Email").Select

strEmailTo = ""
strEmailCC = ""
strEmailBCC = ""

xStp = 1

Do Until xStp = 4

Cells(2, xStp).Select

Do Until ActiveCell = ""

strDistroList = ActiveCell.Value

If xStp = 1 Then strEmailTo = strEmailTo & strDistroList & "; "
If xStp = 2 Then strEmailCC = strEmailCC & strDistroList & "; "
If xStp = 3 Then strEmailBCC = strEmailBCC & strDistroList & "; "

ActiveCell.Offset(1, 0).Select

Loop

xStp = xStp + 1

Loop

Range("A1").Select

'******************************Preparing Email*********************************

Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
olNs.Logon
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = strEmailTo
olMail.CC = strEmailCC
olMail.BCC = strEmailBCC


olMail.Subject = Mid(xFile, 1, Len(xFile) - 4)
olMail.Body = vbCrLf & "Hello Everyone," _
& vbCrLf & vbCrLf & "Please find attached the " & Mid(xFile, 1, Len(xFile) - 4) & "." _
& vbCrLf & vbCrLf & "Regards,"



olMail.Attachments.Add xPath
olMail.Display

Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

baitmaster

Well-known Member
Joined
Mar 12, 2009
Messages
2,039
welcome to the board

there are a couple of downloads at Case studies & example files - Spreadsheet Wizard Ltd that would help with both your requirements here - creating / saving files, and emailing

your issue is probably the file format, I believe you need to change it 52 for a .xlsm file. You would also need to change the file extension to .xlsm in the file name
 

Watch MrExcel Video

Forum statistics

Threads
1,129,685
Messages
5,637,809
Members
416,983
Latest member
LessThanAverageUser

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top