VBA 07/10 to save & email PDF as attachment to blank email from Excel?

[shmalex123]

Hello,
So i have a vba code below that basically filters by the first column in a spreadsheet, copies the data relating to this field to a new sheet, formats it a certain way, saves it and then attaches to a blank outlook email. then i enter the recipients and body of email manually (as this varies with each spreadsheet it creates and i do not want this automated). This all works perfectly.

But what i am having problems with is that i want the file to save and be emailed as a pdf instead. i have found code to save the pdf but not to attach to an email. if i try to attach it to an email manually while the file is open then none of the print settings are kept and it does not fit on one page.

so i suppose what i need is; code that will attach my pdf to a blank email (so i can enter the recipient and the body text),
and also some code that will format the pdf so that the data is shrunk to one page wide and tall.

any ideas? --- yes i have tried Ron de bruin's help however none of his code actually prompts an outlook new blank email to open with the attachment

Application.Dialogs(xlDialogSendMail).Show -> this piece of code opens me a blank email from Excel. can this be done from the pdf????

Thank you!

Sub EmailStarts()
Dim fname
fname = InputBox("Enter the type of emails you are sending:")
Dim tdate
tdate = InputBox("Enter today's date [YYYYMMDD]:")
r = 2
Do While Cells(r, 1) <> ""
r = r + 1
Loop
r = r - 1
c = 2
Do While Cells(1, c) <> ""
c = c + 1
Loop
c = c - 1

Range(Cells(2, 1), Cells(r, 1)).Copy
Cells(2, 21).PasteSpecial Paste:=xlValues
CutCopyMode = False
Range(Cells(2, 21), Cells(r, 21)).Sort _
Key1:=Cells(2, 21), Order1:=xlAscending

x = 2
Do While Cells(x, 21) <> ""
If Cells(x, 21) = Cells(x - 1, 21) Then
Cells(x, 22) = 1
Else
Cells(x, 22) = 0
End If
x = x + 1
Loop
Range(Cells(2, 21), Cells(r, 22)).Sort _
Key1:=Cells(2, 22), Order1:=xlAscending
Cells(2, 22).Select
Range(Cells(2, 22), Cells(r, 22)).Find(What:="1", After:=ActiveCell, LookIn:=xlValues).Activate
x = ActiveCell.Row
Range(Cells(x, 21), Cells(r, 22)).ClearContents
Range(Cells(2, 22), Cells(r, 22)).ClearContents
Cells(1, 1).Select
For a = 2 To x
agent = Cells(a, 21)
Range(Cells(1, 1), Cells(r, 11)).AutoFilter Field:=1, Criteria1:=agent
Range(Cells(1, 1), Cells(r, c)).Copy
Workbooks.Add
ActiveSheet.Paste
Application.DisplayAlerts = False
Cells.Select
Cells.EntireColumn.AutoFit


ActiveWindow.SmallScroll Down:=-352
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.RowHeight = 21.75
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With

With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.LeftMargin = Application.InchesToPoints(0.15748031496063)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.31496062992126)
.BottomMargin = Application.InchesToPoints(0.31496062992126)
.PrintGridlines = True
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

Cells.Select
With Selection
.WrapText = False
End With

Rows("1:1").Select
With Selection
.WrapText = True
End With

Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 11
End With
Cells.Select
Cells.EntireColumn.AutoFit

Filename = agent & " " & fname & " " & tdate
ActiveWorkbook.SaveAs "C:\Documents and Settings\alexd\Desktop\Emails Sent\" & Filename & ".xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.Dialogs(xlDialogSendMail).Show
Application.DisplayAlerts = True
ActiveWindow.Close
Next
Selection.AutoFilter
End Sub


Thank you! ALEX