Didn't really understand 100% what's happening wrong but having had a
quick look at your code this:

ActiveSheet.ExportAsFixedFormat

would suggest that you're exporting only the activesheet and i didn't
see there any loops going through all of the sheets of the wb.
Not sure if i go that right but something you might wanna look at.


On Sep 30, 1:44*pm, Seanie wrote:
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(xlCellTypeConsta nts)
* * * * 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