Emoncada
12-17-2008, 10:05 AM
I have this vbcode that works great emailing a read-only copy of a worksheet. I want to know how I can email it as a PDF instead of an excel file.
Sub eMailActiveWorksheet()
Range("C3:C36").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-63
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G3:G23").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-63
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:C").Select
Range("C1").Activate
Selection.EntireColumn.Hidden = False
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Range("F1").Activate
Selection.EntireColumn.Hidden = False
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
'Date
Range("G1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Buttons.Visible = False
Dim OL As Object
Dim EmailItem As Object
Dim Wb As Workbook
Dim WbName As String
Dim FileName As String
Dim y As Long
Dim TempChar As String
Dim SaveName As String
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(0)
FileName = ActiveSheet.Name & " - " & ActiveWorkbook.Name
For y = 1 To Len(FileName)
TempChar = Mid(FileName, y, 1)
Select Case TempChar
Case Is = "/", "\", "*", "?", """", "<", ">", "|", ":"
Case Else
SaveName = SaveName & TempChar
End Select
Next y
ActiveSheet.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs SaveName
Wb.ChangeFileAccess xlReadOnly
With EmailItem
.Subject = "Inventory"
.Body = "Attached Is Today's Inventory" ' & vbCrLf & _
"Line 2" & vbCrLf & _
"Line 3"
.To = "abc123@yahoo.com"
.CC = ""
'.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Wb.FullName
.Send
End With
WbName = Wb.FullName
Wb.Close False
Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Kill WbName
Application.ScreenUpdating = True
Sub eMailActiveWorksheet()
Range("C3:C36").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-63
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G3:G23").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-63
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:C").Select
Range("C1").Activate
Selection.EntireColumn.Hidden = False
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Range("F1").Activate
Selection.EntireColumn.Hidden = False
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
'Date
Range("G1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Buttons.Visible = False
Dim OL As Object
Dim EmailItem As Object
Dim Wb As Workbook
Dim WbName As String
Dim FileName As String
Dim y As Long
Dim TempChar As String
Dim SaveName As String
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(0)
FileName = ActiveSheet.Name & " - " & ActiveWorkbook.Name
For y = 1 To Len(FileName)
TempChar = Mid(FileName, y, 1)
Select Case TempChar
Case Is = "/", "\", "*", "?", """", "<", ">", "|", ":"
Case Else
SaveName = SaveName & TempChar
End Select
Next y
ActiveSheet.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs SaveName
Wb.ChangeFileAccess xlReadOnly
With EmailItem
.Subject = "Inventory"
.Body = "Attached Is Today's Inventory" ' & vbCrLf & _
"Line 2" & vbCrLf & _
"Line 3"
.To = "abc123@yahoo.com"
.CC = ""
'.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Wb.FullName
.Send
End With
WbName = Wb.FullName
Wb.Close False
Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Kill WbName
Application.ScreenUpdating = True