Question

我正在尝试修复excel宏以自动填充Web表单。安全设置不允许表单被更快地操纵，然后人们可以输入信息。我想包括一个计时器，以便将每个条目的进程减慢到一秒，但我不确定如何执行此操作。以下是VBA：

Sub Load()
On Error Resume Next
    ActiveWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\system32\MSHTML.TLB"
    ActiveWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\system32\ieframe.dll"

Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer
Dim oHTML_Element As IHTMLElement
Dim sURL As String
Dim WPid As String
Dim WPpercent As Double
Dim Total As Double
Dim WPname As String
Dim dblClock As Double
Dim Percent As Double
On Error GoTo Err_Clear

WPid = Range("A2")
sURL = ****
'Set oBrowser = New InternetExplorer
'oBrowser.Silent = True
'oBrowser.timeout = 60
'oBrowser.navigate sURL
'oBrowser.Visible = True


'Do
  'Wait till the Browser is loaded
'Loop Until oBrowser.readyState = READYSTATE_COMPLETE


  'Reads out the object on the website
  'For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
  'Debug.Print oHTML_Element.Name
  'Debug.Print oHTML_Element.Value
  'Next


    Range("B2").Select

    Set oBrowser = New InternetExplorer
    'oBrowser.Silent = True
    'oBrowser.timeout = 60
    oBrowser.navigate sURL
    oBrowser.Visible = True

    Do
        'Wait till the Browser is loaded
    Loop Until oBrowser.readyState = READYSTATE_COMPLETE

    Set HTMLDoc = oBrowser.document

    Do While ActiveCell <> Empty And HTMLDoc.all.PrctRem.Value <> 0
        WPpercent = Round(ActiveCell * 100, 2)
        Percent = HTMLDoc.all.PrctRem.Value
    If Percent = 0 Then Exit Do

        ActiveCell.Offset(0, 1).Select
        WPname = ActiveCell

    If WPpercent > Percent Then
        HTMLDoc.all.QBDPerct.Value = Percent
    Else
        HTMLDoc.all.QBDPerct.Value = WPpercent
    End If
        HTMLDoc.all.QBDLn.Value = WPname


    'Do
    'Loop Until HTMLDoc.all.QBDTot.Value = 100 - Percent And HTMLDoc.all.QBDPerct.Value = 0

        ActiveCell.Offset(1, -1).Select

    'Windows("QBD Load Tool").Visible = True
    'MsgBox "Load next Event?"
    'oBrowser.Quit

    'oBrowser.Refresh
    HTMLDoc.all.Insert.Click
    Do While oBrowser.Busy
    Loop

    'Do
        'Wait till the Browser is loaded
    'Loop Until oBrowser.readyState = READYSTATE_COMPLETE

    'Set oBrowser = Nothing


        'dblClock = Timer
        'While Timer < dblClock + 1.3
        'DoEvents
        'Wend

    Loop


oBrowser.Quit
Set oBrowser = Empty
Windows("QBD Load Tool").Activate
MsgBox ("Load Complete. Check QBD and Save")
    Set oBrowser = New InternetExplorer
    oBrowser.Silent = True
    oBrowser.timeout = 60
    oBrowser.navigate sURL
    oBrowser.Visible = True
Err_Clear:
If Err <> 0 Then
Err.Clear
Resume Next

End If


End Sub

有什么建议吗？

Answer 1

等一秒钟：

Application.Wait(Now + TimeValue("0:00:01"))

Answer 2

在脚本顶部尝试此操作...它会在您开始从中抓取数据之前强制页面完全加载。

Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop

如果页面未加载，则无法从中获取数据。

使用VBA从excel自动填充Web表单

2 个答案: