excel - PageSetup.PrintArea无法按预期工作

我正在尝试打印出标记为Printarea的部分。但是，这段代码有时运行良好，有时却不好。确实没有规则。问题是，如何使它100％可运行。
运行良好时会做什么。它打印该区域，将其另存为“图片”，然后退出。
不这样做时会做什么。它打印空白页，上面没有任何数据，就像打印空白页一样。尽管页面空白，但页面打印的事实表明保存不是问题。
你能帮我吗？

好的，我将显示我的卡。最初是从“学习VBA领域”项目（打印保存的图片）开始的，所以我试图从网站上获取有关我的到来的数据，然后打印星期几，到今天为止还有多远等。由于固定范围有所帮助，因此显示了整个代码，但是在通过vbs脚本手动启动时，在10％的情况下，以及在win后启动时，有50％的情况下，我仍然得到空白页。基本上，我注意到压力很大的CPU与成功的代码运行直接相关。除始终成功的网站请求外，所有文件都是本地文件。

VBS：

Set objExcel = CreateObject("Excel.Application")
objExcel.Application.Run "'*someCorporatePath\newStart.xlsb'!Module1.Auto_Open"
objExcel.DisplayAlerts = False
objExcel.Application.Quit
Set objExcel = Nothing

模块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

最佳答案

要求：将第一个工作表的PrintArea保存为bmp文件。

原始程序：

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

帖子中最初说明的过程使用PageSetup.PrintArea property作为范围的参考来创建名为area的范围。

如果PrintArea设置为整个工作表，则PrintArea属性将等于一个空字符串，并且下面的指令将产生错误。

Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)

当过程打印空白页时，我们可以假定PrintArea属性是有效的A1-style reference。

PageSetup.PrintArea属性为有效的A1-style reference时，至少在以下情况下可以复制空白页的打印：
1.当与PrintArea对应的范围实际上是一个空单元格范围时，
2.当与PrintArea对应的范围隐藏其行或列时，
3.打印图表时，尽管可以看到图表的行和列，但Chart.SourceData的行或列是隐藏的，因此图表为空白。

原始程序已进行了调整，以要求用户验证输出，如果输出为空白，则会向用户显示打印范围（即Print.Area），因此可以进行必要的更正。

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