Consulting

Results 1 to 4 of 4

Thread: Solved: Create pdf attachment from Url in cell and send via Outlook

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Great!
    Is this a "Great", you will i'll be able to help, or "Great", you will use this code for your project

  2. #2
    Ok, it seems I've stared at Ron de Bruins' Pdf macro for long enough now to "almost" get my head around it.

    My only remaining task now, is, to get around having to use a coded file name. Is there a way to pick up the "\gringo\" from the pc username. I really don't want to use a shared workbook.


    [VBA]Sub RDB_Worksheet_Or_Worksheets_To_PDF()
    Dim FileName As String

    If ActiveWindow.SelectedSheets.Count > 1 Then
    MsgBox "There is more then one sheet selected," & vbNewLine & _
    "be aware that every selected sheet will be published"
    End If

    'Call the function with the correct arguments
    'Tip: You can also use Sheets("Sheet3") instead of ActiveSheet in the code(sheet not have to be active then)
    'FileName = RDB_Create_PDF(Sheets("Sheet1"), "", True, True)

    FileName = RDB_Create_PDF(Sheets("Sheet1"), "C:\Users\gringo\Documents\PDF-Examples.pdf", True, True)
    'For a fixed file name and overwrite it each time you run the macro use
    'RDB_Create_PDF(ActiveSheet, "C:\Users\Ron\Test\YourPdfFile.pdf", True, True)

    If FileName <> "" Then
    'Ok, you find the PDF where you saved it
    'You can call the mail macro here if you want
    Else
    MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
    "Microsoft Add-in is not installed" & vbNewLine & _
    "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
    "The path to Save the file in arg 2 is not correct" & vbNewLine & _
    "You didn't want to overwrite the existing PDF if it exist"
    End If
    End Sub[/VBA]

    ==============

    [VBA]Option Explicit

    'The code below are used by the macros in the other two modules
    'Do not change the code in the functions in this module

    Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
    OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
    & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

    If FixedFilePathName = "" Then
    'Open the GetSaveAsFilename dialog to enter a file name for the pdf
    FileFormatstr = "PDF Files (*.pdf), *.pdf"
    Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
    Title:="Create PDF")

    'If you cancel this dialog Exit the function
    If Fname = False Then Exit Function
    Else
    Fname = FixedFilePathName
    End If

    'If OverwriteIfFileExist = False we test if the PDF
    'already exist in the folder and Exit the function if that is True
    If OverwriteIfFileExist = False Then
    If Dir(Fname) <> "" Then Exit Function
    End If

    'Now the file name is correct we Publish to PDF
    On Error Resume Next
    Myvar.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    FileName:=Fname, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=OpenPDFAfterPublish = True
    On Error GoTo 0

    'If Publish is Ok the function will return the file name
    If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
    End Function



    Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
    StrSubject As String, StrBody As String, Send As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
    .To = StrTo
    .CC = ""
    .BCC = ""
    .Subject = StrSubject
    .Body = StrBody
    .Attachments.Add FileNamePDF
    If Send = True Then
    .Send
    Else
    .Display
    End If
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
    End Function



    Function Create_PDF_Sheet_Level_Names(NamedRange As String, FixedFilePathName As String, _
    OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    'This function will create a PDF with every sheet with
    'a sheet level name variable <NamedRange> in it
    Dim FileFormatstr As String
    Dim Fname As Variant
    Dim Ash As Worksheet
    Dim sh As Worksheet
    Dim ShArr() As String
    Dim s As Long
    Dim SheetLevelName As Name

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
    & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

    'We fill the Array with sheets with the sheet level name variable
    For Each sh In ActiveWorkbook.Worksheets
    If sh.Visible = -1 Then
    Set SheetLevelName = Nothing
    On Error Resume Next
    Set SheetLevelName = sh.Names(NamedRange)
    On Error GoTo 0
    If Not SheetLevelName Is Nothing Then
    s = s + 1
    ReDim Preserve ShArr(1 To s)
    ShArr(s) = sh.Name
    End If
    End If
    Next sh

    'We exit the function If there are no sheets with
    'a sheet level name variable named <NamedRange>
    If s = 0 Then Exit Function

    If FixedFilePathName = "" Then

    'Open the GetSaveAsFilename dialog to enter a file name for the pdf
    FileFormatstr = "PDF Files (*.pdf), *.pdf"
    Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
    Title:="Create PDF")

    'If you cancel this dialog Exit the function
    If Fname = False Then Exit Function
    Else
    Fname = FixedFilePathName
    End If


    'If OverwriteIfFileExist = False we test if the PDF
    'already exist in the folder and Exit the function if that is True
    If OverwriteIfFileExist = False Then
    If Dir(Fname) <> "" Then Exit Function
    End If

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Remember the ActiveSheet
    Set Ash = ActiveSheet

    'Select the sheets with the sheet level name in it
    Sheets(ShArr).Select

    'Now the file name is correct we Publish to PDF
    On Error Resume Next
    ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    FileName:=Fname, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=OpenPDFAfterPublish = True
    On Error GoTo 0

    'If Publish is Ok the function will return the file name
    If Dir(Fname) <> "" Then
    Create_PDF_Sheet_Level_Names = Fname
    End If

    Ash.Select

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    End If
    End Function
    [/VBA]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •