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

Question

我正在尝试修复一个 excel 宏以自动填充 Web 表单。 安全设置不允许比用户更快地操作表单。我想包含一个计时器，将每个条目的过程减慢到一秒，但不确定如何做到这一点。以下是 VBA：

Sub Load()
On Error Resume Next
    ActiveWorkbook.VBProject.References.AddFromFile "C:WINDOWSsystem32MSHTML.TLB"
    ActiveWorkbook.VBProject.References.AddFromFile "C:WINDOWSsystem32ieframe.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

等待 1 秒：

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

Answer 2

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

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

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