• 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...

  • 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

Logit

Active Member
Code:
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
 

Attachments

Shay A

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

TY
 

Logit

Active Member
https://www.rondebruin.nl/win/s1/outlook/amail3.htm

Code:
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
 

Attachments

Logit

Active Member
Code:
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
 

Attachments

Logit

Active Member
Edited macro :

Code:
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
 
Top