title: PageSetup.PrintArea doesn't work as intended
body: <p>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?</p>
  
  <p>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.</p>
  
  <p>VBS:</p>
  
  <pre><code>Set objExcel = CreateObject("Excel.Application")
  objExcel.Application.Run "'*someCorporatePath\newStart.xlsb'!Module1.Auto_Open"
  objExcel.DisplayAlerts = False
  objExcel.Application.Quit
  Set objExcel = Nothing
  </code></pre>
  
  <p>Module 1</p>
  
  <pre><code>    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 = &amp;H2
      Public Const SPIF_UPDATEINIFILE = &amp;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 &lt;&gt; 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&amp;, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
  
  End Sub
  </code></pre>