S
Seanie
I'm using Ron De Bruins code to PDF an Excel sheet, it works great
except when I try to PDF more than one sheet it does not extract the
specified sheets at all. I'm getting a little confused, so below is
the code
Sub Mail_PDF()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim strbody As String
Dim FilenameStr As String
Dim TempWb As Workbook
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(olMailItem)
Set Sourcewb = ActiveWorkbook
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE"
_
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <>
"" Then
Sourcewb.Sheets(Array("SheetA", "SheetB")).Copy
Set TempWb = ActiveWorkbook
On Error Resume Next
Sheets("SheetA").Select
ActiveSheet.DrawingObjects.Visible = True
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0
'Change all cells in the worksheets to values if you want
With TempWb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
For Each cell In ThisWorkbook.Sheets("SheetA") _
.Columns("BC").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next
strto = Left(strto, Len(strto) - 1)
FilenameStr = Application.DefaultFilePath & "\" & "Part of " &
Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm") & "~.pdf"
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FilenameStr, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'Close the new workbook you create file without saving
TempWb.Close False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
For Each cell In ThisWorkbook.Sheets("SheetA").Range("BF2:BF35")
strbody = strbody & cell.Value & vbNewLine
Next
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = strto
.Subject =
ThisWorkbook.Sheets("SheetA").Range("BA1").Value
.Body = strbody
.Attachments.Add Destwb.FullName
.ReadReceiptRequested = True
If Sheets("SheetA").Range("D192").Value > 0 Then
.Importance = 2
Else
.Importance = 1
End If
.SendUsingAccount = OutApp.Session.Accounts.Item(3)
.Send
End With
On Error GoTo 0
'Delete the file you send
Kill FilenameStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Else
MsgBox "PDF add-in Not Installed"
End If
End Sub
except when I try to PDF more than one sheet it does not extract the
specified sheets at all. I'm getting a little confused, so below is
the code
Sub Mail_PDF()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim strbody As String
Dim FilenameStr As String
Dim TempWb As Workbook
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(olMailItem)
Set Sourcewb = ActiveWorkbook
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE"
_
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <>
"" Then
Sourcewb.Sheets(Array("SheetA", "SheetB")).Copy
Set TempWb = ActiveWorkbook
On Error Resume Next
Sheets("SheetA").Select
ActiveSheet.DrawingObjects.Visible = True
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0
'Change all cells in the worksheets to values if you want
With TempWb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
For Each cell In ThisWorkbook.Sheets("SheetA") _
.Columns("BC").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next
strto = Left(strto, Len(strto) - 1)
FilenameStr = Application.DefaultFilePath & "\" & "Part of " &
Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm") & "~.pdf"
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FilenameStr, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'Close the new workbook you create file without saving
TempWb.Close False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
For Each cell In ThisWorkbook.Sheets("SheetA").Range("BF2:BF35")
strbody = strbody & cell.Value & vbNewLine
Next
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = strto
.Subject =
ThisWorkbook.Sheets("SheetA").Range("BA1").Value
.Body = strbody
.Attachments.Add Destwb.FullName
.ReadReceiptRequested = True
If Sheets("SheetA").Range("D192").Value > 0 Then
.Importance = 2
Else
.Importance = 1
End If
.SendUsingAccount = OutApp.Session.Accounts.Item(3)
.Send
End With
On Error GoTo 0
'Delete the file you send
Kill FilenameStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Else
MsgBox "PDF add-in Not Installed"
End If
End Sub