VBA Internet Explorer 脚本只有 50% 的时间有效

Question

我在 VBA 上有一个脚本可以加载网站、复制数据并将其粘贴到隐藏页面。它以前工作过，但我必须运行它大约 20 次才能让它做我想做的事。错误非常不一致，我正在考虑是否应该继续这样做，因为我需要至少 95% 的成功率。

Majority of the time the data is not copied correctly & the page is blank, the script finishes with out error but nothing happens.

The other time the script fails is on Set ieTable = ieDoc.all.item -- Do While ieApp.Busy: DoEvents: Loop -- Set ieDoc = ieApp.Document

如您所见，为了能够检查错误发生的位置，我用消息提示困扰了一切。

Sub Pull_Data()

    'Kills ALL IE windows
    On Error GoTo Ignore:
    Call IE_Sledgehammer
    Ignore:

    Dim ieApp As InternetExplorer
    Dim ieDoc As Object
    Dim ieTable As Object
    Dim clip As DataObject
    Dim UserName As String, Password As String
    Dim SubmitButton
    Dim i As Integer

    'Create anew instance of ie
    Set ieApp = New InternetExplorer
    ieApp.Navigate "Intranet site I cannot share"

    'Debugging
    ieApp.Visible = True

    'When busy - wait
    On Error GoTo Skip_wait
    Do While ieApp.Busy: DoEvents: Loop
    Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
    GoTo Login

    'Debugging
    Skip_wait:
    MsgBox ("You skipped the first wait")

    Login:
    '*****common error*****
    Set ieDoc = ieApp.Document
    Set SubmitButton = ieDoc.getElementsByTagName("input")

    'Login script
    With ieDoc.forms(0)
    If Err.Number = 424 Then
    GoTo skip_login

    .UserName.Value = "USERNAME"
    .Password.Value = "PASSWORD"
    SubmitButton(i).Click
    End If
    End With
    GoTo wait

    'Debugging
    skip_login:
    MsgBox ("You skipped the login")

    'When busy - wait
    wait:
    On Error GoTo Skip_waiting
    Do While ieApp.Busy: DoEvents: Loop
    Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
    GoTo Copypaste

    Skip_waiting:
    MsgBox ("You skipped the second wait")

    'Copy&paste script
    Copypaste:
    Set clip = New DataObject
    Set ieTable = ieDoc.all.item
    clip.SetText "" & ieTable.outerHTML & ""
    clip.PutInClipboard
    Sheets("Raw Data").Range("E2").PasteSpecial "Unicode Text"

    'Kills all activeX/controls copied from ieDoc.all.item
    Sheets("Raw Data").DrawingObjects.Delete

    'Kills ALL IE windows
    On Error GoTo Ignored:
    Call IE_Sledgehammer
    Ignored:

    End Sub

I do know about the pull data from web option which was my goto on this stuff, but since our office has changed its security settings, its made that option impossible. Other than this, I cannot think of a way to pull data from a click of a button.

Is this option worth it? For anyone with experience with this, Can you tell me if this option is reliable? I cannot for the life of me work out why this is failing.

HTML:

<html><head>
    <title>
        Open Questions Summary
    </title>
    <link rel="stylesheet" href="/styles.css" type="text/css">
</head>
<body bgcolor="#FFFFFF">
    <table cellspacing="1" cellpadding="2" align="center" border="0" width="400">
        <tbody><tr>
            <td colspan="2">
                Customer Sector: 
                <form method="get" action="INTERNAL WORK SITE">
                    <select name="strCustomerType">
                        <option value="residential" selected="selected">Residential</option>
                        <option value="business">Business</option>
                    </select>
                    <input name="soobmit" value="Submit" type="submit">
                </form></table>

Answer 1

从你的代码和描述来看，你似乎想在文本框中填充值并处理下拉列表，我建议你可以参考下面的代码，它们在我的机器上都运行良好：

Sub LoginViaBrowser()
    Dim IE As Object

    Dim Dc_Usuario As String
    Dim Dc_Senha As String
    Dim Dc_URL As String

    Dim txtNam As Object, txtPwd As Object

    Dc_Usuario = "user@email.com"
    Dc_Senha = "pass"

    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Visible = True
        .Navigate "https://www.solarmanpv.com/portal/LoginPage.aspx"

        While IE.ReadyState <> 4
            DoEvents
        Wend
        IE.Document.getElementById("uNam").Value = Dc_Usuario
        IE.Document.getElementById("uPwd").Value = Dc_Senha

        IE.Document.getElementById("Loginning").Click

    End With
    Set IE = Nothing
End Sub

处理下拉列表：

Public Sub ClickTest()

    Dim  ie As Object, evtChange As Object

    Dim item As Object

    Set ie = CreateObject("InternetExplorer.Application")
    With ie
        .Visible = True
        .Navigate2 "<the website url>"

        While .Busy Or .readyState <> 4: DoEvents: Wend

        Set evtChange = .Document.createEvent("HTMLEvents")
        evtChange.initEvent "change", True, False

        'get the select element. Please note the index, it is starting from 0.
        Set item = ie.Document.getElementsByTagName("select")(0)

        expCcy = "EUR"

        'Set the Expression Currency
        For Each o In item 'Sets Expression Currency
            If o.Value = expCcy Then
                o.Selected = True
                o.dispatchEvent evtChange
                Exit For
            End If
        Next        
    End With
End Sub

更多详细信息，请查看以下主题： and 。

VBA Internet Explorer 脚本只有 50% 的时间有效

VBA Internet explorer script only works 50% of the time

excel

internet-explorer

parsing

automation

vba