Знаю, коллеги, знаю, что миллион подобных тем. И вот из них и составлен код, который немного хочу подправить:
Код
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
Необходимо чтобы: 1. Текущий лист сохранялся в pdf 2. После сохранения открывалась папка, в которой был сохранен pdf 3. (добавил) Буду сверщасилив если еще перед сохранением будет проверять - заполнены ли ячейки C2 и C5
Представленный код содержит излишний функционал, но боюсь самостоятельно справиться с очисткой я не сумел.
Sub jjj_activesheet_to_pdf()
Dim pdfName
With ActiveSheet
pdfName = Application.GetSaveAsFilename(.Name, "Acrobat PDF (*.pdf),*.pdf")
If pdfName = False Then Exit Sub
If IsEmpty([C2]) Then [C2].Select: Exit Sub
If IsEmpty([C5]) Then [C5].Select: Exit Sub
.ExportAsFixedFormat xlTypePDF, pdfName, xlQualityStandard, False, False, OpenAfterPublish:=False
End With
Shell "explorer /select," & pdfName, vbNormalFocus
End Sub 'jjj_activesheet_to_pdf