excel - PageSetup.PrintArea 未按预期工作

Question

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

好的，我会亮出我的底牌。这开始于“学习 VBA 的这一领域”项目(打印保存图片)，所以我尝试从网站上提取有关我上类的数据，然后打印今天是哪一天，到目前为止我们离这周还有多远等。由于固定范围有所帮助，因此显示了整个代码，但在 10% 的情况下手动运行时我仍然得到空白页，在 win 启动后通过 vbs 脚本运行时我仍然得到 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

Answer 1

要求:将第一个工作表的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 样式引用。

当 PageSetup.PrintArea 属性是有效的 A1 样式引用 时，至少可以在以下情况下复制空白页的打印:
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