时间戳

首页 > 解决方案 > Excel Vba Loop IE - 未运行

vba - Excel Vba Loop IE - 未运行

问题描述

我正在运行下面的代码，但它似乎没有执行循环。它仅适用于单个单元格，但不适用于定义范围内的其他单元格。

在下方添加了 PDF 打印代码

Sub SearchBot()
    Dim objie As InternetExplorer
    Dim aEle As HTMLLinkElement
    Dim y As Integer
    Dim result As String
    Dim form As Variant, button As Variant
    Dim cell As Range
    Dim rng As Range
    Dim i As Integer
    Dim lastrow As Long
    lastrow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
    Set objie = New InternetExplorer
    Set rng = Range("A2:A" & lastrow)
    user = Environ("username")
    objie.Visible = True

    For Each cell In rng
        objie.Navigate "https://www.google.com.sg/search" & _
            "?q=(fraud)&tbm=nws&spf=1495542183367&cad=h"
        Do While objie.Busy = True Or objie.ReadyState <> 4: DoEvents: Loop
        objie.Document.getElementById("lst-ib").Value = cell.Value & " (fraud)"
        Set form = objie.Document.body.getElementsByTagName("form")(0)
        Set button = form.getElementsByTagName("button")(0)
        button.Click
        Do While objie.Busy = True Or objie.ReadyState <> 4: DoEvents: Loop
        TimeOutWebQuery = 5
        TimeOutTime = DateAdd("s", TimeOutWebQuery, Now)
        Do Until objie.ReadyState = 4
            DoEvents
            If Now > TimeOutTime Then
                objie.Stop
                GoTo ErrorTimeOut
            End If
        Loop
        objie.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
        Call PDFPrint("C:\Users\" & user & "\Desktop\" & "Screening_" & _
            cell.Value & " " & cell.Offset(0, 1).Value & ".pdf")
ErrorTimeOut:
        Set objie = Nothing
    Next cell
End Sub

我正在运行下面的代码，但它似乎没有执行循环。它仅适用于单个单元格，但不适用于定义范围内的其他单元格。

在下方添加了 PDF 打印代码

Sub PDFPrint(strPDFPath As String)

Dim Ret                 As Long
Dim ChildRet            As Long
Dim ChildRet2           As Long
Dim ChildRet3           As Long
Dim comboRet            As Long
Dim editRet             As Long
Dim ChildSaveButton     As Long
Dim PDFRet              As Long
Dim PDFName             As String
Dim StartTime           As Date

StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
    Ret = 0
    DoEvents
    Ret = FindWindow(vbNullString, "Save PDF File As")
    If Ret <> 0 Then Exit Do
Loop

If Ret <> 0 Then
    SetForegroundWindow (Ret)
    StartTime = Now()
    Do Until Now() > StartTime + TimeValue("00:00:05")
        ChildRet = 0
        DoEvents
        ChildRet = FindWindowEx(Ret, ByVal 0&, "DUIViewWndClassName", vbNullString)
        If ChildRet <> 0 Then Exit Do
    Loop

    If ChildRet <> 0 Then
        StartTime = Now()
        Do Until Now() > StartTime + TimeValue("00:00:05")
            ChildRet2 = 0
            DoEvents
            ChildRet2 = FindWindowEx(ChildRet, ByVal 0&, "DirectUIHWND", vbNullString)
            If ChildRet2 <> 0 Then Exit Do
        Loop

        If ChildRet2 <> 0 Then
            StartTime = Now()
            Do Until Now() > StartTime + TimeValue("00:00:05")
                ChildRet3 = 0
                DoEvents
                ChildRet3 = FindWindowEx(ChildRet2, ByVal 0&, "FloatNotifySink", vbNullString)
                If ChildRet3 <> 0 Then Exit Do
            Loop

            If ChildRet3 <> 0 Then
                StartTime = Now()
                Do Until Now() > StartTime + TimeValue("00:00:05")
                    comboRet = 0
                    DoEvents
                    comboRet = FindWindowEx(ChildRet3, ByVal 0&, "ComboBox", vbNullString)
                    If comboRet <> 0 Then Exit Do
                Loop

                If comboRet <> 0 Then
                    StartTime = Now()
                    Do Until Now() > StartTime + TimeValue("00:00:05")
                        editRet = 0
                        DoEvents
                        editRet = FindWindowEx(comboRet, ByVal 0&, "Edit", vbNullString)
                        If editRet <> 0 Then Exit Do
                    Loop

                    If editRet <> 0 Then
                        SendMessage editRet, WM_SETTEXT, 0&, ByVal " " & strPDFPath
                        keybd_event VK_DELETE, 0, 0, 0
                        keybd_event VK_DELETE, 0, KEYEVENTF_KEYUP, 0
                        On Error Resume Next
                        PDFName = Mid(strPDFPath, WorksheetFunction.Find("*", WorksheetFunction.Substitute(strPDFPath, "\", "*", Len(strPDFPath) _
                        - Len(WorksheetFunction.Substitute(strPDFPath, "\", "")))) + 1, Len(strPDFPath))
                        On Error GoTo 0

                        Sleep 1000
                        ChildSaveButton = FindWindowEx(Ret, ByVal 0&, "Button", "&Save")
                        SendMessage ChildSaveButton, BM_CLICK, 0, 0

                        Do Until CheckPrinterStatus("Adobe PDF") = "Idle"
                            DoEvents
                            If CheckPrinterStatus("Adobe PDF") = "Error" Then Exit Do
                        Loop

                        StartTime = Now()
                        Do Until StartTime > StartTime + TimeValue("00:00:05")
                            PDFRet = 0
                            DoEvents
                            PDFRet = FindWindow(vbNullString, PDFName & " - Adobe Acrobat")
                            If PDFRet <> 0 Then Exit Do
                        Loop
                        If PDFRet <> 0 Then
                            PostMessage PDFRet, WM_CLOSE, 0&, 0&
                        End If
                    End If
                End If
            End If
        End If
    End If
 End If
End Sub

Function CheckPrinterStatus(strPrinterName As String) As String


Dim strComputer As String
Dim objWMIService As Object
Dim colInstalledPrinters As Variant
Dim objPrinter As Object

On Error Resume Next
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery("Select * from Win32_Printer")

If Err.Number <> 0 Then
    CheckPrinterStatus = "Error"
End If
On Error GoTo 0

For Each objPrinter In colInstalledPrinters
    If objPrinter.Name = strPrinterName Then
        Select Case objPrinter.PrinterStatus
            Case 1: CheckPrinterStatus = "Other"
            Case 2: CheckPrinterStatus = "Unknown"
            Case 3: CheckPrinterStatus = "Idle"
            Case 4: CheckPrinterStatus = "Printing"
            Case 5: CheckPrinterStatus = "Warmup"
            Case 6: CheckPrinterStatus = "Stopped printing"
            Case 7: CheckPrinterStatus = "Offline"
            Case Else: CheckPrinterStatus = "Error"
        End Select
    End If
Next objPrinter

If CheckPrinterStatus = "" Then CheckPrinterStatus = "Error"

End Function

标签： vbaexcelloopsweb-scraping

解决方案

您必须set objie=Nothing退出循环，否则您将删除对 IE 的引用，并且在循环的下一步objie.Navigate中将失败。

Sub SearchBot()
    Dim objie As InternetExplorer
    Dim aEle As HTMLLinkElement
    Dim y As Integer
    Dim result As String
    Dim form As Variant, button As Variant
    Dim cell As Range
    Dim rng As Range
    Dim i As Integer
    Dim lastrow As Long
    lastrow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
    Set objie = New InternetExplorer
    Set rng = Range("A2:A" & lastrow)
    user = Environ("username")
    objie.Visible = True

    For Each cell In rng
        objie.Navigate "https://www.google.com.sg/search" & _
            "?q=(fraud)&tbm=nws&spf=1495542183367&cad=h"
        Do While objie.Busy = True Or objie.ReadyState <> 4: DoEvents: Loop
        objie.Document.getElementById("lst-ib").Value = cell.Value & " (fraud)"
        Set form = objie.Document.body.getElementsByTagName("form")(0)
        Set button = form.getElementsByTagName("button")(0)
        button.Click
        Do While objie.Busy = True Or objie.ReadyState <> 4: DoEvents: Loop
        TimeOutWebQuery = 5
        TimeOutTime = DateAdd("s", TimeOutWebQuery, Now)
        Do Until objie.ReadyState = 4
            DoEvents
            If Now > TimeOutTime Then
                objie.Stop
                GoTo ErrorTimeOut
            End If
        Loop
        objie.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
        Call PDFPrint("C:\Users\" & user & "\Desktop\" & "Screening_" & _
            cell.Value & " " & cell.Offset(0, 1).Value & ".pdf")
    Next cell

ErrorTimeOut:
        Set objie = Nothing

End Sub

更新AFAIK，您不能将文件名传递给 ExecWB，但我可能错了。愿这值得一试

Const PRINT_WAITFORCOMPLETION = 2
...

objie.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, PRINT_WAITFORCOMPLETION
Call PDFPrint("C:\Users\" & user & "\Desktop\" & "Screening_" & _
         cell.Value & " " & cell.Offset(0, 1).Value & ".pdf")

这样 PDFPrint 可能会找到正确的窗口。您还必须确保您的窗口标题确实是保存 PDF 文件，否则 PDFPrint 中调用的函数将失败

Ret = FindWindow(vbNullString, "Save PDF File As")

推荐阅读