1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Sending active sheet with VBA from Outlook

Discussion in 'VBA Macros' started by Shay A, Aug 18, 2018.

  1. Shay A

    Shay A Member

    Messages:
    209
    Hi,
    I have been trying this code I found on the net. The code should send the active sheet as an attachment and then delete the temporary file from the hard disk. However, when I run the code, nothing happens in Outlook. Maybe it's because I use 365 version of Office?

    TY,
    Shay


    https://www.rondebruin.nl/win/s1/outlook/amail2.htm
  2. Logit

    Logit Active Member

    Messages:
    272
    Code (vb):
    Option Explicit

    Sub Email_Sheet()

      Dim oApp As Object
      Dim oMail As Object
      Dim LWorkbook As Workbook
      Dim LFileName As String

      'Turn off screen updating
     Application.ScreenUpdating = False

      'Copy the active worksheet and save to a temporary workbook
     ActiveSheet.Copy
      Set LWorkbook = ActiveWorkbook

      'Create a temporary file in your current directory that uses the name
     ' of the sheet as the filename
     LFileName = LWorkbook.Worksheets(1).Name
      On Error Resume Next
      'Delete the file if it already exists
     Kill LFileName
      On Error GoTo 0
      'Save temporary file
     LWorkbook.SaveAs Filename:=LFileName

      'Create an Outlook object and new mail message
     Set oApp = CreateObject("Outlook.Application")
      Set oMail = oApp.CreateItem(0)

      'Set mail attributes (uncomment lines to enter attributes)
     ' In this example, only the attachment is being added to the mail message
     With oMail
          .To = "user@yahoo.com"
          .Subject = "Subject"
          .body = "This is the body of the message." & vbCrLf & vbCrLf & _
          "Attached is the file"
          .Attachments.Add LWorkbook.FullName
          .Display  '<-- Replace with .Send if you want to auto send email without viewing it first
     End With

      'Delete the temporary file and close temporary Workbook
     LWorkbook.ChangeFileAccess Mode:=xlReadOnly
      Kill LWorkbook.FullName
      LWorkbook.Close SaveChanges:=False

      'Turn back on screen updating
     Application.ScreenUpdating = True
      Set oMail = Nothing
      Set oApp = Nothing

    End Sub

     

    Attached Files:

    Thomas Kuriakose likes this.
  3. Shay A

    Shay A Member

    Messages:
    209
    So this should work on 365 version as well?

    Thanks!
  4. Logit

    Logit Active Member

    Messages:
    272
    Have you tried it ?
  5. Deepak

    Deepak Excel Ninja

    Messages:
    2,862
    Rons' Code are generic in nature and use as indicated there...
  6. Shay A

    Shay A Member

    Messages:
    209
    Yes I have and it works, thank you!
  7. Logit

    Logit Active Member

    Messages:
    272
    Great !
  8. Shay A

    Shay A Member

    Messages:
    209
    Hi,
    Further to this post, will it work on a group of selected worksheets and not just the active one?

    TY
  9. Logit

    Logit Active Member

    Messages:
    272
    https://www.rondebruin.nl/win/s1/outlook/amail3.htm

    Code (vb):
    Option Explicit

    Sub Mail_Sheets_Array()
    'Working in Excel 2000-2016
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
       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
        Dim sh As Worksheet
        Dim TheActiveWindow As Window
        Dim TempWindow As Window

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        Set Sourcewb = ActiveWorkbook

        'Copy the sheets to a new workbook
       'We add a temporary Window to avoid the Copy problem
       'if there is a List or Table in one of the sheets and
       'if the sheets are grouped
       With Sourcewb
            Set TheActiveWindow = ActiveWindow
            Set TempWindow = .NewWindow
            .Sheets(Array("Sheet1", "Sheet3")).Copy
        End With

        'Close temporary Window
       TempWindow.Close

        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

        '    'Change all cells in the worksheets to values if you want
       '    For Each sh In Destwb.Worksheets
       '        sh.Select
       '        With sh.UsedRange
       '            .Cells.Copy
       '            .Cells.PasteSpecial xlPasteValues
       '            .Cells(1).Select
       '        End With
       '        Application.CutCopyMode = False
       '        Destwb.Worksheets(1).Select
       '    Next sh

        '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 OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        With Destwb
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
            On Error Resume Next
            With OutMail
                .to = "me@yahoo.com"
                .CC = ""
                .BCC = ""
                .Subject = "This is the Subject line"
                .Body = "Hi there"
                .Attachments.Add Destwb.FullName
                'You can add other files also like this
               '.Attachments.Add ("C:\test.txt")
               '.Send  'or use .Display
               .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

    Attached Files:

  10. Shay A

    Shay A Member

    Messages:
    209
    And another tweak please, what if I want the sheed to sent in PDF format?
  11. Logit

    Logit Active Member

    Messages:
    272
    Code (vb):
    Option Explicit

    Sub pdf()
    Dim wsA As Worksheet, wbA As Workbook, strTime As String
    Dim strName As String, strPath As String
    Dim strFile As String
    Dim strPathFile As String


    'On Error GoTo errHandler

        Set wbA = ActiveWorkbook
        Set wsA = ActiveSheet
       

    'replace spaces and periods in sheet name
       strName = Replace(wsA.Name, " ", "")
        strName = Replace(strName, ".", "_")
       
    'create default name for savng file
     
        strPath = "C:\PDFs\"
        strFile = Sheets("Email").Range("B2").Value
        strPathFile = strPath & strFile


    Dim myFolder$
    myFolder = "C:\PDFs"
       
        If Dir(myFolder, vbDirectory) = "" Then
            MkDir myFolder
        End If

    'export to PDF if a folder was selected
       wsA.ExportAsFixedFormat 0, strPathFile
       
        If Len(Dir$(myFolder)) > 0 Then
            SetAttr myFolder, vbNormal
        End If

    'confirmation message with file info
       MsgBox "PDF file has been created: " _
          & vbCrLf _
          & strPathFile


    exitHandler:
        Exit Sub
    errHandler:
        MsgBox "Could not create PDF file"
        Resume exitHandler
    End Sub


    Sub Mail_workbook_Outlook()

        Dim c As Range
        Dim OutApp As Object
        Dim OutMail As Object
        Dim strPath As String
        Dim FileName As String

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
       
        strPath = "C:\PDFs\"
        FileName = Dir(strPath & "*.*")

        'On Error Resume Next
       For Each c In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = c.Value
                .CC = ""
                .BCC = ""
                .Subject = c.Offset(0, 1).Value
                .Body = "The parts have been placed on today's load sheet and will be processed by EOB today.  The parts have also been transferred to the repository file."
                FileName = Dir(strPath & "*.*")
                .Attachments.Add strPath & FileName
               
                '.Send                              '<-- .Send will auto send email without review
               .Display                            '<-- .Display will show the email first for review
           End With
            'On Error GoTo 0
       Next c


        Set OutMail = Nothing
        Set OutApp = Nothing
       
      byby
         
    End Sub

    Sub byby()  'deletes PDF file after attaching to email
    Dim folder As Object
    Dim path As String
    path = "C:\PDFs"
    Set folder = CreateObject("scripting.filesystemobject")

        folder.DeleteFolder path, True

    End Sub

     

    Attached Files:

  12. Shay A

    Shay A Member

    Messages:
    209
    So basically in order to compete this task I would to tun 3 sub routines?

    TY!
  13. Logit

    Logit Active Member

    Messages:
    272
    Edited macro :

    Code (vb):
    Option Explicit

    Sub ExportAsPDF()

    Dim FolderPath As String

    FolderPath = "C:\PDFs"

    If Not FolderPath = "" Then
        MkDir FolderPath
    End If
         
        Sheets(Array("Sheet2", "Sheet3")).Select    '<-- Edit for additional sheet names
       ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FolderPath & "\Sheets", _
            openafterpublish:=False, ignoreprintareas:=False
       
    MsgBox "All PDF's have been successfully exported."

    Mail_workbook_Outlook

    End Sub

    Sub Mail_workbook_Outlook()

        Dim c As Range
        Dim OutApp As Object
        Dim OutMail As Object
        Dim strPath As String
        Dim FileName As String

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
       
        strPath = "C:\PDFs\"
        FileName = Dir(strPath & "*.*")
       
        For Each c In Sheet1.Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
        If c.Value <> "Email Addresses" Then
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = c.Value
                    .CC = ""
                    .BCC = ""
                    .Subject = c.Offset(0, 1).Value
                    .Body = "The parts have been placed on today's load sheet and will be processed by EOB today.  The parts have also been transferred to the repository file."
                   
                    .Attachments.Add strPath & FileName
                   
                    '.Send                              '<-- .Send will auto send email without review
                   .Display                            '<-- .Display will show the email first for review
               End With
                On Error GoTo 0
          End If
        Next c


        Set OutMail = Nothing
        Set OutApp = Nothing
       
      byby
         
    End Sub

    Sub byby()  'deletes PDF file after attaching to email
    Dim folder As Object
    Dim path As String
    path = "C:\PDFs"
    Set folder = CreateObject("scripting.filesystemobject")

        folder.DeleteFolder path, True
       
    Sheets("Email").Select
    End Sub

Share This Page