Я запускаю приведенный ниже код, но кажется, что он не выполняет цикл. Он отлично работает только для одной ячейки, но не работает для других ячеек в пределах определенного диапазона.
Добавлен код печати 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