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

[gringo287]

Hi,

I've Set up a Search engine of sorts, in excel. Basically it works of one list with title in one column and url etc in the next cell.

The aim is to reduce the time it takes for users to find what the need, whether it be a youtube clip, pdf, website or product info. once the search is done and selection made, the user can then view/play (through either a WebBrowser/Pdf viewer in my userform) the selection or email it to a customer.

essentially it works fine, but i'm keen to make it as good as it can be. I've done some searching and found (http://www.rondebruin.nl/pdf.htm), which although is very good, its not what i'm looking for. I want to be able to create a Pdf attachment from the search result, which would be the url for a pdf from a manufacturers website for example.

I'd also really like to be able to get some advice on a question related to this same project that i posted here a few months back. I'd love to be able to do the same as i can with Pdf's and youtube clips, with power point presentations as well. this would also mean that, if this is possible I'd really love it if i could then send them via attachments, the same as i want to with the pdf's.

P.s

windows 8 is a stinking pile.... and don get me started on microsoft wireless keyboard/mice

[gringo287]

Didn't have to time to add this before


[VBA]Option Explicit

Sub Guru_Click()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")

For Each ws In ActiveWorkbook.Worksheets
If ws.Range("A1").Value Like "?*@?*.?*" Then
If ws.Range("A1").Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = ws.Range("A1").Value
.CC = ""
.BCC = ""
.Subject = "THIS MAILBOX IS OUTGOING ONLY AND IS NOT MONITORED, PLEASE DO NOT REPLY"
.HTMLBody = RangetoHTML(ws.UsedRange)
' ***I saw this on one of my searches, but this has no affect and no errors ***
'.attachments.Add ("C:\Users\gringo\Documents\Outlook Files\Nokia_Lumia_820_UG_en")
.Send 'or use .Send
End With
On Error GoTo 0

Set OutMail = Nothing
End If
End If
Next ws

Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub[/VBA]

[gringo287]

Great!

Is this a "Great", you will i'll be able to help, or "Great", you will use this code for your project

[gringo287]

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]