PageSetup.PrintArea doesn't work as intended - excel

Question

I am trying to print out section, that is marked as Printarea. This code however sometimes runs good and sometimes it doesn't. There is really no rule with it. The question is, how can I make it 100% runnable.
What it does when it runs good. It prints the area, saves it as Picture and then quits.
What it does when it doesn't. It prints blank white page without any data on it, as if printing blank page. The fact that the page prints, evethough its blank suggests that the saving is not a problem.
Can you help?
OK, I will reveal my cards. This started as "learning this area of VBA" project (printing saving pictures), so I tried to pull data from website about my arrival to work and then printing what day it is, how far are we with the week so far etc. The whole code is revealed since the fixed range helped a bit, but I still get blank pages in 10% of cases when ran manually and 50% of cases when ran after win start via vbs script. basically I noticed that stressed CPU is in direct correlation to succesful code run. All files are local except for the website pull which is always succesful.
VBS:
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.Run "'*someCorporatePath\newStart.xlsb'!Module1.Auto_Open"
objExcel.DisplayAlerts = False
objExcel.Application.Quit
Set objExcel = Nothing
Module 1
Option Explicit
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
Public Const SPIF_UPDATEINIFILE = &H1
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Auto_Open()
Call getDataFromWebsite
Call weekProgress
Call saveSheet
Call changeWallpaper
Application.DisplayAlerts = False
Application.Quit
End Sub
Sub getDataFromWebsite()
Dim x As String
Dim IE As Object
Dim HtmlCon As HTMLDocument
Dim element As Object
Dim ArrivalTime
On Error GoTo Handler
x = "*Some-secret-corporate-website*"
Set IE = New InternetExplorerMedium
IE.Navigate (x)
IE.Visible = False
Do While IE.ReadyState <> 4
DoEvents
Loop
Set HtmlCon = IE.document
Set element = HtmlCon.getElementsByClassName("*someAJAXcorporateElement*")
ArrivalTime = element(0).innerText
ThisWorkbook.Sheets(1).Cells(3, 15).Value = ArrivalTime
Handler:
IE.Quit
End Sub
Sub weekProgress()
Dim caseResult As String
Dim offsetDayIndex As Integer
Const dayBarLenght = 2
Select Case Application.WorksheetFunction.Weekday(Date, 2)
Case 1
caseResult = "Monday"
offsetDayIndex = 0
Case 2
caseResult = "Tuesday"
offsetDayIndex = 1
Case 3
caseResult = "Wednesday"
offsetDayIndex = 2
Case 4
caseResult = "Thursday"
offsetDayIndex = 3
Case 5
caseResult = "Friday"
offsetDayIndex = 4
Case Else
caseResult = "Monday"
End Select
DoEvents
ThisWorkbook.Sheets(1).Cells(24, 11).Value = caseResult
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 12)).Interior.ColorIndex = 1
If Not caseResult = "Monday" Then
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 4 + (dayBarLenght * offsetDayIndex))).Interior.ColorIndex = 2
End If
End Sub
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
Dim intLastRow As Integer
Dim intLastCol As Integer
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
With ThisWorkbook.Sheets(1)
.PageSetup.PrintArea = .Range("A1", .Cells(37, 17)).Address
End With
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="*MyCorporatePath*", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
Sub changeWallpaper()
Dim strImagePath As String
strImagePath = "*MyCorporatePath*"
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub

Answer 1

Requirement: To save the PrintArea of the first worksheet as a bmp file.
Original procedure:
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="C:\Users\insertyourname\Pictures\savedImage.bmp", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
The procedure as originally stated in the post creates a range named area using the PageSetup.PrintArea property as the reference for the range.
If the PrintAreais set to the entire sheet then the PrintArea property would be equal to an empty string and the instruction below will generate an error.
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
As the procedure is printing a blank page, we can assume that the PrintArea property is a valid A1-style reference.
The printing of a blank page when the PageSetup.PrintArea property is a valid A1-style reference could be replicated at least in the following cases:
1. When the range corresponding to the PrintArea is in fact a range of empty cells,
2. When the range corresponding to the PrintArea has its rows or columns hidden,
3. When printing a chart and although the rows and columns of the chart are visible the rows or columns of the Chart.SourceData are hidden, thus the chart is blank.
The original procedure has been adjusted in order to ask the user to validate the output and if the output is blank them it presents the user with the printed range (i.e. the Print.Area) so the necessary corrections can be applied.
Sub Save_PrintArea_As_bmp()
Dim ws As Worksheet
Dim oCht As Object
Dim ddZoomCoef As Double
Dim rArea As Range
Set ws = ThisWorkbook.Worksheets(1) 'Modify as required
With ws
ddZoomCoef = 100 / .Parent.Windows(1).Zoom
Set rArea = .Range(.PageSetup.PrintArea)
rArea.CopyPicture xlPrinter
Set oCht = .ChartObjects.Add(0, 0, _
rArea.Width * ddZoomCoef, rArea.Height * ddZoomCoef)
End With
Application.DisplayAlerts = False
With oCht
.Chart.Paste
If MsgBox("Is the printed page blank?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
"Save PrintArea As bmp") = vbYes Then
.Delete
MsgBox "This is the PrintArea, validate that the range is visible."
With ws
.Activate
Application.Goto .Cells(1), 1
Application.Goto rArea
Exit Sub
Application.DisplayAlerts = True
End With
Else
.Chart.Export Filename:="D:\#D_Trash\savedImage.bmp", _
Filtername:="bmp" 'Modify as required
.Delete
End If: End With
Application.DisplayAlerts = True
End Sub

Answer 2

It sounds like you want to save an image of the area that would be printed, even if the user has not specified a print area. The problem is that Excel has no .PrintArea value if one has not been specified by a user. See below for further details.
To ensure the code works as intended, you can either stop the code early if no print area has been set:
If ThisWorkbook.Sheets(1).PageSetup.PrintArea = vbNullString Then
MsgBox "No print area has been set.", vbCritical, "Save Sheet"
Exit Sub
End If
Or you can set the print area manually to include all values by placing this at the start of the macro:
Dim intLastRow as Integer
Dim intLastCol As Integer
With ThisWorkbook.Sheets(1)
If .PageSetup.PrintArea = vbNullString Then
intLastRow = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False).Row
intLastCol = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
MatchCase:=False).Column
.PageSetup.PrintArea = .Range("A1", .Cells(intLastRow, intLastCol)).Address
End If
End With
Note that this closely mimics the default print area to start from A1, but does not include more distant cells that include only formatting or objects. This is likely sufficient for your needs, but it could be adjusted further if you didn't want it to start from A1 or if you need to include cells that contain only formatting or objects.
Notes on "Default Print Area"
There isn't strictly a default print area determined by Excel at the time of printing. It instead prints as many continuous pages as necessary to include all cells that contain any values, formatting or objects, starting from A1 (regardless of where content starts). This is not necessarily a rectangular area and the number of pages printed can depend on the print order. It also does not necessarily include all cells in the .UsedArea
For example, enter a value in W15 (3 pages to the right) and E70 (1 page down). If printing without setting a print area, Excel will start with a blank page from A1. The default print order setting of down-then-across will result in 5 pages being printed from the layout below: Pages 1,4,2,5,3. Changing to print across-then-down will result in only 4 pages being printed: Pages 1,2,3,4. Manually setting the print area instead results in all 6 pages being printed in whichever order is specified.

Answer 3

Upon learning, that Chart.Paste is causing the problem and upon researching in web I found that Chart.Paste is broken terribly in VBA itself. One has to manually activate it through the code. I also found that the printarea is no longer needed since I just passed the desired range to PrintArea and then wrote the PrintArea value to another unknown. So here is the code, that fixes the buggy Chart.Paste
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area As Range
Dim intLastRow As Integer
Dim intLastCol As Integer
Dim chartName As String
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = Range("A1", Cells(37, 17))
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
DoEvents
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
DoEvents
chartName = oCht.Chart.Name
ThisWorkbook.Sheets(1).Activate 'this one **********
oCht.Activate 'this one too ***********
Application.Wait (Now + TimeValue("0:00:02"))
oCht.Chart.Paste
Application.Wait (Now + TimeValue("0:00:02"))
DoEvents
oCht.Chart.Export Filename:="somePath", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub