Note: The other languages of the website are Google-translated. Back to English
Войти  \/ 
x
or
x
Регистрация  \/ 
x

or

Как сохранить рабочий лист в виде файла PDF и отправить его по электронной почте в виде вложения через Outlook?

В некоторых случаях вам может потребоваться отправить рабочий лист в виде файла PDF через Outlook. Обычно вам нужно вручную сохранить рабочий лист как файл PDF, затем создать новое электронное письмо с этим файлом PDF в качестве вложения в Outlook и, наконец, отправить его. Это требует времени, чтобы сделать это вручную, шаг за шагом. В этой статье мы покажем вам, как быстро сохранить рабочий лист в виде файла PDF и автоматически отправить его в виде вложения через Outlook в Excel.

Сохраните рабочий лист как PDF-файл и отправьте его по электронной почте как вложение с кодом VBA.


Сохраните рабочий лист как PDF-файл и отправьте его по электронной почте как вложение с кодом VBA.


Вы можете запустить приведенный ниже код VBA, чтобы автоматически сохранить активный лист в виде файла PDF, а затем отправить его по электронной почте как вложение через Outlook. Пожалуйста, сделайте следующее.

1. Откройте рабочий лист, который вы сохраните в формате PDF и отправите, затем нажмите другой + F11 клавиши одновременно, чтобы открыть Microsoft Visual Basic для приложений окно.

2. в Microsoft Visual Basic для приложений окна, нажмите Вставить > модуль. Затем скопируйте и вставьте приведенный ниже код VBA в Код: окно. Смотрите скриншот:

Код VBA: сохраните рабочий лист как файл PDF и отправьте его по электронной почте как вложение

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file 
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
    
    'Create Outlook email 
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub

3. нажмите F5 ключ для запуска кода. в Browse диалоговом окне выберите папку для сохранения этого PDF-файла, а затем щелкните OK кнопку.

Базовые ноты:

1. Теперь активный рабочий лист сохранен как файл PDF. И файл PDF называется именем рабочего листа.
2. Если активный рабочий лист пуст, вы получите диалоговое окно, как показано на скриншоте ниже, после нажатия кнопки OK кнопку.

4. Теперь создается новое электронное письмо Outlook, и вы можете видеть, что файл PDF указан как вложение в поле «Прикрепленные». Смотрите скриншот:

5. Составьте это письмо и отправьте его.
6. Этот код доступен только при использовании Outlook в качестве почтовой программы.

С легкостью сохраняйте рабочий лист или несколько рабочих листов в виде отдельных файлов PDF одновременно:

Теперь Разделить книгу полезности Kutools for Excel может помочь вам легко сохранить рабочий лист или несколько рабочих листов в виде отдельных файлов PDF одновременно, как показано ниже. Скачайте и попробуйте прямо сейчас! (30-дневная бесплатная трасса)


Статьи по теме:


Лучшие инструменты для работы в офисе

Kutools for Excel решает большинство ваших проблем и увеличивает вашу производительность на 80%

  • Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма ...
  • Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон...
  • Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы... Предотвращение дублирования ячеек; Сравнить диапазоны...
  • Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор ...
  • Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое ...
  • Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии...
  • Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом ...
  • Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF...
  • Более 300 мощных функций. Поддерживает Office / Excel 2007-2019 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.
вкладка kte 201905

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

  • Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
  • Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
  • Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!
офисный дно
Say something here...
symbols left.
You are guest
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Makeeuropeanu · 1 months ago
    Hi,
    I needed something similar so here is what I got.
    It takes the current date and creates a new folder with the date name in a specific location.
    It places the pdf inside that new location, then attaches the pdf into a new email. 
    Works as a treat. 
    I am just a beginner so please excuse me if it looks like a mess. :D

    Sub PDFTOEMAIL()
    Dim xSht As Worksheet
    Dim xFileDlg As FileDialog
    Dim xFolder As String
    Dim xYesorNo As Integer
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim xUsedRng As Range
    Dim xPath As String
    Dim xOutMsg As String
    Dim sFolderName As String, sFolder As String
    Dim sFolderPath As String

    Set xSht = ActiveSheet
    xFileDate = Format(Now, "dd-mm-yyyy")
    sFolder = "C:" 'here is where you have a main folder
    sFolderName = "Week ending " + Format(Now, "dd-mm-yyyy") 'folder to be created in main folder with name Week ending and current date
    sFolderPath = "C:" & sFolderName 'main folder again to create the new path including the new folder
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If oFSO.FolderExists(sFolderPath) Then
    MsgBox "Folder already exists !" & vbCrLf & vbCrLf & sFolderPath, vbInformation, "INFO"
    Else
    MkDir sFolderPath
    MsgBox "New folder has been created !" & vbCrLf & vbCrLf & sFolderPath, vbInformation, "INFO"
    End If
    xPath = sFolderPath
    xFolder = xPath + "\" + xSht.Name + "_" + xFileDate + ".pdf"
    If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
    vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
    Kill xFolder
    Else
    MsgBox "if you don't overwrite the existing PDF, I can't continue." _
    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
    Exit Sub
    End If
    If Err.Number <> 0 Then
    MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
    Exit Sub
    End If
    End If

    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    xOutMsg = "<b>Please find attached</b><br/><br/><br/><br/><br/><br/><br/><br/><br/><br/><br/><br/><span style=""color:#00FF00;background:#000000"">This email and attachment has been generated automatically</span>"
    'adds a note that the email was generated automatically

    With xEmailObj
    .Display
    .To = "" 'add your own emails
    .CC = ""
    .Subject = xSht.Name + " PDF for week ending " + xFileDate + " - Location " ' subject includes sheet name, pdf, date and location, this can be edited as needed
    .Attachments.Add xFolder
    .HTMLBody = xOutMsg & .HTMLBody
    If DisplayEmail = False Then
    '.Send <--- Here if you delete the apostrophe the email will be sent automatically, so please be careful
    End If
    End With
    Else
    MsgBox "The active worksheet cannot be blank"
    Exit Sub
    End If
    End Sub
  • To post as a guest, your comment is unpublished.
    Tori · 1 months ago
    Hi @crystal 

    This is fab - the o key thing I am struggling with is the file name - I’d like the file name to pull from a cell in the worksheet rather than use the tab name. I’ve already edited the code to save automatically to a specified folder but am struggling with the file name.

    Any help you can offer please?
    • To post as a guest, your comment is unpublished.
      crystal · 28 days ago
      Hi Tori,
      If you want to name the PDF file with a specific cell value, please try the following code.
      After running the code and selecting a folder to save the file, another dialog box pops up, please select the cell that you will use the value as the name of the PDF file, and then click OK to finish.

      Sub Saveaspdfandsend2() 'Updated by Extendoffice 20210521 Dim xSht As Worksheet Dim xFileDlg As FileDialog Dim xFolder As String Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng, xRgInser As Range Dim xB As Boolean Set xSht = ActiveSheet Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) If xFileDlg.Show = True Then xFolder = xFileDlg.SelectedItems(1) Else MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" Exit Sub End If xB = True On Error Resume Next While xB Set xRgInser = Nothing Set xRgInser = Application.InputBox("Select a cell that you will use the value to name the PDF file:", "Kutools for Excel", , , , , , 8) If xRgInser Is Nothing Then MsgBox " No cell seleced, exit the operation! ", vbInformation, "Kutools for Excel" Exit Sub End If If xRgInser.Text = "" Then MsgBox " The selected cell is blank, please reselect! ", vbInformation, "Kutools for Excel" Else xB = False End If Wend xFolder = xFolder + "\" + xRgInser.Text + ".pdf" 'Check if file already exist If Len(Dir(xFolder)) > 0 Then xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ vbYesNo + vbQuestion, "File Exists") On Error Resume Next If xYesorNo = vbYes Then Kill xFolder Else MsgBox "if you don't overwrite the existing PDF, I can't continue." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" Exit Sub End If If Err.Number <> 0 Then MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" Exit Sub End If End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then 'Save as PDF file xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "" .CC = "" .Subject = xSht.Name + ".pdf" .Attachments.Add xFolder If DisplayEmail = False Then '.Send End If End With Else MsgBox "The active worksheet cannot be blank" Exit Sub End If End Sub
  • To post as a guest, your comment is unpublished.
    BenSpo · 1 months ago
    Hi @crystal , excelent code thanks for sharing.
    Is there a way to select multiples sheets (from the same workbook) to save each one as an independent PDF and then send them all attached in one email?
    • To post as a guest, your comment is unpublished.
      crystal · 28 days ago
      Hi,
      The below VBA code can do you a favor, please have a try.
      In the the twelfth line of the code, please replace the sheet names with the actual sheet names in your case.

      Sub Saveaspdfandsend1() Dim xSht As Worksheet Dim xFileDlg As FileDialog Dim xFolder As String Dim xYesorNo, I, xNum As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Dim xArrShetts As Variant Dim xPDFNameAddress As String Dim xStr As String xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name. For I = 0 To UBound(xArrShetts) On Error Resume Next Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I)) If xSht.Name <> xArrShetts(I) Then MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel" Exit Sub End If Next Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) If xFileDlg.Show = True Then xFolder = xFileDlg.SelectedItems(1) Else MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" Exit Sub End If 'Check if file already exist xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _ vbYesNo + vbQuestion, "File Exists") If xYesorNo <> vbYes Then Exit Sub For I = 0 To UBound(xArrShetts) Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I)) xStr = xFolder & "\" & xSht.Name & ".pdf" xNum = 1 While Not (Dir(xStr, vbDirectory) = vbNullString) xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf" xNum = xNum + 1 Wend Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard Else End If xArrShetts(I) = xStr Next 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "" .CC = "" .Subject = "????" For I = 0 To UBound(xArrShetts) .Attachments.Add xArrShetts(I) Next If DisplayEmail = False Then '.Send End If End With End Sub

  • To post as a guest, your comment is unpublished.
    hein · 2 months ago
    Hello, i would like to save this in a certain file location, with the name based on the vallue in cell C30.
    I have tried a few options, but keep getting faults.
    • To post as a guest, your comment is unpublished.
      crystal · 2 months ago
      Hi hein,
      The below code maybe can help. After running the code, select a certain folder to save the PDF file, then a dialog box will pop up for you to enter the filename.
      Sub Saveaspdfandsend() 'Updated by Extendoffice 20210209 Dim xSht As Worksheet Dim xFileDlg As FileDialog Dim xFolder As String Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Dim xStrName As String Dim xV As Variant Set xSht = ActiveSheet Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) If xFileDlg.Show = True Then xFolder = xFileDlg.SelectedItems(1) Else MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" Exit Sub End If xStrName = "" xV = Application.InputBox("Please enter the filename:", "Kutools for Excel", , , , , , 2) If xV = False Then Exit Sub End If xStrName = xV If xStrName = "" Then MsgBox ("No filename entered, exiting process!") Exit Sub End If xFolder = xFolder + "\" + xStrName + ".pdf" 'Check if file already exist If Len(Dir(xFolder)) > 0 Then xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ vbYesNo + vbQuestion, "File Exists") On Error Resume Next If xYesorNo = vbYes Then Kill xFolder Else MsgBox "if you don't overwrite the existing PDF, I can't continue." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" Exit Sub End If If Err.Number <> 0 Then MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" Exit Sub End If End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then 'Save as PDF file xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "" .CC = "" .Subject = xSht.Name + ".pdf" .Attachments.Add xFolder If DisplayEmail = False Then '.Send End If End With Else MsgBox "The active worksheet cannot be blank" Exit Sub End If End Sub
      • To post as a guest, your comment is unpublished.
        HeinPeeters · 2 months ago
        Thanks for that, thats great, but i want the sheet to be named as per cell A1 on sheet 1. the place to save as per A1 on sheet 2 for example C:\Users\peete\Dropbox\Screenshots, but can change when using the file, and email send to email address on A3 sheet 2 what I have worked out already.
      • To post as a guest, your comment is unpublished.
        Hein · 2 months ago
        Thanks for that, thats great, but i want the sheet to be named as per cell A1 on sheet 1. the place to save as per A1 on sheet 2 for example C:\Users\peete\Dropbox\Screenshots, and email send to email address on A3 sheet 2 what I have worked out already.
  • To post as a guest, your comment is unpublished.
    mleczus94 · 3 months ago
    Hi,
    If I have two sheets in file, and I would like to run this macro on one sheet(by pressing button) but send another, how can I get it?
  • To post as a guest, your comment is unpublished.
    deepakmaheshwari · 4 months ago

    Hi , it's working great thank you for sharing, Just need one help.
    If I want to save a PDF file with customized name (option to type file name in SaveAs dialog box), as user's use this option in form template where forms saved as PDF with unique name .
    • To post as a guest, your comment is unpublished.
      crystal · 4 months ago
      Hi,
      Please try the below VBA code. After running the code, select a folder to save the PDF file, then a dialog box will pop up for you to enter the filename.
      Sub Saveaspdfandsend() 'Updated by Extendoffice 20210209 Dim xSht As Worksheet Dim xFileDlg As FileDialog Dim xFolder As String Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Dim xStrName As String Dim xV As Variant Set xSht = ActiveSheet Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) If xFileDlg.Show = True Then xFolder = xFileDlg.SelectedItems(1) Else MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" Exit Sub End If xStrName = "" xV = Application.InputBox("Please enter the filename:", "Kutools for Excel", , , , , , 2) If xV = False Then Exit Sub End If xStrName = xV If xStrName = "" Then MsgBox ("No filename entered, exiting process!") Exit Sub End If xFolder = xFolder + "\" + xStrName + ".pdf" 'Check if file already exist If Len(Dir(xFolder)) > 0 Then xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ vbYesNo + vbQuestion, "File Exists") On Error Resume Next If xYesorNo = vbYes Then Kill xFolder Else MsgBox "if you don't overwrite the existing PDF, I can't continue." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" Exit Sub End If If Err.Number <> 0 Then MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" Exit Sub End If End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then 'Save as PDF file xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "" .CC = "" .Subject = xSht.Name + ".pdf" .Attachments.Add xFolder If DisplayEmail = False Then '.Send End If End With Else MsgBox "The active worksheet cannot be blank" Exit Sub End If End Sub
  • To post as a guest, your comment is unpublished.
    Alison · 8 months ago
    This code works great except i want to have the worksheet saved as sheet name + date (ie. Sheet1 Oct 1 2020); on the user's desktop (this will be used by multiple people and their paths may vary slightly). If possible, i want to embed a .jpg into the body as well.. the JPG is located both inside the worksheet (outside of print area) and the image is stored on a shared server.. though the path to the server varies by user (for most it is a "T" drive for some a "U" drive)

    can this be done? please and thank you a million times.
  • To post as a guest, your comment is unpublished.
    Geoff · 10 months ago
    If I were wanting it to autosave in a specific folder each and every time (eliminating the need for the user to choose the folder), how would i do that?
    Ex. C: Invoices/NorthAmerica/Clients
    Help is greatly appreciated.
    • To post as a guest, your comment is unpublished.
      crystal · 9 months ago
      Hi Geoff,
      If you want to automatically save the pdf file to a specific folder rather than selecting the location manually, please try the below code. Don't forget to change the folder path in the code.

      Sub SaveAsPDFandSend() Dim xSht As Worksheet Dim xFileDlg As FileDialog Dim xFolder As String Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Dim xPath As String Set xSht = ActiveSheet xPath = "C:\Users\Win10x64Test\Desktop\worksheet to pdf" 'here "workshet to pdf" is the destination folder to save the pdf files xFolder = xPath + "\" + xSht.Name + ".pdf" If Len(Dir(xFolder)) > 0 Then xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ vbYesNo + vbQuestion, "File Exists") On Error Resume Next If xYesorNo = vbYes Then Kill xFolder Else MsgBox "if you don't overwrite the existing PDF, I can't continue." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" Exit Sub End If If Err.Number <> 0 Then MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" Exit Sub End If End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then 'Save as PDF file xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "" .CC = "" .Subject = xSht.Name + ".pdf" .Attachments.Add xFolder If DisplayEmail = False Then '.Send End If End With Else MsgBox "The active worksheet cannot be blank" Exit Sub End If End Sub
    • To post as a guest, your comment is unpublished.
      crystal · 10 months ago
      Hi Geoff,
      Do you mean save the worksheet as an pdf file and save into a specific folder without sending?
      • To post as a guest, your comment is unpublished.
        Jeremy · 9 months ago
        I think Geoff means being able to specific a specific folder in the code that the pdf is saved to each time rather than having to select the location manually. The pdf is then emailed from that specific folder.
        • To post as a guest, your comment is unpublished.
          crystal · 9 months ago
          Thank you Jeremy.
  • To post as a guest, your comment is unpublished.
    Kishore · 1 years ago
    Hi Crystal,

    It's really great and working perfectly for me. Need more help to add:

    1. in "Body" I want to give link to particular cell of Active sheet. Further Would like to Bold the text.

    Thanks

    Regards

    Kishore Kumar

    • To post as a guest, your comment is unpublished.
      crystal · 1 years ago
      Hi,
      Do you mean to add the cell value automatically to the mailbody and bold it? Supposing you add the value of C4 to the mail body. Please apply the below code.
      Sub Saveaspdfandsend()
      Dim xSht As Worksheet
      Dim xFileDlg As FileDialog
      Dim xFolder As String
      Dim xYesorNo As Integer
      Dim xOutlookObj As Object
      Dim xEmailObj As Object
      Dim xUsedRng As Range

      Set xSht = ActiveSheet
      Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

      If xFileDlg.Show = True Then
      xFolder = xFileDlg.SelectedItems(1)
      Else
      MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
      Exit Sub
      End If
      xFolder = xFolder + "\" + xSht.Name + ".pdf"

      'Check if file already exist
      If Len(Dir(xFolder)) > 0 Then
      xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
      vbYesNo + vbQuestion, "File Exists")
      On Error Resume Next
      If xYesorNo = vbYes Then
      Kill xFolder
      Else
      MsgBox "if you don't overwrite the existing PDF, I can't continue." _
      & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
      Exit Sub
      End If
      If Err.Number <> 0 Then
      MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
      & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
      Exit Sub
      End If
      End If

      Set xUsedRng = xSht.UsedRange
      If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
      'Save as PDF file
      xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

      'Create Outlook email
      Set xOutlookObj = CreateObject("Outlook.Application")
      Set xEmailObj = xOutlookObj.CreateItem(0)
      With xEmailObj
      .Display
      .To = ""
      .CC = ""
      .Subject = xSht.Name + ".pdf"
      .Attachments.Add xFolder
      .HTMLBody = "
      " & Range("C4") & .HTMLBody
      If DisplayEmail = False Then
      '.Send
      End If
      End With
      Else
      MsgBox "The active worksheet cannot be blank"
      Exit Sub
      End If
      End Sub
  • To post as a guest, your comment is unpublished.
    Odd-Inge · 1 years ago
    Hello,

    Is it possible to find the name for pdf from a cell? Ex. Cell H4


    And in Cell H4 i want it to collect from three different cells. Is this possible?
    • To post as a guest, your comment is unpublished.
      Taylor · 1 years ago
      This is possible. Make separate variables to hold the value from the cells and then use those variables when setting xFolder.
      I used the value from a cell in my sheet plus today's date. You could easily do multiple cell values though.

      This is what I added:
      Dim xMemberName As String
      Dim xFileDate As String

      xMemberName = Range("H3").Value
      xFileDate = Format(Now, "mm-dd")

      xFolder = xFolder + "\" xMemberName + xFileDate + ".pdf"
  • To post as a guest, your comment is unpublished.
    Jason · 2 years ago
    How can I make it delete the saved pdf after it emails it?
    • To post as a guest, your comment is unpublished.
      crystal · 2 years ago
      Hi Jason,
      Sorry can't help you with that yet. You need to manually delete it after emailing it.
  • To post as a guest, your comment is unpublished.
    ranga · 2 years ago
    Thanks it works.
  • To post as a guest, your comment is unpublished.
    james · 2 years ago
    Hi, how can i save & send the pdf wit the workbook name with the current VBA code? what do i use instead of xSht.Name
    • To post as a guest, your comment is unpublished.
      crystal · 2 years ago
      Hi James,
      Do you want to send the active worksheet as pdf and name it as the workbook name?
  • To post as a guest, your comment is unpublished.
    Tom H · 3 years ago
    How would I edit the VBA script above so that the file name is saved as a specific cell selected within the current sheet, for example cell A1?
    • To post as a guest, your comment is unpublished.
      crystal · 2 years ago
      Hi Tom.
      Sorry can’t help with this.
      Welcome to post any question in our forum: https://www.extendoffice.com/forum.html
      You will get more Excel support from out Excel professional or other Excel fans.
  • To post as a guest, your comment is unpublished.
    Armin · 3 years ago
    How can I add for example sheet 2 from the workbook as an pdf?
    • To post as a guest, your comment is unpublished.
      crystal · 2 years ago
      Hi Armin,
      You need to open the Sheet 2 in your workbook firstly and then run the VBA code with above steps to get it down.
  • To post as a guest, your comment is unpublished.
    saultmc@gmail.com · 3 years ago
    How would I edit the VBA script above so that it adds a date and time stamp to the file name that way it doesn't keep overwriting what is already saved?
    • To post as a guest, your comment is unpublished.
      crystal · 3 years ago
      Dear Michael,
      Please run the below VBA code to solve the problem.

      Sub Saveaspdfandsend()
      Dim xSht As Worksheet
      Dim xFileDlg As FileDialog
      Dim xFolder As String
      Dim xYesorNo As Integer
      Dim xOutlookObj As Object
      Dim xEmailObj As Object
      Dim xUsedRng As Range
      Dim xStr As String

      Set xSht = ActiveSheet
      Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

      If xFileDlg.Show = True Then
      xFolder = xFileDlg.SelectedItems(1)
      Else
      MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
      Exit Sub
      End If
      xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
      xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

      'Check if file already exist
      If Len(Dir(xFolder)) > 0 Then
      xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
      vbYesNo + vbQuestion, "File Exists")
      On Error Resume Next
      If xYesorNo = vbYes Then
      Kill xFolder
      Else
      MsgBox "if you don't overwrite the existing PDF, I can't continue." _
      & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
      Exit Sub
      End If
      If Err.Number <> 0 Then
      MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
      & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
      Exit Sub
      End If
      End If

      Set xUsedRng = xSht.UsedRange
      If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
      'Save as PDF file
      xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

      'Create Outlook email
      Set xOutlookObj = CreateObject("Outlook.Application")
      Set xEmailObj = xOutlookObj.CreateItem(0)
      With xEmailObj
      .Display
      .To = ""
      .CC = ""
      .Subject = xSht.Name + "-" + xStr + ".pdf"
      .Attachments.Add xFolder
      If DisplayEmail = False Then
      '.Send
      End If
      End With
      Else
      MsgBox "The active worksheet cannot be blank"
      Exit Sub
      End If
      End Sub
      • To post as a guest, your comment is unpublished.
        parag1somani · 2 years ago
        Hi Crystal,

        It's really great and working perfectly for me. Need more help to add:

        1. in "To" I want to give link to particular cell of Active sheet like wise in CC and in BCC i would like to add active sheet link
        2. in e-mail body i need to specify some standard text.

        I will be great full to you for your help.

        Thanks
        Parag
      • To post as a guest, your comment is unpublished.
        Parag Somani · 2 years ago
        Hi Crystal,

        It's really great and working perfectly for me. Need more help to add:

        1. in "To" I want to give link to particular cell of Active sheet like wise in CC and in BCC i would like to add active sheet link
        2. in e-mail body i need to specify some standard text.

        I will be great full to you for your help.

        Thanks
        Parag
      • To post as a guest, your comment is unpublished.
        Parag Somani · 2 years ago
        Hi Crystal,

        It's really great and working perfectly for me. Need more help to add:

        1. in "To" I want to give link to particular cell of Active sheet like wise in CC and in BCC i would like to add active sheet link
        2. in e-mail body i need to specify some standard text.

        I will be great full to you for your help.

        Thanks
        Parag
        • To post as a guest, your comment is unpublished.
          crystal · 2 years ago
          Hi Parag Somani,
          The below VBA code can help you. Please change the .To, .CC, .BCC and .Body fields based on your needs.

          Sub Saveaspdfandsend()
          Dim xSht As Worksheet
          Dim xFileDlg As FileDialog
          Dim xFolder As String
          Dim xYesorNo As Integer
          Dim xOutlookObj As Object
          Dim xEmailObj As Object
          Dim xUsedRng As Range
          Dim xStr As String

          Set xSht = ActiveSheet
          Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

          If xFileDlg.Show = True Then
          xFolder = xFileDlg.SelectedItems(1)
          Else
          MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
          Exit Sub
          End If
          xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
          xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

          'Check if file already exist
          If Len(Dir(xFolder)) > 0 Then
          xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
          vbYesNo + vbQuestion, "File Exists")
          On Error Resume Next
          If xYesorNo = vbYes Then
          Kill xFolder
          Else
          MsgBox "if you don't overwrite the existing PDF, I can't continue." _
          & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
          Exit Sub
          End If
          If Err.Number <> 0 Then
          MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
          & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
          Exit Sub
          End If
          End If

          Set xUsedRng = xSht.UsedRange
          If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
          'Save as PDF file
          xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

          'Create Outlook email
          Set xOutlookObj = CreateObject("Outlook.Application")
          Set xEmailObj = xOutlookObj.CreateItem(0)
          With xEmailObj
          .Display
          .To = Range("A8")
          .CC = Range("A9")
          .BCC = Range("A10")
          .Subject = xSht.Name + "-" + xStr + ".pdf"
          .Body = "Dear " _
          & vbNewLine & vbNewLine & _
          "This is a test email " & _
          "sending in Excel"
          .Attachments.Add xFolder
          If DisplayEmail = False Then
          '.Send
          End If
          End With
          Else
          MsgBox "The active worksheet cannot be blank"
          Exit Sub
          End If
          End Sub
  • To post as a guest, your comment is unpublished.
    Darren · 3 years ago
    I have tried pasting this into a new module and i get Compile error: Sub or Function not defined. Please help.
    • To post as a guest, your comment is unpublished.
      Bill · 2 years ago
      Same issue
    • To post as a guest, your comment is unpublished.
      crystal · 3 years ago
      Dear Darren,
      Which Office version do you use?
      • To post as a guest, your comment is unpublished.
        Nakia · 2 years ago
        Office 360
  • To post as a guest, your comment is unpublished.
    Michael · 3 years ago
    This is working great for me but is there a way to select a folder location automatically rather than select manually? I am hoping to do this for 40 sheets at once.
    • To post as a guest, your comment is unpublished.
      Hugh · 11 months ago
      Also hoping to see an answer for this issue! Thanks for the help!