why is the file name duplicating in subject field?

Hi there,

I need some help with a VBA code and was wondering if anyone could help.

I needed a VBA code to email a single excel sheet from a workbook and found the code below. The problem is that when the file gets emailed to the recipient, the file name says 'TestFileScottNew.xlsm.xlsm'. In other words, the 'xlsm' part gets duplicated in the attachment and I want to prevent this from happening. I was wondering if anyone could help and let me know how to remove one of the xlsm's in the file name? (if you have a better code to help me achieve my aim then feel free to suggest it!)

Here is the code:

Sub SendWorkSheet()
'Update 20131209
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & ""
FileName = Wb.Name
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With OutlookMail
.To = "xxxxx"
.CC = ""
.BCC = ""
.Subject = "Excel sheet test"
.Body = "Hello, please see file attached. Regards"
.Attachments.Add Wb2.FullName
.Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub

Any help appreciated!

Originally Posted by dangelor

Try...

Wb2.SaveAs FilePath & FileName, FileFormat:=xFormat

... and add code tags to your post.

Originally Posted by AC PORTA VIA

change this line

Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat

to this

Wb2.SaveAs FilePath & FileName , FileFormat:=xFormat

That worked! Thank you!

The only thing is the file name now has 'temp' at the beginning, so it says 'TempTestFileScottNew.xlsm'- this is less of a problem but any ideas why and how to fix it?!

also how can I put this into a command button so that the user can press a button and it pings out the email? I tried putting the above into the VBA for a command button but it didn't work:

Private Sub CommandButton1_Click()
Sub SendWorkSheet()
'Update 20131209
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & ""
FileName = Wb.Name
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName, FileFormat:=xFormat
With OutlookMail
.To = "xxxxx"
.CC = ""
.BCC = ""
.Subject = "Excel sheet test"
.Body = "Hello, please see file attached. Regards"
.Attachments.Add Wb2.FullName
.Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True

End Sub

The error says:

Compile error: expected end sub

Originally Posted by AC PORTA VIA

remove below line

'Sub SendWorkSheet()

This worked for the command button, thank you. It does generate a pop up notification upon activation though which says 'A file named C:\Users\xxxx\AppData\Local\TempBook1.xlsm already exists in this location. Do you want to replace it?' but I think that is okay, right? My understanding is that the way these codes work is that they create a temp file in a location and then deletes it, so this is simply doing that..? Therefore I don't think we can avoid this can we..?

Try this version...

Private Sub CommandButton1_Click()
    'Update 20131209
    
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sFilePath As String, sFileName As String
    Dim iFormat As Integer

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set wb1 = Application.ActiveWorkbook
    ActiveSheet.Copy
    Set wb2 = Application.ActiveWorkbook
    
    sFilePath = Environ$("temp")
    sFileName = sFilePath & "\ " & wb1.Name
    iFormat = wb1.FileFormat
    wb2.SaveAs sFileName, iFormat
    wb2.Close
    
    With CreateObject("Outlook.Application").createItem(0)
        .To = "xxxxx"
        .CC = ""
        .BCC = ""
        .Subject = "Excel sheet test"
        .Body = "Hello, please see file attached. Regards"
        .Attachments.Add sFileName
        .Send
    End With
    
    Kill sFileName
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub

Hello, I have a quick question about the code posted by dangelor 2 posts above. I want to amend this code to send out the email to an address in a specific cell in that worksheet; so for example, if I write an email address in cell D2 of the worksheet, I want the code to send the sheet to that email address. I thought I could do this by simple amending the .To part of the code:

With CreateObject("Outlook.Application").createItem(0)
        .To = Sheet1.Range("D2")
        .CC = ""
        .BCC = ""
        .Subject = "Excel sheet"
        .Body = "Hello" & vbLf & vbLf & "Please find spreadsheet attached." & vbLf & vbLf & "Regards" & vbLf & "Ray"
        .Attachments.Add sFileName
        .Send
    End With

However this did not work and no email was sent out. Please can someone advise?

Are you sure the codename of your sheet is Sheet1?

And that is the workbook with the code in it?

I got it working! I transferred the code from module to worksheet and that worked. Perhaps I need to improve my understanding of module vs worksheet as I thought it was always best to put the code in the module

Thanks!

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

Also, you may not be aware that you can thank those who have helped you by clicking the small star icon located in the lower left corner of the post in which the help was given. By doing so you can add to the reputation(s) of those who helped.

hmmm the code to send out an email is not working now, I am not sure why. Does anyone have any idea why? When I click on the command button to send the email it creates a new file with that worksheet in it and nothing gets emailed. This didn't happen usually, it would just send that worksheet out automatically (no new file was created or anything, it would get emailed straight out to the recipient)

Private Sub CommandButton1_Click()
    'Update 20131209
    
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sFilePath As String, sFileName As String
    Dim iFormat As Integer

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set wb1 = Application.ActiveWorkbook
    ActiveSheet.Copy
    Set wb2 = Application.ActiveWorkbook
    
    sFilePath = Environ$("temp")
    sFileName = sFilePath & "\ " & wb1.Name
    iFormat = wb1.FileFormat
    wb2.SaveAs sFileName, iFormat
    wb2.Close
    
    With CreateObject("Outlook.Application").createItem(0)
        .To = "xxxxxxx"
        .CC = ""
        .BCC = ""
        .Subject = "Excel sheet test"
        .Body = "Hello, please see file attached. Regards"
        .Attachments.Add sFileName
        .Send
    End With
    
    Kill sFileName
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub

EDIT: The code works now so this post is redundant. If anyone can help with the post above that would be great