Option Explicit

Private Sub Publish(ByVal FileName As String)
    Dim pBook As Workbook, pSheet As Worksheet
    Set pBook = Workbooks.Add(xlWBATWorksheet)
    Set pSheet = pBook.Worksheets(1)
    pSheet.Paste pSheet.Range("A1"), False
    'psheet.Pictures.
    With pSheet.PageSetup
        .PaperSize = xlPaperA4
        .Orientation = xlPortrait
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0.196850393700787)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)
    End With
    pSheet.ExportAsFixedFormat xlTypePDF, FileName, xlQualityStandard, False, False, OpenAfterPublish:=True
    pBook.Close False
End Sub

Public Sub ToPdfAsRaster()
    Dim firstRow As Long, lastRow As Long
    Dim firstCol As Long, lastCol As Long
    Dim pShape As Shape, pSheet As Worksheet
    Dim thisRange As Range, pdfName As String
    If TypeOf ActiveWorkbook.ActiveSheet Is Worksheet Then
        
        Set pSheet = ActiveWorkbook.ActiveSheet
        pdfName = Application.GetSaveAsFilename(pSheet.Name, "Acrobat PDF (*.pdf),*.pdf")
        If (UCase$(pdfName) = "FALSE") Or (UCase$(pdfName) = "ËÎÆÜ") Then Exit Sub
        ActiveWindow.DisplayGridlines = False
        Set thisRange = pSheet.UsedRange
        firstRow = thisRange.Row: lastRow = thisRange.Row + thisRange.Rows.Count - 1
        firstCol = thisRange.Column: lastCol = thisRange.Column + thisRange.Columns.Count - 1
        For Each pShape In pSheet.Shapes
            If pShape.TopLeftCell.Row < firstRow Then firstRow = pShape.TopLeftCell.Row
            If pShape.TopLeftCell.Column < firstCol Then firstCol = pShape.TopLeftCell.Column
            If pShape.BottomRightCell.Row > lastRow Then lastRow = pShape.BottomRightCell.Row
            If pShape.BottomRightCell.Column > lastCol Then lastCol = pShape.BottomRightCell.Column
        Next
        pSheet.Range(pSheet.Cells(firstRow, firstCol), pSheet.Cells(lastRow, lastCol)).CopyPicture xlScreen, xlBitmap
        Publish pdfName
    End If
End Sub