Question

我创建了一个代码，可以从网站中提取某些数据，将其添加到工作表中，然后检查它是哪一天并修改进度条（仅限工作表中的列）。然后代码将当前结果保存在工作表上作为图像，最后将其设置为墙纸。起初我不得不处理“未知”的问题。我运行代码失败了。但是当我一步一步地调试它时，它运行得很好。我发现我的工作簿必须被破坏。所以我将VBA复制到一个新的工作簿，最后代码运行正常。几天后我开始出现像单元格对象全局失败等错误。我读到当某些对象没有充分定义时会发生这种情况所以我将thisworkbook.sheets(1).cells添加到出现错误的每个单元格对象中。这并没有帮助，因为即使在最基本的基本内容中，错误也开始出现。所以我转移了工作手册，揭示了这个问题。或者我认为..宏每次运行时都会删除当前的表格。几天前它没有。没有任何改变..我将粘贴下面的代码。工作簿是否再次损坏，如何防止它？

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
    ThisWorkbook.Close SaveChanges:=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 = "someWebsite"
    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("someclassname")
    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

zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
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
    DoEvents
    oCht.Chart.Paste
    DoEvents
    DoEvents
    oCht.Chart.Export Filename:="somepath\savedImage.bmp", Filtername:="bmp"
    DoEvents
    oCht.Delete
    Application.DisplayAlerts = True

End Sub

Sub changeWallpaper()
Dim strImagePath As String

    strImagePath = "somepath\savedImage.bmp"
    Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)

End Sub






Sub saveSheetBackup()
Dim oCht
Worksheets("List1").Range("B2:Q37").CopyPicture xlScreen, xlBitmap

    Application.DisplayAlerts = False
    Set oCht = Charts.Add
    DoEvents
    oCht.Paste
    DoEvents
    oCht.Export Filename:="somepath\savedImage.bmp", Filtername:="bmp"
    DoEvents
    oCht.Delete
    Application.DisplayAlerts = True
End Sub

Answer 1

我有顿悟。我已将try替换为简单Thisworkbook.Close，并禁用了警报，这就是诀窍。我仍然不太明白为什么在没有保存的情况下关闭工作簿会完全删除工作表。有人可以启发我吗？

VBA表现不佳，方法失败，床单消失

1 个答案: