Question

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

好的，我将显示我的卡。这项工作最初是从“学习VBA领域”项目（打印保存的图片）开始的，所以我尝试从网站上获取有关我的到来的数据，然后打印当天是几号，星期几到今天等等。由于固定范围有所帮助，因此显示了全部代码，但是在通过vbs脚本启动时，我仍然有10％的情况手动运行，而有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

要求：将第一个工作表的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文件。

原始过程：

area

该帖子中最初说明的过程使用PageSetup.PrintArea property作为范围的参考，创建了一个名为PrintArea的范围。

如果将PrintArea设置为整个工作表，则Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)属性将等于一个空字符串，并且下面的指令将产生错误。

PrintArea

由于该过程正在打印空白页，因此我们可以假定A1-style reference属性是有效的PageSetup.PrintArea。

至少在以下情况下，可以复制A1-style reference属性为有效的PrintArea时空白页的打印：
1.当与PrintArea对应的范围实际上是一个空单元格的范围时，
2.当与Chart.SourceData对应的范围的行或列被隐藏时，
3.打印图表时，尽管图表的行和列可见，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），因此可以进行必要的更正

 <Grid container spacing={24}>
   <Grid item xl={6} md={6} sm={12} xs={12}>
     <TextField
      required
      id="outlined-email-input"
      label="Customer Name"
      name="email"
      fullWidth
     />
    </Grid>
    <Grid item xl={6} md={6} sm={12} xs={12}>
      <TextField
       required
       id="outlined-email-input"
       label="Customer Name"
       name="email"
       fullWidth
      />
     </Grid>
  </Grid>

Answer 2

听起来好像您想保存要打印区域的图像，即使用户尚未指定打印区域。问题是，如果用户未指定Excel，则Excel没有.PrintArea值。有关更多详细信息，请参见下文。

为确保代码正常工作，如果未设置打印区域，则可以提早停止代码：

If ThisWorkbook.Sheets(1).PageSetup.PrintArea = vbNullString Then
    MsgBox "No print area has been set.", vbCritical, "Save Sheet"
    Exit Sub
End If

或者您可以通过将其放置在宏的开头来手动设置打印区域以包括所有值：

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

请注意，这与默认打印区域相似，从A1开始，但不包括更远的仅包含格式或对象的单元格。这可能足以满足您的需求，但是如果您不希望它从A1开始或者需要包含仅包含格式或对象的单元格，则可以对其进行进一步调整。

“默认打印区域”的注意事项

在打印时，严格来说没有Excel确定的默认打印区域。相反，它将打印从A1开始（无论内容从何处开始）以包含所有包含任何值，格式或对象的所有单元格所需的连续页。这不一定是矩形区域，并且打印的页数可能取决于打印顺序。它还不一定包含.UsedArea

中的所有单元格

例如，在W15（向右3页）和E70（向后1页）中输入值。如果在没有设置打印区域的情况下进行打印，Excel将从A1中的空白页开始。默认的打印顺序设置为“先下后跨”，将导致从以下布局打印5页：第1,4,2,5,3页。更改为从头开始打印，将仅打印4页：第1,2,3,4页。手动设置打印区域将导致以指定的顺序打印全部6页。

Answer 3

从学习中得知Chart.Paste引起了问题，并且在Web上进行研究后，我发现Chart.Paste在VBA本身中被严重破坏了。必须通过代码手动激活它。我还发现不再需要打印区域，因为我只是将所需范围传递给了PrintArea，然后将PrintArea值写入了另一个未知区域。所以这是代码，它修复了有问题的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

PageSetup.PrintArea无法按预期工作

3 个答案: