Consulting

Results 1 to 4 of 4

Thread: VBA code to email a single excel worksheet - file name issue

  1. #1
    VBAX Regular
    Joined
    Apr 2021
    Posts
    40
    Location

    VBA code to email a single excel worksheet - file name issue

    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 (link here: https://www.extendoffice.com/documen...-email.html#a2). 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?

    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!
    Last edited by Paul_Hossler; 04-01-2021 at 12:47 PM. Reason: Added CODE tags

  2. #2
    Hi Ray707, try this code to send the last saved version of the active workbook:
    Sub SendWorkSheet()
       
        Dim OutlookApp As Object
        Dim OutlookMail As Object
        On Error Resume Next
        Application.ScreenUpdating = False
    
    
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
            
        With OutlookMail
            .To = "xxxxx"
            .CC = ""
            .BCC = ""
            .Subject = "Excel sheet test"
            .Body = "Hello, please see file attached. Regards"
            .Attachments.Add ActiveWorkbook.FullName
            .display
           ' .Send
        End With
        
        Set OutlookMail = Nothing
        Set OutlookApp = Nothing
        Application.ScreenUpdating = True
        
    End Sub

  3. #3
    Hi Ray707,
    I misread your request, see below the code to send only the active sheet, adapted from this link https://www.rondebruin.nl/win/s1/outlook/amail2.htm:

    Sub Mail_ActiveSheet()
    
    
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim Sourcewb As Workbook
        Dim Destwb As Workbook
        Dim TempFilePath As String
        Dim TempFileName As String
        Dim OutApp As Object
        Dim OutMail As Object
    
    
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
    
    
        Set Sourcewb = ActiveWorkbook
    
    
        'Copy the ActiveSheet to a new workbook
        ActiveSheet.Copy
        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
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End With
    
    
        
        TempFilePath = Environ$("temp") & "\"
        TempFileName = ActiveSheet.Name
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
    
        With Destwb
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
            On Error Resume Next
            With OutMail
                .to = "xxxxx"
                .CC = ""
                .BCC = ""
                .Subject = "Excel sheet test"
                .Body = "Hello, please see file attached. Regards"
                .Attachments.Add Destwb.FullName
                '.Send   'or use
                .Display
            End With
            On Error GoTo 0
            .Close savechanges:=False
        End With
    
    
        'Delete the file you have send
        Kill TempFilePath & TempFileName & FileExtStr
    
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    
    
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End Sub

  4. #4
    VBAX Regular
    Joined
    Apr 2021
    Posts
    40
    Location
    Quote Originally Posted by Sequoyah View Post
    Hi Ray707,
    I misread your request, see below the code to send only the active sheet, adapted from this link https://www.rondebruin.nl/win/s1/outlook/amail2.htm:

    Sub Mail_ActiveSheet()
    
    
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim Sourcewb As Workbook
        Dim Destwb As Workbook
        Dim TempFilePath As String
        Dim TempFileName As String
        Dim OutApp As Object
        Dim OutMail As Object
    
    
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
    
    
        Set Sourcewb = ActiveWorkbook
    
    
        'Copy the ActiveSheet to a new workbook
        ActiveSheet.Copy
        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
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End With
    
    
        
        TempFilePath = Environ$("temp") & "\"
        TempFileName = ActiveSheet.Name
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
    
        With Destwb
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
            On Error Resume Next
            With OutMail
                .to = "xxxxx"
                .CC = ""
                .BCC = ""
                .Subject = "Excel sheet test"
                .Body = "Hello, please see file attached. Regards"
                .Attachments.Add Destwb.FullName
                '.Send   'or use
                .Display
            End With
            On Error GoTo 0
            .Close savechanges:=False
        End With
    
    
        'Delete the file you have send
        Kill TempFilePath & TempFileName & FileExtStr
    
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    
    
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End Sub
    Perfect, thank you!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •