I think this was taken from the internet someplace. Its the code behind out help tickets at work.
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
'
Const MAX_PATH = 260
'
' This function uses Windows API GetTempPath to get the temporary folder
Sub Get_Temporary_Folder()
sTempFolder = GetTmpPath
End Sub
'
'
Function GetTmpPath()
Dim sFolder As String ' Name of the folder
Dim lRet As Long ' Return Value
sFolder = String(MAX_PATH, 0)
lRet = GetTempPath(MAX_PATH, sFolder)
If lRet <> 0 Then
GetTmpPath = Left(sFolder, InStr(sFolder, _
Chr(0)) - 1)
Else
GetTmpPath = vbNullString
End If
End Function
'
'
'
'
'Main Functions
Sub Workbook_To_PDF()
Randomize
Dim filename As String
Dim File As String
Dim Send_To As String
Dim Subject_Line As String
Dim Body_Text As String
Dim Send_Email_Automatically As Boolean
Dim Show_Saved_File As Boolean
GetTmpPath
File = GetTmpPath & "YourPdfFile " & Right(Rnd(), 5) & ".pdf"
Show_Saved_File = False 'False = No
filename = Create_PDF(ActiveWorkbook, File, True, Show_Saved_File)
Send_To = "" '''Enter to email address here
Subject_Line = "" '''Enter subject here
Body_Text = "" '''Enter email body here
Send_Email_Automatically = True 'False = No
Mail_Me = Mail_PDF_Outlook(File, Send_To, Subject_Line, Body_Text, Send_Email_Automatically)
End Sub
'
'
Function 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 to see if the Microsoft Create/Send 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 file.
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 then test to see if the PDF
'already exists in the folder and exit the function if it does.
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
'Now export the PDF file.
On Error Resume Next
Myvar.ExportAsFixedFormat _
Type:=xlTypePDF, _
filename:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If the export is successful, return the file name.
If Dir(Fname) <> "" Then Create_PDF = Fname
End If
End Function
'
'
Function 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
Bookmarks