Sub ExportAsPDF()
Dim Ini As String
Dim FNm As Variant
Dim Shp As Shape
Dim Top As Long
Dim Btm As Long
Dim Lft As Integer
Dim Rgt As Integer
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
With ActiveWorkbook
Ini = .Path & Application.PathSeparator
If InStr(.Name, ".") = 0 Then
Ini = Ini & .Name
Else
Ini = Ini & Left(.Name, InStr(.Name, ".") - 1)
End If
End With
FNm = Application.GetSaveAsFilename( _
InitialFileName:=Ini, _
FileFilter:="Adobe Acrobat Document (*.pdf), *.pdf", _
Title:="Save As")
If FNm = False Then Exit Sub
With ActiveSheet
Top = .Rows.Count
Lft = .Columns.Count
End With
Btm = 1
Rgt = 1
For Each Shp In ActiveSheet.Shapes
With Shp.TopLeftCell
If .Row < Top Then Top = .Row
If .Column < Lft Then Lft = .Column
End With
With Shp.BottomRightCell
If .Row > Btm Then Btm = .Row
If .Column > Rgt Then Rgt = .Column
End With
Next Shp
With ActiveSheet
.PageSetup.PrintArea = .Range(Cells(Top, Lft), Cells(Btm, Rgt)).Address
End With
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.PrintCommunication = True
On Error Resume Next
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FNm, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
If Err.Number <> 0 Then
MsgBox _
Prompt:= _
"The action can't be completed because the file is open in Adobe Reader" & _
vbCrLf & vbCrLf & "Close the file and try again.", _
Buttons:=vbExclamation, _
Title:="File In Use"
End If
On Error GoTo 0
End Sub