Skip to main content

Conas bileog oibre a shábháil mar chomhad PDF agus í a sheoladh ar ríomhphost mar cheangaltán trí Outlook?

I roinnt cásanna, b’fhéidir go mbeidh ort bileog oibre a sheoladh mar chomhad PDF trí Outlook. De ghnáth, caithfidh tú an bhileog oibre a shábháil de láimh mar chomhad PDF, ansin r-phost nua a chruthú leis an gcomhad PDF seo mar cheangaltán i do Outlook agus é a sheoladh ar deireadh. Tógann sé am chun é a bhaint amach de láimh céim ar chéim. San Airteagal seo, taispeánfaimid duit conas bileog oibre a shábháil go tapa mar chomhad PDF agus é a sheoladh go huathoibríoch mar cheangaltán trí Outlook in Excel.

Sábháil bileog oibre mar chomhad PDF agus seol ríomhphost é mar cheangaltán le cód VBA

Sábháil bileog oibre mar chomhad PDF agus seol ríomhphost é mar cheangaltán le cód VBA

Féadfaidh tú an cód VBA thíos a rith chun an bhileog oibre ghníomhach a shábháil go huathoibríoch mar chomhad PDF, agus ansin é a sheoladh ar ríomhphost mar cheangaltán trí Outlook. Déan mar a leanas le do thoil.

1. Oscail an bhileog oibre a shábhálfaidh tú mar PDF agus seol, ansin brúigh an Eile + F11 eochracha ag an am céanna chun an Microsoft Visual Basic d’Fheidhmchláir fhuinneog.

2. Sa Microsoft Visual Basic d’Fheidhmchláir fuinneog, cliceáil Ionsáigh > Modúil. Ansin cóipeáil agus greamaigh an cód VBA thíos sa cód fuinneog. Féach an pictiúr:

Cód VBA: Sábháil bileog oibre mar chomhad PDF agus seol ríomhphost mar cheangaltán

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. Brúigh an F5 eochair chun an cód a rith. Sa Brabhsáil bosca dialóige, roghnaigh fillteán le do thoil chun an comhad PDF seo a shábháil, agus ansin cliceáil ar an OK cnaipe.

nótaí:

1. Anois sábhálfar an bhileog oibre ghníomhach mar chomhad PDF. Agus ainmnítear an comhad PDF le hainm na bileoige oibre.
2. Má tá an bhileog oibre gníomhach bán, gheobhaidh tú bosca dialóige mar atá thíos ar an scáileán a thaispeántar tar éis duit an OK cnaipe.

4. Anois cruthaítear r-phost nua Outlook agus is féidir leat a fheiceáil go bhfuil an comhad PDF liostaithe mar cheangaltán sa chomhad Ceangailte. Féach an pictiúr:

5. Cum an ríomhphost seo le do thoil agus ansin é a sheoladh.
6. Níl an cód seo ar fáil ach nuair a úsáideann tú Outlook mar do chlár ríomhphoist.

Sábháil bileog oibre nó bileoga oibre iolracha go héasca mar chomhaid PDF ar leithligh ag an am céanna:

An Leabhar Oibre Scoilt fóntais de Kutools for Excel is féidir leis cabhrú leat bileog oibre nó bileoga oibre iolracha a shábháil go héasca mar chomhaid PDF ar leithligh ag an am céanna mar a thaispeántar an taispeántas thíos. Íoslódáil agus bain triail as anois! (30- rian lá saor in aisce,)

Earraí gaolmhara:

Uirlisí Táirgiúlachta Oifige is Fearr

Gnéithe Coitianta: Faigh, Aibhsigh nó Aithnigh Dúblaigh   |  Scrios Sraitheanna Bána   |  Comhcheangail Colúin nó Cealla gan Sonraí a Chailleadh   |   Babhta gan Foirmle ...
Cuardaigh Super: Ilchritéir VLookup  |   VLookup Illuachanna  |   VLookup Trasna Ilbhileoga   |   Amharc doiléir ....
Liosta anuas Casta: Go tapa Cruthaigh Liosta Anuas   |  Liosta anuas Cleithiúnach   |  Liosta Buail Isteach Ilroghnacha ....
Bainisteoir Colún: Cuir Líon Sonrach Colún leis  |  Colúin Bog  |  Scoránaigh Stádas Infheictheachta na gColún Ceilte  |  Déan comparáid idir Raonta & Colúin ...
Gnéithe Réadmhaoin: Fócas Eangaí   |  Amharc Dearaidh   |   Barra Mór na Foirmle   |  Leabhar Oibre & Bainisteoir Bileog   |  Leabharlann Acmhainní (Uaththéacs)   |  Piocálaí Dáta   |  Comhcheangail Bileoga Oibre   |  Criptigh/Díchriptigh Cealla   |  Seol Ríomhphost trí Liosta   |  Scagaire Super   |   Scagaire Speisialta (scagaire trom/iodálach/stailc tríd...) ...
Barr 15 Uirlisí:  12 Téacs uirlisí (Cuir Téacs, Bain Carachtair,...)   |   50 + Cairt cineálacha (Cairt Gantt,...)   |   40+ Praiticiúil Foirmlí (Ríomh aois bunaithe ar lá breithe,...)   |   19 Insertion uirlisí (Cuir isteach Cód QR, Ionsáigh Pictiúr ón gCosán,...)   |   12 Tiontú uirlisí (Uimhreacha le Focail, Comhshó Airgeadra,...)   |   7 Cumaisc & Scoilt uirlisí (Sraitheanna Comhcheangail Casta, Cealla Scoilt,...)   |   ... agus eile

Supercharge Do Scileanna Excel le Kutools for Excel, agus Éifeachtúlacht Taithí Cosúil Riamh Roimhe. Kutools for Excel Tairiscintí os cionn 300 Ardghné chun Táirgiúlacht a Mhéadú agus Am a Shábháil.  Cliceáil anseo chun an ghné is mó a theastaíonn uait a fháil ...

cluaisín kte 201905

Office Tab Tugann sé comhéadan Tabbed chuig Oifig, agus Déan do chuid Oibre i bhfad níos éasca

  • Cumasaigh eagarthóireacht agus léamh tabbed i Word, Excel, PowerPoint, Foilsitheoir, Rochtain, Visio agus Tionscadal.
  • Oscail agus cruthaigh cáipéisí iolracha i gcluaisíní nua den fhuinneog chéanna, seachas i bhfuinneoga nua.
  • Méadaíonn do tháirgiúlacht 50%, agus laghdaíonn sé na céadta cad a tharlaíonn nuair luch duit gach lá!
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