Перейти до основного матеріалу

Як зберегти аркуш як файл 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 для додатків вікна, натисніть Insert > Модулі. Потім скопіюйте та вставте наведений нижче код 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 клавіша для запуску коду. В перегорнути діалоговому вікні, виберіть папку для збереження цього PDF-файлу, а потім клацніть на OK кнопки.

примітки:

1. Тепер активний аркуш зберігається як файл PDF. І файл PDF називається іменем робочого аркуша.
2. Якщо активний робочий аркуш порожній, ви отримаєте діалогове вікно, як показано на екрані нижче, після натискання на OK кнопки.

4. Тепер створено нове повідомлення електронної пошти Outlook, і ви можете побачити, що файл PDF вказано як вкладення у вкладці Вкладені. Дивіться знімок екрана:

5. Будь ласка, складіть цей електронний лист, а потім надішліть його.
6. Цей код доступний лише тоді, коли ви використовуєте Outlook як свою поштову програму.

Легко зберігайте аркуш або кілька аркушів як окремі файли PDF одночасно:

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

Статті по темі:

Найкращі інструменти продуктивності офісу

Популярні функції: Знайдіть, виділіть або визначте дублікати   |  Видалити порожні рядки   |  Об’єднайте стовпці або клітинки без втрати даних   |   Раунд без Формули ...
Супер пошук: VLookup за кількома критеріями  |   Багатозначний VLookup  |   VLookup на кількох аркушах   |   Нечіткий пошук ....
Розширений розкривний список: Швидке створення випадаючого списку   |  Залежний спадний список   |  Виберіть розкривний список, що вибирається ....
Менеджер колонок: Додайте конкретну кількість стовпців  |  Перемістити стовпці  |  Перемкнути статус видимості прихованих стовпців  |  Порівняйте діапазони та стовпці ...
Особливості: Фокус сітки   |  Перегляд дизайну   |   Велика панель формул   |  Диспетчер робочих книг і аркушів   |  Бібліотека ресурсів (автотекст)   |  Вибір дати   |  Об’єднайте робочі аркуші   |  Шифрування/розшифрування клітинок   |  Надсилайте листи за списком   |  Супер фільтр   |   Спеціальний фільтр (фільтр жирний/курсив/закреслений...) ...
Топ-15 наборів інструментів:  12 текст Tools (додати текст, Видалити символи, ...)   |   50 + Графік типи (діаграма Ганта, ...)   |   40+ Практичний Формули (Розрахуйте вік на основі дня народження, ...)   |   19 вставка Tools (Вставте QR-код, Вставити зображення зі шляху, ...)   |   12 Перетворення Tools (Числа до слів, Валютна конверсія, ...)   |   7 Злиття та розділення Tools (Розширені комбіновані ряди, Розділені клітини, ...)   |   ... і більше

Покращуйте свої навички Excel за допомогою Kutools for Excel, і відчуйте ефективність, як ніколи раніше. Kutools for Excel Пропонує понад 300 додаткових функцій для підвищення продуктивності та економії часу.  Натисніть тут, щоб отримати функцію, яка вам найбільше потрібна...

вкладка kte 201905

Office Tab Надає інтерфейс із вкладками в Office і значно полегшує вашу роботу

  • Увімкніть редагування та читання на вкладках у Word, Excel, PowerPoint, Publisher, Access, Visio та Project.
  • Відкривайте та створюйте кілька документів на нових вкладках того самого вікна, а не в нових вікнах.
  • Збільшує вашу продуктивність на 50% та зменшує сотні клацань миші для вас щодня!
Comments (66)
Rated 5 out of 5 · 1 ratings
Mayko
Mayko
This comment was minimized by the moderator on the site
Hello, I am a total noob when doing this; so I apologize in advance.

My work has us email them our hours bi weekly, I am based in Arizona US. But I travel for work to Germany. My ADP time management app doesn't work well, given the time difference. So I email my hours, but it's annoying have to type it all every time. So I made a sheet in excel to help me out.
I am using the code posted above to attach pdf attachment to email. But I wanted to add the active sheet in the email body as well. How would I go about it using the same code posted in above. Basically I want to have a button to attach pdf of sheet and in the email body have a screenshot of the same sheet, But I also want my signature below.
I need both options in one button.
(I attached an image of what I mean about screenshot in email body )

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
Reply
Report
0
0
crystal
crystal     Mayko
This comment was minimized by the moderator on the site
Hi Mayko,
The following VBA code can help you. After running the code, you need to select a folder to save the pdf file. Then, the pdf file will be inserted as an attachment to the email, and a screenshot of the contents of the currently active worksheet and the Outlook signature will be added to the body of the email.


Sub Saveaspdfandsend()
'Updated by Extendoffice 2023/10/19
    Dim xSht As Worksheet
    Dim xFileDlg As FileDialog
    Dim xFolder As String
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim defaultBodyText 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

    xFolder = xFolder & "\" & xSht.Name & ".pdf"

    'Check if file already exists
    If Len(Dir(xFolder)) > 0 Then
        Dim xYesorNo As Integer
        xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
        If xYesorNo <> vbYes Then
            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
        On Error Resume Next
        Kill xFolder
        On Error GoTo 0
    End If

    '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)
    
    ' Display the email first to ensure signature is loaded
    xEmailObj.Display

    ' Default body text
    defaultBodyText = "<br><br>Dear [Recipient Name],<br><br>Please find attached the requested document.<br><br>Best regards,<br>[Your Name]<br><br>"
    
    ' Update the body while preserving the original (which contains the signature)
    xEmailObj.HTMLBody = defaultBodyText & xEmailObj.HTMLBody

    'Copy the worksheet's content as a picture
    xSht.UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

    'Paste the copied picture to the mail body
    Dim xWordDoc As Object
    Set xWordDoc = xEmailObj.GetInspector.WordEditor
    xWordDoc.Range(0, 0).PasteAndFormat 16 ' 16 is wdChartPicture

    'Add the attachment
    xEmailObj.Attachments.Add xFolder
End Sub
Reply
Report
0
0
Zee
Zee
This comment was minimized by the moderator on the site
I'm using the original post and loving it.
I would like to know how I would be able to set a permanent folder that it downloads the pdf into.
my folder is
G:\BFM\Supervisor\Shift Update Archive

Thankyou
Reply
0
0
crystal
crystal     Zee
This comment was minimized by the moderator on the site
Hi Zee,

The following VBA code can help. Please give it a try. Thank you.
Sub Saveaspdfandsend()
'Updated by Extendoffice 20230130
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

xFolder = "G:\BFM\Supervisor\Shift Update Archive" + "\" + 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
Reply
Report
0
0
Cipri
Cipri
This comment was minimized by the moderator on the site
Hi Crystal,

Is it possible to set the pdf name from a specific cell?

Thank you in advance!
Reply
0
0
crystal
crystal     Cipri
This comment was minimized by the moderator on the site
Hi Cipri,
Suppose you want to name the pdf file with the value of A1.
Find the following line in the VBA code:
xFolder = xFolder + "\" + xSht.Name + ".pdf"

Then replace it with the line below.
xFolder = xFolder + "\" + Range("A1") + ".pdf"
Reply
Report
0
0
Cipri
Cipri
This comment was minimized by the moderator on the site
Hi Crystal.

Is there any possibility to save the pdf automatically to a specific folder with the sheet name followed by date and time for example?

I have tried to run one of your codes but it gives me an error at this line

xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

Thank you!
Reply
0
0
crystal
crystal     Cipri
This comment was minimized by the moderator on the site
Hi Cipri,
If you want to save the pdf automatically to a specific folder with the sheet name followed by date and time. The following VBA code can do you a favor.

Sub Saveaspdfandsend()
'Updated by Extendoffice 20220819
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 + Format(Now, "dd-mmm-yy h-mm-ss") + ".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
Reply
Report
0
0
Yousef
Yousef
This comment was minimized by the moderator on the site
Hi,
Many thanks for the code, but can we save a range to PDF.

for example i would like to save a range from B2:Q40 to PDF only?
Reply
0
0
crystal
crystal     Yousef
This comment was minimized by the moderator on the site
Hi,
The following VBA code can do you a favor. Please give it a try.
Sub Saveaspdfandsend()
'Updated by Extendoffice 20220819
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 xWb As Workbook

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
Set xUsedRng = xSht.Range("B2:Q40")
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    Application.ScreenUpdating = False
    xUsedRng.Copy
    Set xWb = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
    Application.DisplayAlerts = False
    xWb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    '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
Reply
Report
0
0
Jurandir
Jurandir
This comment was minimized by the moderator on the site
Boa tarde,

Conteúdo muito bom mesmo.

É possível criar uma Macro que ao clicar no botão atribuído a essa macro ela envia a planilha automaticamente em PDF para um endereço de e-mail?

Desde já agradeço
Reply
0
0
Rated 5 out of 5
crystal
crystal     Jurandir
This comment was minimized by the moderator on the site
Hi Jurandir,
If you need a button to run the VBA code, please do as follows.
1. Click Develper > Insert > Button (Form Control), then draw a button in a worksheet.
2. After drawing the button, an Assign Macro dialog box pops up, click the New button.
3. Copy the VBA code except the first and last lines, and then paste it between the existing lines in the Code window.
4. Press the Alt + Q keys to close the Code window.
Then you can press the button to run the code.
Reply
Report
0
0
Sudhy
Sudhy
This comment was minimized by the moderator on the site
hi this is working perfectly for me, Can you please help me to do the following along with this Code(1) to save, select the file name from a given cell in the worksheet(2) Automatically add an email address from a cell
Reply
0
0
Rueben
Rueben
This comment was minimized by the moderator on the site
Hi
Thanks for the code but I still having an issue emailing the doc in PDF straight after publishing. This is the current code that I have. I copied the "send email" code from this site.
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStrName As String

Dim x As Integer
Application.ScreenUpdating = False


' Set numrows = number of rows of data.
NumRows = Worksheets("DATA").Range("A2", Range("A2").End(xlDown)).Rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
'Reference
Worksheets("Template").Cells(22, 5) = Worksheets("DATA").Cells(x + 1, 2)
'Invoice Number
Worksheets("Template").Cells(22, 7) = Worksheets("DATA").Cells(x + 1, 9)
'Description
Worksheets("Template").Cells(26, 1) = "HANDLING FEE:" & " " & Worksheets("DATA").Cells(x + 1, 6)
'Amounts
Worksheets("Template").Cells(26, 9) = Worksheets("DATA").Cells(x + 1, 4)

' Insert your code here.
' Selects cell down 1 row from active cell.
' ActiveCell.Offset(1, 0).Select
Set wbA = ActiveWorkbook
Set wsA = Worksheets("Template")


'get active workbook folder, if saved
' On Error GoTo errHandler
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
Application.ScreenUpdating = True
strName = wsA.Range("L1").Value _
& " - " & wsA.Range("A2").Value _
& " - " & wsA.Range("A3").Value

'create default name for savng file
strFile = strName & ".pdf"
strPathFile = strPath & strFile

'export to PDF in current folder
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
' MsgBox "PDF file has been created: " _
' & vbCrLf _
' & strPathFile

' Create Outlook email

Set OutMail = OutApp.CreateItem(0)

strMsg = "Could not start mail for " _
& c.Value
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = strSubj
.Body = strBody
.Attachments.Add _
strSavePath & strPDFName
.Send
End With
On Error GoTo 0
lSent = lSent + 1
If lSent >= lCount Then Exit For


MsgBox "The active worksheet cannot be blank"
Exit Sub


exitHandler:
' Set wsA = Worksheets("Template")
'errHandler:
' MsgBox "Could not create PDF file"
' Resume exitHandler


Next
End Sub



Reply
Report
0
0
Rod Bennett
Rod Bennett
This comment was minimized by the moderator on the site
Hi
Many thanks for the Code but is it possible to save the the PDF automatically to the same location as the active Excel file and with the same file name as the active Excel file?
Many thanks.
Rod
Reply
0
0
Nicole
Nicole
This comment was minimized by the moderator on the site
How do I edit this code to only save cells ("a1:r99") to save as the PDF. I have extra stuff on the sides I don't want in my PDF document.
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
Reply
0
0
RLF
RLF     Nicole
This comment was minimized by the moderator on the site
Hello, I just tried this code on one of my worksheets and I have print areas set so the extra stuff at the bottom did not appear in the pdf. Try it!
Reply
0
0
There are no comments posted here yet
Load More
Please leave your comments in English
Guest
Posting as Guest
×
Rate this post:
Reset
0   Characters
Suggested Locations