I am trying to export the print area as picture. I have tried some codes and some works well but I have a little problem
The print area is $A$11:$I$26 and I need to include the headers in A1:I1 (the title rows) to be in the same picture that will be exported
Any idea how to do that?
This is my try till now but O got error of not being able to deal with multiple selections
Code: Select all
Sub pic_save()
Dim PicPath As String
Dim OutPutPath As String
Dim wS As Worksheet
Set wS = ThisWorkbook.Sheets("Sheet1")
OutPutPath = ThisWorkbook.Path & "\"
'wS.Range(wS.PageSetup.PrintArea).Address
Dim s As String
s = Union(wS.Range("A1:I1"), wS.Range(wS.PageSetup.PrintArea)).Address
PicPath = Generate_Image_From_Range(wS, s, OutPutPath, "pic", "png", False)
MsgBox wS.Name & " exported to : " & vbCrLf & _
PicPath, vbInformation + vbOKOnly
End Sub
Public Function Generate_Image_From_Range(wS As Worksheet, _
RgStr As String, _
OutPutPath As String, _
ImgName As String, _
ImgType As String, _
Optional TrueToTuneFilters As Boolean = False) As String
Dim ImgPath As String
Dim oRng As Range
Dim oChrtO As ChartObject
Dim lWidth As Long, lHeight As Long
Dim ActSh As Worksheet
Dim ValScUp As Boolean
ImgPath = OutPutPath & ImgName & "." & ImgType
Set ActSh = ActiveSheet
Set oRng = wS.Range(RgStr)
wS.Activate
'On Error GoTo ErrHdlr
With oRng
.Select
'''Zoom to improve render
ValScUp = Application.ScreenUpdating
Application.ScreenUpdating = False
ActiveWindow.Zoom = True
DoEvents
Application.ScreenUpdating = ValScUp
lWidth = .Width
lHeight = .Height
.CopyPicture xlScreen, xlPicture 'Best render
End With 'oRng
Set oChrtO = wS.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
With oChrtO
.Activate
.Chart.Paste
With .ShapeRange
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
With .Chart.Shapes.Item(1)
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
End With '.Chart.Shapes.Item (1)
End With '.ShapeRange
With .Chart
DoEvents
.Export Filename:=ImgPath, Filtername:=ImgType, Interactive:=TrueToTuneFilters
' If Not TrueToTuneFilters Then _
' .Export filename:=ImgPath, Filtername:=ImgType, Interactive:=False
' If TrueToTuneFilters Then _
' .Export filename:=ImgPath, Filtername:=ImgType, Interactive:=True
End With '.Chart
DoEvents
.Delete
End With 'oChrtO
ActSh.Activate
Generate_Image_From_Range = ImgPath
On Error GoTo 0
Exit Function
ErrHdlr:
Generate_Image_From_Range = vbNullString
End Function
