Excel Vba Loop IE-无法运行

时间：2018-09-03 08:12:32

标签： excel vba excel-vba loops web-scraping

我正在运行以下代码，但似乎无法执行循环。它仅可在单个单元格上完美运行，而在定义范围内的其他单元格上则无法运行。

在下面添加了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

1 个答案:

答案 0 :(得分：0)

您必须将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

更新，因为您无法将文件名传递给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")
相关问题
最新问题