【发布时间】：2018-09-03 08:12:31
【问题描述】：
我正在运行下面的代码，但它似乎没有执行循环。它仅适用于单个单元格，但不适用于定义范围内的其他单元格。
在下方添加了 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
【问题讨论】：
-
cell 是一个错误的变量名，因为它已经用于 excel vba 中的单元格对象。不看其他东西，这可能是问题吗？
-
我认为这没有问题。它只是不执行循环，可能是因为 objie = nothing。不知道应该放在哪里？
-
尝试在所有情况下完全限定您的范围：
lastrow = Sheets("sheet1").Range("A" & Sheets("sheet1").Rows.Count).End(xlUp).Row -
还是一样。 :(
-
也许提供一些测试值
标签： vba excel loops web-scraping